(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

    This program 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.

    This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
*)

From mathcomp
Require Import ssreflect ssrbool ssrfun ssrnat eqtype.
From LemmaOverloading
Require Import rels prelude.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**********)
(* Posets *)
(**********)

(* We put bottom in posets right away, instead of adding it later both in *)
(* lattices and in cpos. Since we never consider bottom-less posets, this *)
(* saves some tedium and name space. *)

Module Poset.

Section RawMixin.

Record mixin_of (T : Type) := Mixin {
  mx_leq : T -> T -> Prop;
  mx_bot : T;
  _ : forall x, mx_leq mx_bot x;
  _ : forall x, mx_leq x x;
  _ : forall x y, mx_leq x y -> mx_leq y x -> x = y;
  _ : forall x y z, mx_leq x y -> mx_leq y z -> mx_leq x z}.

End RawMixin.

Section ClassDef.

Record class_of T := Class {mixin : mixin_of T}.

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

(* produce a poset type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack (m0 : mixin_of T) :=
  fun m & phant_id m0 m => Pack (@Class T m) T.

Definition leq := mx_leq (mixin class).
Definition bot := mx_bot (mixin class).

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Notation poset := Poset.type.
Notation PosetMixin := Poset.Mixin.
Notation Poset T m := (@pack T _ m id).

Notation "[ 'poset' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'poset'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'poset' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'poset'  'of'  T ]") : form_scope.

Notation "x <== y" := (Poset.leq x y) (at level 70).
Notation bot := Poset.bot.

Arguments Poset.bot {cT}.
Prenex Implicits Poset.bot.

(* re-state lattice properties using the exported notation *)
Section Laws.
Variable T : poset.

Lemma botP (x : T) : bot <== x.
Proof. by case: T x=>s [[leq b B]]. Qed.

Lemma poset_refl (x : T) : x <== x.
Proof. by case: T x=>S [[leq b B R]]. Qed.

Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Proof. by case: T x y=>S [[l b B R A Tr]] *; apply: (A). Qed.

Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
Proof. by case: T y x z=>S [[l b B R A Tr]] ? x y z; apply: (Tr). Qed.

End Laws.

Hint Resolve botP poset_refl : core.

Add Parametric Relation (T : poset) : T (@Poset.leq T)
  reflexivity proved by (@poset_refl _)
  transitivity proved by (fun x y => @poset_trans _ y x) as poset_rel.

End Exports.

End Poset.

Export Poset.Exports.

(**************************)
(* some basic definitions *)
(**************************)

Definition monotone (T1 T2 : poset) (f : T1 -> T2) :=
  forall x y, x <== y -> f x <== f y.

Section IdealDef.
Variable T : poset.

Structure ideal (P : T) := Ideal {id_val : T; id_pf : id_val <== P}.

(* Changing the type of the ideal *)

Lemma relaxP (P1 P2 : T) : P1 <== P2 -> forall p, p <== P1 -> p <== P2.
Proof. by move=>H1 p H2; apply: poset_trans H1. Qed.

Definition relax (P1 P2 : T) (x : ideal P1) (pf : P1 <== P2) :=
  Ideal (relaxP pf (id_pf x)).

End IdealDef.

(***********************)
(* poset constructions *)
(***********************)

Section SubPoset.
Variables (T : poset) (s : Pred T) (C : bot \In s).

Local Notation tp := {x : T | x \In s}.

Definition sub_bot : tp := exist _ bot C.
Definition sub_leq (p1 p2 : tp) := sval p1 <== sval p2.

Lemma sub_botP x : sub_leq sub_bot x.
Proof. by apply: botP. Qed.

Lemma sub_refl x : sub_leq x x.
Proof. by rewrite /sub_leq. Qed.

Lemma sub_asym x y : sub_leq x y -> sub_leq y x -> x = y.
Proof.
move: x y=>[x Hx][y Hy]; rewrite /sub_leq /= => H1 H2.
move: (poset_asym H1 H2) Hy=> <- Hy; congr exist.
by apply: proof_irrelevance.
Qed.

Lemma sub_trans x y z : sub_leq x y -> sub_leq y z -> sub_leq x z.
Proof.
move: x y z=>[x Hx][y Hy][z Hz]; rewrite /sub_leq /=.
by apply: poset_trans.
Qed.

(* no need to put canonical here, because the system won't be *)
(* able to get the proof C from the {x : T | x \In s} syntax *)
Definition subPosetMixin := PosetMixin sub_botP sub_refl sub_asym sub_trans.
Definition subPoset := Eval hnf in Poset tp subPosetMixin.

End SubPoset.

(* pairing of posets *)

Section PairPoset.
Variable (A B : poset).
Local Notation tp := (A * B)%type.

Definition pair_bot : tp := (bot, bot).
Definition pair_leq (p1 p2 : tp) := p1.1 <== p2.1 /\ p1.2 <== p2.2.

Lemma pair_botP x : pair_leq pair_bot x.
Proof. by split; apply: botP. Qed.

Lemma pair_refl x : pair_leq x x.
Proof. by []. Qed.

Lemma pair_asym x y : pair_leq x y -> pair_leq y x -> x = y.
Proof.
move: x y=>[x1 x2][y1 y2][/= H1 H2][/= H3 H4].
by congr (_, _); apply: poset_asym.
Qed.

Lemma pair_trans x y z : pair_leq x y -> pair_leq y z -> pair_leq x z.
Proof.
move: x y z=>[x1 x2][y1 y2][z1 z2][/= H1 H2][/= H3 H4]; split=>/=.
- by apply: poset_trans H3.
by apply: poset_trans H4.
Qed.

Definition pairPosetMixin :=
  PosetMixin pair_botP pair_refl pair_asym pair_trans.
Canonical pairPoset := Eval hnf in Poset tp pairPosetMixin.

End PairPoset.

(* functions into a poset form a poset *)

Section FunPoset.
Variable (A : Type) (B : poset).
Local Notation tp := (A -> B).

Definition fun_bot : tp := fun x => bot.
Definition fun_leq (p1 p2 : tp) := forall x, p1 x <== p2 x.

Lemma fun_botP x : fun_leq fun_bot x.
Proof. by move=>y; apply: botP. Qed.

Lemma fun_refl x : fun_leq x x.
Proof. by []. Qed.

Lemma fun_asym x y : fun_leq x y -> fun_leq y x -> x = y.
Proof.
move=>H1 H2; apply: fext=>z;
by apply: poset_asym; [apply: H1 | apply: H2].
Qed.

Lemma fun_trans x y z : fun_leq x y -> fun_leq y z -> fun_leq x z.
Proof. by move=>H1 H2 t; apply: poset_trans (H2 t). Qed.

Definition funPosetMixin := PosetMixin fun_botP fun_refl fun_asym fun_trans.
Canonical funPoset := Eval hnf in Poset tp funPosetMixin.

End FunPoset.

(* dependent functions into a poset form a poset *)

Section DFunPoset.
Variables (A : Type) (B : A -> poset).
Local Notation tp := (forall x, B x).

Definition dfun_bot : tp := fun x => bot.
Definition dfun_leq (p1 p2 : tp) := forall x, p1 x <== p2 x.

Lemma dfun_botP x : dfun_leq dfun_bot x.
Proof. by move=>y; apply: botP. Qed.

Lemma dfun_refl x : dfun_leq x x.
Proof. by []. Qed.

Lemma dfun_asym x y : dfun_leq x y -> dfun_leq y x -> x = y.
Proof.
move=>H1 H2; apply: fext=>z;
by apply: poset_asym; [apply: H1 | apply: H2].
Qed.

Lemma dfun_trans x y z : dfun_leq x y -> dfun_leq y z -> dfun_leq x z.
Proof. by move=>H1 H2 t; apply: poset_trans (H2 t). Qed.

(* no point in declaring this canonical, since it's keyed on forall *)
(* and forall is not a symbol *)
Definition dfunPosetMixin :=
  PosetMixin dfun_botP dfun_refl dfun_asym dfun_trans.
Definition dfunPoset := Eval hnf in Poset tp dfunPosetMixin.

End DFunPoset.

(* ideal of a poset is a poset *)

Section IdealPoset.
Variable (T : poset) (P : T).

Definition ideal_bot :=  Ideal (botP P).
Definition ideal_leq (p1 p2 : ideal P) := id_val p1 <== id_val p2.

Lemma ideal_botP x : ideal_leq ideal_bot x.
Proof. by apply: botP. Qed.

Lemma ideal_refl x : ideal_leq x x.
Proof. by case: x=>x H; rewrite /ideal_leq. Qed.

Lemma ideal_asym x y : ideal_leq x y -> ideal_leq y x -> x = y.
Proof.
move: x y=>[x1 H1][x2 H2]; rewrite /ideal_leq /= => H3 H4; move: H1 H2.
rewrite (poset_asym H3 H4)=>H1 H2.
congr Ideal; apply: proof_irrelevance.
Qed.

Lemma ideal_trans x y z : ideal_leq x y -> ideal_leq y z -> ideal_leq x z.
Proof. by apply: poset_trans. Qed.

Definition idealPosetMixin :=
  PosetMixin ideal_botP ideal_refl ideal_asym ideal_trans.
Canonical idealPoset := Eval hnf in Poset (ideal P) idealPosetMixin.

End IdealPoset.

(* Prop is a poset *)

Section PropPoset.

Definition prop_bot := False.
Definition prop_leq (p1 p2 : Prop) := p1 -> p2.

Lemma prop_botP x : prop_leq prop_bot x.
Proof. by []. Qed.

Lemma prop_refl x : prop_leq x x.
Proof. by []. Qed.

Lemma prop_asym x y : prop_leq x y -> prop_leq y x -> x = y.
Proof. by move=>H1 H2; apply: pext. Qed.

Lemma prop_trans x y z : prop_leq x y -> prop_leq y z -> prop_leq x z.
Proof. by move=>H1 H2; move/H1. Qed.

Definition propPosetMixin :=
  PosetMixin prop_botP prop_refl prop_asym prop_trans.
Canonical propPoset := Eval hnf in Poset Prop propPosetMixin.

End PropPoset.

(* Pred is a poset *)

(* Can be inherited from posets of -> and Prop, but we declare a *)
(* dedicated structure to keep the infix notation of Pred. Otherwise, *)
(* poset inference turns Pred A into A -> Prop. *)

Section PredPoset.
Variable A : Type.

Definition predPosetMixin : Poset.mixin_of (Pred A) :=
  funPosetMixin A propPoset.
Canonical predPoset := Eval hnf in Poset (Pred A) predPosetMixin.

End PredPoset.

(* nat is a poset *)
Section NatPoset.

Lemma nat_botP x : 0 <= x. Proof. by []. Qed.
Lemma nat_refl x : x <= x. Proof. by []. Qed.

Lemma nat_asym x y : x <= y -> y <= x -> x = y.
Proof. by move=>H1 H2; apply: anti_leq; rewrite H1 H2. Qed.

Lemma nat_trans x y z : x <= y -> y <= z -> x <= z.
Proof. by apply: leq_trans. Qed.

Definition natPosetMixin := PosetMixin nat_botP nat_refl nat_asym nat_trans.
Canonical natPoset := Eval hnf in Poset nat natPosetMixin.

End NatPoset.

(*********************)
(* Complete lattices *)
(*********************)

Module Lattice.

Section RawMixin.

Variable T : poset.

Record mixin_of := Mixin {
  mx_sup : Pred T -> T;
  _ : forall (s : Pred T) x, x \In s -> x <== mx_sup s;
  _ : forall (s : Pred T) x,
        (forall y, y \In s -> y <== x) -> mx_sup s <== x}.

End RawMixin.

Section ClassDef.

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

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

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

(* produce a lattice type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack b0 (m0 : mixin_of (Poset.Pack b0 T)) :=
  fun m & phant_id m0 m => Pack (@Class T b0 m) T.

Definition sup (s : Pred cT) : cT := mx_sup (mixin class) s.

Definition poset := Poset.Pack class cT.

End ClassDef.

Module Exports.
Coercion base : class_of >-> Poset.class_of.
Coercion sort : type >-> Sortclass.
Coercion poset : type >-> Poset.type.
Canonical Structure poset.

Notation lattice := Lattice.type.
Notation LatticeMixin := Lattice.Mixin.
Notation Lattice T m := (@pack T _ _ m id).

Notation "[ 'lattice' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'lattice'  'of'  T  'for' cT ]") : form_scope.
Notation "[ 'lattice' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'lattice'  'of'  T ]") : form_scope.

Arguments Lattice.sup [cT].
Prenex Implicits Lattice.sup.
Notation sup := Lattice.sup.

(* re-state lattice properties using the exported notation *)
Section Laws.
Variable T : lattice.

Lemma supP (s : Pred T) x : x \In s -> x <== sup s.
Proof. by case: T s x=>S [[p]][/= s H1 *]; apply: H1. Qed.

Lemma supM (s : Pred T) x : (forall y, y \In s -> y <== x) -> sup s <== x.
Proof. by case: T s x=>S [[p]][/= s H1 H2 *]; apply: (H2). Qed.

End Laws.

End Exports.

End Lattice.

Export Lattice.Exports.

(* we have greatest lower bounds too *)
Section Infimum.
Variable T : lattice.

Definition inf (s : Pred T) :=
  sup [Pred x : T | forall y, y \In s -> x <== y].

Lemma infP s : forall x, x \In s -> inf s <== x.
Proof. by move=>x H; apply: supM=>y; apply. Qed.

Lemma infM s : forall x, (forall y, y \In s -> x <== y) -> x <== inf s.
Proof. by apply: supP. Qed.

End Infimum.

(* we can compute least and greatest fixed points *)

Section Lat.
Variable T : lattice.

Definition tarski_lfp (f : T -> T) := inf [Pred x : T | f x <== x].
Definition tarski_gfp (f : T -> T) := sup [Pred x : T | x <== f x].

Definition sup_closed (T : lattice) :=
  [Pred s : Pred T |
     bot \In s /\ forall d, d <=p s -> sup d \In s].

Definition sup_closure (T : lattice) (s : Pred T) :=
  [Pred p : T | forall t : Pred T, s <=p t -> t \In sup_closed T -> p \In t].

End Lat.

Arguments sup_closed {T}.
Arguments sup_closure [T].
Prenex Implicits sup_closed sup_closure.

Section BasicProperties.
Variable T : lattice.

Lemma sup_mono (s1 s2 : Pred T) : s1 <=p s2 -> sup s1 <== sup s2.
Proof. by move=>H; apply: supM=>y; move/H; apply: supP. Qed.

Lemma supE (s1 s2 : Pred T) : s1 =p s2 -> sup s1 = sup s2.
Proof. by move=>H; apply: poset_asym; apply: supM=>y; move/H; apply: supP. Qed.

(* Knaster-Tarski *)
Lemma tarski_lfp_fixed (f : T -> T) :
        monotone f -> f (tarski_lfp f) = tarski_lfp f.
Proof.
move=>M; suff L: f (tarski_lfp f) <== tarski_lfp f.
- by apply: poset_asym=>//; apply: infP; apply: M L.
by apply: infM=>x L; apply: poset_trans (L); apply: M; apply: infP.
Qed.

Lemma tarski_lfp_least f : forall x : T, f x = x -> tarski_lfp f <== x.
Proof. by move=>x H; apply: infP; rewrite InE /= H. Qed.

Lemma tarski_gfp_fixed (f : T -> T) :
        monotone f -> f (tarski_gfp f) = tarski_gfp f.
Proof.
move=>M; suff L: tarski_gfp f <== f (tarski_gfp f).
- by apply: poset_asym=>//; apply: supP; apply: M L.
by apply: supM=>x L; apply: poset_trans (L) _; apply: M; apply: supP.
Qed.

Lemma tarski_gfp_greatest f : forall x : T, f x = x -> x <== tarski_gfp f.
Proof. by move=>x H; apply: supP; rewrite InE /= H. Qed.

(* closure contains s *)
Lemma sup_clos_sub (s : Pred T) : s <=p sup_closure s.
Proof. by move=>p H1 t H2 H3; apply: H2 H1. Qed.

(* closure is smallest *)
Lemma sup_clos_min (s : Pred T) :
        forall t, s <=p t -> sup_closed t -> sup_closure s <=p t.
Proof. by move=>t H1 H2 p; move/(_ _ H1 H2). Qed.

(* closure is closed *)
Lemma sup_closP (s : Pred T) : sup_closed (sup_closure s).
Proof.
split; first by move=>t _ [].
move=>d H1 t /sup_clos_min H3 H4.
by case: (H4) => _; apply=> x /H1/(H3 H4).
Qed.

Lemma sup_clos_idemp (s : Pred T) : sup_closed s -> sup_closure s =p s.
Proof. by move=>p; split; [apply: sup_clos_min | apply: sup_clos_sub]. Qed.

Lemma sup_clos_mono (s1 s2 : Pred T) :
        s1 <=p s2 -> sup_closure s1 <=p sup_closure s2.
Proof.
move=>H1; apply: sup_clos_min (sup_closP s2)=>p H2.
by apply: sup_clos_sub; apply: H1.
Qed.

End BasicProperties.

(* lattice constructions *)

Section SubLattice.
Variables (T : lattice) (s : Pred T) (C : sup_closed s).
Local Notation tp := (subPoset (proj1 C)).

Definition sub_sup' (u : Pred tp) : T :=
  sup [Pred x : T | exists y, y \In u /\ x = sval y].

Lemma sub_supX (u : Pred tp) : sub_sup' u \In s.
Proof. by case: C u=>P /= H u; apply: H=>t [[y]] H1 [_] ->. Qed.

Definition sub_sup (u : Pred tp) : tp :=
  exist _ (sub_sup' u) (sub_supX u).

Lemma sub_supP (u : Pred tp) (x : tp) : x \In u -> x <== sub_sup u.
Proof. by move=>H; apply: supP; exists x. Qed.

Lemma sub_supM (u : Pred tp) (x : tp) :
        (forall y, y \In u -> y <== x) -> sub_sup u <== x.
Proof. by move=>H; apply: supM=>y [z][H1] ->; apply: H H1. Qed.

Definition subLatticeMixin := LatticeMixin sub_supP sub_supM.
Definition subLattice := Eval hnf in Lattice {x : T | x \In s} subLatticeMixin.

End SubLattice.

(* pairing *)

Section PairLattice.
Variables (A B : lattice).
Local Notation tp := (A * B)%type.

Definition pair_sup (s : Pred tp) : tp :=
            (sup [Pred p | exists f, p = f.1 /\ f \In s],
             sup [Pred p | exists f, p = f.2 /\ f \In s]).

Lemma pair_supP (s : Pred tp) (p : tp) : p \In s -> p <== pair_sup s.
Proof. by move=>H; split; apply: supP; exists p. Qed.

Lemma pair_supM (s : Pred tp) (p : tp) :
        (forall q, q \In s -> q <== p) -> pair_sup s <== p.
Proof. by move=>H; split; apply: supM=>y [f][->]; case/H. Qed.

Definition pairLatticeMixin := LatticeMixin pair_supP pair_supM.
Canonical pairLattice := Eval hnf in Lattice tp pairLatticeMixin.

End PairLattice.

(* functions into a latice form a lattice *)

Section FunLattice.
Variables (A : Type) (B : lattice).
Local Notation tp := (A -> B).

Definition fun_sup (s : Pred tp) : tp :=
  fun x => sup [Pred p | exists f, f \In s /\ p = f x].

Lemma fun_supP (s : Pred tp) (p : tp) : p \In s -> p <== fun_sup s.
Proof. by move=>H x; apply: supP; exists p. Qed.

Lemma fun_supM (s : Pred tp) (p : tp) :
        (forall q, q \In s -> q <== p) -> fun_sup s <== p.
Proof. by move=>H t; apply: supM=>x [f][H1] ->; apply: H. Qed.

Definition funLatticeMixin := LatticeMixin fun_supP fun_supM.
Canonical funLattice := Eval hnf in Lattice tp funLatticeMixin.

End FunLattice.

(* dependent functions into a lattice form a lattice *)

Section DFunLattice.
Variables (A : Type) (B : A -> lattice).
Local Notation tp := (dfunPoset B).

Definition dfun_sup (s : Pred tp) : tp :=
  fun x => sup [Pred p | exists f, f \In s /\ p = f x].

Lemma dfun_supP (s : Pred tp) (p : tp) :
        p \In s -> p <== dfun_sup s.
Proof. by move=>H x; apply: supP; exists p. Qed.

Lemma dfun_supM (s : Pred tp) (p : tp) :
       (forall q, q \In s -> q <== p) -> dfun_sup s <== p.
Proof. by move=>H t; apply: supM=>x [f][H1] ->; apply: H. Qed.

Definition dfunLatticeMixin := LatticeMixin dfun_supP dfun_supM.
Definition dfunLattice := Eval hnf in Lattice (forall x, B x) dfunLatticeMixin.

End DFunLattice.

(* applied sup equals the sup of applications *)

Lemma sup_appE A (B : lattice) (s : Pred (A -> B)) (x : A) :
        sup s x = sup [Pred y : B | exists f, f \In s /\ y = f x].
Proof. by []. Qed.

Lemma sup_dappE A (B : A -> lattice) (s : Pred (dfunLattice B)) (x : A) :
        sup s x = sup [Pred y : B x | exists f, f \In s /\ y = f x].
Proof. by []. Qed.

(* ideal of a lattice forms a lattice *)

Section IdealLattice.
Variables (T : lattice) (P : T).

Definition ideal_sup' (s : Pred (ideal P)) :=
  sup [Pred x | exists p, p \In s /\ id_val p = x].

Lemma ideal_supP' (s : Pred (ideal P)) : ideal_sup' s <== P.
Proof. by apply: supM=>y [[x]] H /= [_] <-. Qed.

Definition ideal_sup (s : Pred (ideal P)) := Ideal (ideal_supP' s).

Lemma ideal_supP (s : Pred (ideal P)) p :
        p \In s -> p <== ideal_sup s.
Proof. by move=>H; apply: supP; exists p. Qed.

Lemma ideal_supM (s : Pred (ideal P)) p :
        (forall q, q \In s -> q <== p) -> ideal_sup s <== p.
Proof. by move=>H; apply: supM=>y [q][H1] <-; apply: H. Qed.

Definition idealLatticeMixin := LatticeMixin ideal_supP ideal_supM.
Canonical idealLattice := Eval hnf in Lattice (ideal P) idealLatticeMixin.

End IdealLattice.

(* Prop is a lattice *)

Section PropLattice.

Definition prop_sup (s : Pred Prop) : Prop := exists p, p \In s /\ p.

Lemma prop_supP (s : Pred Prop) p : p \In s -> p <== prop_sup s.
Proof. by exists p. Qed.

Lemma prop_supM (s : Pred Prop) p :
        (forall q, q \In s -> q <== p) -> prop_sup s <== p.
Proof. by move=>H [r][]; move/H. Qed.

Definition propLatticeMixin := LatticeMixin prop_supP prop_supM.
Canonical propLattice := Eval hnf in Lattice Prop propLatticeMixin.

End PropLattice.

(* Pred is a lattice *)

Section PredLattice.
Variable A : Type.

Definition predLatticeMixin := funLatticeMixin A propLattice.
Canonical predLattice := Eval hnf in Lattice (Pred A) predLatticeMixin.

End PredLattice.

(**********)
(* Chains *)
(**********)

Section Chains.
Variable T : poset.

Definition chain_axiom (s : Pred T) :=
  (exists d, d \In s) /\
  (forall x y, x \In s -> y \In s -> x <== y \/ y <== x).

Structure chain := Chain {
  pred_of :> Pred T;
  _ : chain_axiom pred_of}.

Canonical chainPredType := @mkPredType T chain pred_of.

End Chains.

Lemma chainE (T : poset) (s1 s2 : chain T) :
        s1 = s2 <-> pred_of s1 =p pred_of s2.
Proof.
split=>[->//|]; move: s1 s2=>[s1 H1][s2 H2] /= E; move: H1 H2.
suff: s1 = s2 by move=>-> H1 H2; congr Chain; apply: proof_irrelevance.
by apply: fext=>x; apply: pext; split; move/E.
Qed.

(* common chain constructions *)

(* adding bot to a chain *)

Section LiftChain.
Variable (T : poset) (s : chain T).

Lemma lift_chainP : chain_axiom [Pred x : T | x = bot \/ x \In s].
Proof.
case: s=>p [[d H1] H2] /=; split=>[|x y]; first by exists d; right.
by case=>[->|H3][->|H4]; auto.
Qed.

Definition lift_chain := Chain lift_chainP.

End LiftChain.

(* mapping monotone function over a chain *)

Section ImageChain.
Variables (T1 T2 : poset) (s : chain T1) (f : T1 -> T2) (M : monotone f).

Lemma image_chainP :
        chain_axiom [Pred x2 : T2 | exists x1, x2 = f x1 /\ x1 \In s].
Proof.
case: s=>p [[d H1] H2]; split=>[|x y]; first by exists (f d); exists d.
case=>x1 [->] H3 [y1][->] H4; rewrite -!toPredE /= in H3 H4.
by case: (H2 x1 y1 H3 H4)=>L; [left | right]; apply: M L.
Qed.

Definition image_chain := Chain image_chainP.

End ImageChain.

Notation "[ f '^^' s 'by' M ]" := (@image_chain _ _ s f M)
  (at level 0, format "[ f  '^^'  s  'by'  M ]") : form_scope.

Section ChainId.
Variables (T : poset) (s : chain T).

Lemma id_mono : monotone (@id T).
Proof. by []. Qed.

Lemma id_chainE (M : monotone id) : [id ^^ s by M] = s.
Proof. by apply/chainE=>x; split; [case=>y [<-]|exists x]. Qed.

End ChainId.

Arguments id_mono [T].
Prenex Implicits id_mono.

Section ChainConst.
Variables (T1 T2 : poset) (y : T2).

Lemma const_mono : monotone (fun x : T1 => y).
Proof. by []. Qed.

Lemma const_chainP : chain_axiom (Pred1 y).
Proof. by split; [exists y | move=>x1 x2 ->->; left]. Qed.

Definition const_chain := Chain const_chainP.

Lemma const_chainE s : [_ ^^ s by const_mono] = const_chain.
Proof.
apply/chainE=>z1; split; first by case=>z2 [->].
by case: s=>s [[d] H1] H2; move=><-; exists d.
Qed.

End ChainConst.

Arguments const_mono [T1 T2 y].
Prenex Implicits const_mono.

Section ChainCompose.
Variables (T1 T2 T3 : poset) (f1 : T2 -> T1) (f2 : T3 -> T2).
Variables (s : chain T3) (M1 : monotone f1) (M2 : monotone f2).

Lemma comp_mono : monotone (f1 \o f2).
Proof. by move=>x y H; apply: M1; apply: M2. Qed.

Lemma comp_chainE :
        [f1 ^^ [f2 ^^ s by M2] by M1] = [f1 \o f2 ^^ s by comp_mono].
Proof.
apply/chainE=>x1; split; first by case=>x2 [->][x3][->]; exists x3.
by case=>x3 [->]; exists (f2 x3); split=>//; exists x3.
Qed.

End ChainCompose.

Arguments comp_mono [T1 T2 T3 f1 f2].
Prenex Implicits comp_mono.

(* projections out of a chain *)

Section ProjChain.
Variables (T1 T2 : poset) (s : chain [poset of T1 * T2]).

Lemma proj1_mono : monotone (@fst T1 T2).
Proof. by case=>x1 x2 [y1 y2][]. Qed.

Lemma proj2_mono : monotone (@snd T1 T2).
Proof. by case=>x1 x2 [y1 y2][]. Qed.

Definition proj1_chain := [@fst _ _ ^^ s by proj1_mono].
Definition proj2_chain := [@snd _ _ ^^ s by proj2_mono].

End ProjChain.

Arguments proj1_mono [T1 T2].
Arguments proj2_mono [T1 T2].
Prenex Implicits proj1_mono proj2_mono.

(* diagonal chain *)

Section DiagChain.
Variable (T : poset) (s : chain T).

Lemma diag_mono : monotone (fun x : T => (x, x)).
Proof. by []. Qed.

Definition diag_chain := [_ ^^ s by diag_mono].

Lemma proj1_diagE : proj1_chain diag_chain = s.
Proof. by rewrite /proj1_chain /diag_chain comp_chainE id_chainE. Qed.

Lemma proj2_diagE : proj2_chain diag_chain = s.
Proof. by rewrite /proj2_chain /diag_chain comp_chainE id_chainE. Qed.

End DiagChain.

Arguments diag_mono [T].
Prenex Implicits diag_mono.

(* applying functions from a chain of functions *)

Section AppChain.
Variables (A : Type) (T : poset) (s : chain [poset of A -> T]).

Lemma app_mono x : monotone (fun f : A -> T => f x).
Proof. by move=>f1 f2; apply. Qed.

Definition app_chain x := [_ ^^ s by app_mono x].

End AppChain.

Arguments app_mono [A T].
Prenex Implicits app_mono.

(* ditto for dependent functions *)

Section DAppChain.
Variables (A : Type) (T : A -> poset) (s : chain (dfunPoset T)).

Lemma dapp_mono x : monotone (fun f : dfunPoset T => f x).
Proof. by move=>f1 f2; apply. Qed.

Definition dapp_chain x := [_ ^^ s by dapp_mono x].

End DAppChain.

Arguments dapp_mono [A T].
Prenex Implicits dapp_mono.

(* pairing chain applications *)

Section ProdChain.
Variables (S1 S2 T1 T2 : poset) (f1 : S1 -> T1) (f2 : S2 -> T2).
Variables (M1 : monotone f1) (M2 : monotone f2).
Variable (s : chain [poset of S1 * S2]).

Lemma prod_mono : monotone (f1 \* f2).
Proof. by case=>x1 x2 [y1 y2][/= H1 H2]; split; [apply: M1 | apply: M2]. Qed.

Definition prod_chain := [f1 \* f2 ^^ s by prod_mono].

Lemma proj1_prodE : proj1_chain prod_chain = [f1 ^^ proj1_chain s by M1].
Proof.
rewrite /proj1_chain /prod_chain !comp_chainE !/comp /=.
by apply/chainE.
Qed.

Lemma proj2_prodE : proj2_chain prod_chain = [f2 ^^ proj2_chain s by M2].
Proof.
rewrite /proj2_chain /prod_chain !comp_chainE !/comp /=.
by apply/chainE.
Qed.

End ProdChain.

Arguments prod_mono [S1 S2 T1 T2 f1 f2].
Prenex Implicits prod_mono.

(* chain of all nats *)

Section NatChain.

Lemma nat_chain_axiom : chain_axiom (@PredT nat).
Proof.
split=>[|x y _ _]; first by exists 0.
rewrite /Poset.leq /= [y <= x]leq_eqVlt.
by case: leqP; [left | rewrite orbT; right].
Qed.

Definition nat_chain := Chain nat_chain_axiom.

End NatChain.

(*********)
(* CPO's *)
(*********)

Module CPO.

Section RawMixin.

Record mixin_of (T : poset) := Mixin {
  mx_lim : chain T -> T;
  _ : forall (s : chain T) x, x \In s -> x <== mx_lim s;
  _ : forall (s : chain T) x,
        (forall y, y \In s -> y <== x) -> mx_lim s <== x}.

End RawMixin.

Section ClassDef.

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

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

Structure type : Type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

Definition pack b0 (m0 : mixin_of (Poset.Pack b0 T)) :=
  fun m & phant_id m0 m => Pack (@Class T b0 m) T.

Definition poset := Poset.Pack class cT.
Definition lim (s : chain poset) : cT := mx_lim (mixin class) s.

End ClassDef.

Module Import Exports.
Coercion base : class_of >-> Poset.class_of.
Coercion sort : type >-> Sortclass.
Coercion poset : type >-> Poset.type.
Canonical Structure poset.

Notation cpo := type.
Notation CPOMixin := Mixin.
Notation CPO T m := (@pack T _ _ m id).

Notation "[ 'cpo' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
  (at level 0, format "[ 'cpo'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'cpo' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'cpo'  'of'  T ]") : form_scope.

Arguments CPO.lim {cT}.
Notation lim := CPO.lim.

Section Laws.
Variable D : cpo.

Lemma limP (s : chain D) x : x \In s -> x <== lim s.
Proof. by case: D s x=>S [[p]][/= l H1 *]; apply: (H1). Qed.

Lemma limM (s : chain D) x : (forall y, y \In s -> y <== x) -> lim s <== x.
Proof. by case: D s x=>S [[p]][/= l H1 H2 *]; apply: (H2). Qed.

End Laws.

End Exports.

End CPO.

Export CPO.Exports.

(****************************)
(* common cpo constructions *)
(****************************)

(* pairs *)

Section PairCPO.
Variables (A B : cpo).
Local Notation tp := [poset of A * B].

Definition pair_lim (s : chain tp) : tp :=
  (lim (proj1_chain s), lim (proj2_chain s)).

Lemma pair_limP (s : chain tp) x : x \In s -> x <== pair_lim s.
Proof. by split; apply: limP; exists x. Qed.

Lemma pair_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> pair_lim s <== x.
Proof. by split; apply: limM=>y [z][->]; case/H. Qed.

Definition pairCPOMixin := CPOMixin pair_limP pair_limM.
Canonical pairCPO := Eval hnf in CPO (A * B) pairCPOMixin.

End PairCPO.

(* functions *)

Section FunCPO.
Variable (A : Type) (B : cpo).
Local Notation tp := [poset of A -> B].

Definition fun_lim (s : chain tp) : tp :=
  fun x => lim (app_chain s x).

Lemma fun_limP (s : chain tp) x : x \In s -> x <== fun_lim s.
Proof. by move=>H t; apply: limP; exists x. Qed.

Lemma fun_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> fun_lim s <== x.
Proof. by move=>H1 t; apply: limM=>y [f][->] H2; apply: H1. Qed.

Definition funCPOMixin := CPOMixin fun_limP fun_limM.
Canonical funCPO := Eval hnf in CPO (A -> B) funCPOMixin.

End FunCPO.

(* dependent functions *)

Section DFunCPO.
Variable (A : Type) (B : A -> cpo).
Local Notation tp := (dfunPoset B).

Definition dfun_lim (s : chain tp) : tp :=
  fun x => lim (dapp_chain s x).

Lemma dfun_limP (s : chain tp) x : x \In s -> x <== dfun_lim s.
Proof. by move=>H t; apply: limP; exists x. Qed.

Lemma dfun_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> dfun_lim s <== x.
Proof. by move=>H1 t; apply: limM=>y [f][->] H2; apply: H1. Qed.

Definition dfunCPOMixin := CPOMixin dfun_limP dfun_limM.
Definition dfunCPO := Eval hnf in CPO (forall x, B x) dfunCPOMixin.

End DFunCPO.

(* Prop *)

Section PropCPO.
Local Notation tp := [poset of Prop].

Definition prop_lim (s : chain tp) : tp := exists p, p \In s /\ p.

Lemma prop_limP (s : chain tp) p : p \In s -> p <== prop_lim s.
Proof. by exists p. Qed.

Lemma prop_limM (s : chain tp) p :
        (forall q, q \In s -> q <== p) -> prop_lim s <== p.
Proof. by move=>H [r][]; move/H. Qed.

Definition propCPOMixin := CPOMixin prop_limP prop_limM.
Canonical propCPO := Eval hnf in CPO Prop propCPOMixin.

End PropCPO.

(* Pred *)

Section PredCPO.
Variable A : Type.

Definition predCPOMixin := funCPOMixin A propCPO.
Canonical predCPO := Eval hnf in CPO (Pred A) predCPOMixin.

End PredCPO.

(* every complete lattice is a cpo *)

Section LatticeCPO.
Variable A : lattice.
Local Notation tp := (Lattice.poset A).

Definition lat_lim (s : chain tp) : tp := sup s.

Lemma lat_limP (s : chain tp) x : x \In s -> x <== lat_lim s.
Proof. by apply: supP. Qed.

Lemma lat_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> lat_lim s <== x.
Proof. by apply: supM. Qed.

Definition latCPOMixin := CPOMixin lat_limP lat_limM.
Definition latCPO := Eval hnf in CPO tp latCPOMixin.

End LatticeCPO.

(* sub-CPO's *)

(* every chain-closed subset of a cpo is a cpo *)

Section AdmissibleClosure.
Variable T : cpo.

Definition chain_closed :=
  [Pred s : Pred T |
     bot \In s /\ forall d : chain T, d <=p s -> lim d \In s].

(* admissible closure of s is the smallest closed set containing s *)
(* basically extends s to include the sups of chains *)
Definition chain_closure (s : Pred T) :=
  [Pred p : T | forall t : Pred T, s <=p t -> chain_closed t -> p \In t].

(* admissible closure contains s *)
Lemma chain_clos_sub (s : Pred T) : s <=p chain_closure s.
Proof. by move=>p H1 t H2 H3; apply: H2 H1. Qed.

(* admissible closure is smallest *)
Lemma chain_clos_min (s : Pred T) t :
        s <=p t -> chain_closed t -> chain_closure s <=p t.
Proof. by move=>H1 H2 p; move/(_ _ H1 H2). Qed.

(* admissible closure is closed *)
Lemma chain_closP (s : Pred T) : chain_closed (chain_closure s).
Proof.
split; first by move=>t _ [].
move=>d H1 t /chain_clos_min H3 H4.
by case: (H4) => _; apply=> x /H1/(H3 H4).
Qed.

Lemma chain_clos_idemp (s : Pred T) :
        chain_closed s -> chain_closure s =p s.
Proof.
move=>p; split; last by apply: chain_clos_sub.
by apply: chain_clos_min=>//; apply: chain_closP.
Qed.

Lemma chain_clos_mono (s1 s2 : Pred T) :
        s1 <=p s2 -> chain_closure s1 <=p chain_closure s2.
Proof.
move=>H1; apply: chain_clos_min (chain_closP s2)=>p H2.
by apply: chain_clos_sub; apply: H1.
Qed.

(* intersection of admissible sets is admissible *)
Lemma chain_closI (s1 s2 : Pred T) :
       chain_closed s1 -> chain_closed s2 -> chain_closed (PredI s1 s2).
Proof.
move=>[H1 S1][H2 S2]; split=>// d H.
by split; [apply: S1 | apply: S2]=>// x; case/H.
Qed.

End AdmissibleClosure.

Arguments chain_closed {T}.

(* diagonal of an admissible set of pairs is admissible *)
Lemma chain_clos_diag (T : cpo) (s : Pred (T * T)) :
        chain_closed s -> chain_closed [Pred t : T | (t, t) \In s].
Proof.
move=>[B H1]; split=>// d H2.
rewrite InE /= -{1}(proj1_diagE d) -{2}(proj2_diagE d).
by apply: H1; case=>x1 x2 [x][[<- <-]]; apply: H2.
Qed.

Section SubCPO.
Variables (D : cpo) (s : Pred D) (C : chain_closed s).

Local Notation tp := (subPoset (proj1 C)).

Lemma sval_mono : monotone (sval : tp -> D).
Proof. by move=>[x1 H1][x2 H2]; apply. Qed.

Lemma sub_limX (u : chain tp) : lim [sval ^^ u by sval_mono] \In s.
Proof. by case: C u=>P H u; apply: (H)=>t [[y]] H1 [->]. Qed.

Definition sub_lim (u : chain tp) : tp :=
  exist _ (lim [sval ^^ u by sval_mono]) (sub_limX u).

Lemma sub_limP (u : chain tp) x : x \In u -> x <== sub_lim u.
Proof. by move=>H; apply: limP; exists x. Qed.

Lemma sub_limM (u : chain tp) x :
        (forall y, y \In u -> y <== x) -> sub_lim u <== x.
Proof. by move=>H; apply: limM=>y [z][->]; apply: H. Qed.

Definition subCPOMixin := CPOMixin sub_limP sub_limM.
Definition subCPO := Eval hnf in CPO {x : D | x \In s} subCPOMixin.

End SubCPO.

(***********************************************)
(* Continuity and Kleene's fixed point theorem *)
(***********************************************)

Lemma lim_mono (D : cpo) (s1 s2 : chain D) :
        s1 <=p s2 -> lim s1 <== lim s2.
Proof. by move=>H; apply: limM=>y; move/H; apply: limP. Qed.

Lemma limE (D : cpo) (s1 s2 : chain D) :
        s1 =p s2 -> lim s1 = lim s2.
Proof. by move=>H; apply: poset_asym; apply: lim_mono=>x; rewrite H. Qed.

Lemma lim_liftE (D : cpo) (s : chain D) :
        lim s = lim (lift_chain s).
Proof.
apply: poset_asym; apply: limM=>y H; first by apply: limP; right.
by case: H; [move=>-> | apply: limP].
Qed.

(* applied lim equals the lim of applications *)
(* ie., part of continuity of application *)
(* but is so often used, I give it a name *)

Lemma lim_appE A (D : cpo) (s : chain [cpo of A -> D]) (x : A) :
        lim s x = lim (app_chain s x).
Proof. by []. Qed.

Lemma lim_dappE A (D : A -> cpo) (s : chain (dfunCPO D)) (x : A) :
        lim s x = lim (dapp_chain s x).
Proof. by []. Qed.

Section Continuity.
Variables (D1 D2 : cpo) (f : D1 -> D2).

Definition continuous :=
  exists M : monotone f,
  forall s : chain D1, f (lim s) = lim [f ^^ s by M].

Lemma cont_mono : continuous -> monotone f.
Proof. by case. Qed.

Lemma contE (s : chain D1) (C : continuous) :
       f (lim s) = lim [f ^^ s by cont_mono C].
Proof.
case: C=>M E; rewrite E; congr (lim (image_chain _ _)).
apply: proof_irrelevance.
Qed.

End Continuity.

Section Kleene.
Variables (D : cpo) (f : D -> D) (C : continuous f).

Fixpoint pow m := if m is n.+1 then f (pow n) else bot.

Lemma pow_mono : monotone pow.
Proof.
move=>m n; elim: n m=>[|n IH] m /=; first by case: m.
rewrite {1}/Poset.leq /= leq_eqVlt ltnS.
case/orP; first by move/eqP=>->.
move/IH=>{IH} H; apply: poset_trans H _.
by elim: n=>[|n IH] //=; apply: cont_mono IH.
Qed.

Definition pow_chain := [pow ^^ nat_chain by pow_mono].

Lemma reindex : pow_chain =p lift_chain [f ^^ pow_chain by cont_mono C].
Proof.
move=>x; split.
- case; case=>[|n][->] /=; first by left.
  by right; exists (pow n); split=>//; exists n.
case=>/=; first by move=>->; exists 0.
by case=>y [->][n][->]; exists n.+1.
Qed.

Definition kleene_lfp := lim pow_chain.

Lemma kleene_lfp_fixed : f kleene_lfp = kleene_lfp.
Proof. by rewrite (@contE _ _ f) lim_liftE; apply: limE; rewrite reindex. Qed.

Lemma kleene_lfp_least : forall x, f x = x -> kleene_lfp <== x.
Proof.
move=>x H; apply: limM=>y [n][->] _.
by elim: n=>[|n IH] //=; rewrite -H; apply: cont_mono IH.
Qed.

End Kleene.

(**********************************)
(* Continuity of common functions *)
(**********************************)

Lemma id_cont (D : cpo) : continuous (@id D).
Proof. by exists id_mono; move=>d; rewrite id_chainE. Qed.

Arguments id_cont {D}.

Lemma const_cont (D1 D2 : cpo) (y : D2) : continuous (fun x : D1 => y).
Proof.
exists const_mono; move=>s; apply: poset_asym.
- by apply: limP; case: s=>[p][[d H1] H2]; exists d.
by apply: limM=>_ [x][->].
Qed.

Arguments const_cont {D1 D2 y}.

Lemma comp_cont (D1 D2 D3 : cpo) (f1 : D2 -> D1) (f2 : D3 -> D2) :
        continuous f1 -> continuous f2 -> continuous (f1 \o f2).
Proof.
case=>M1 H1 [M2 H2]; exists (comp_mono M1 M2); move=>d.
by rewrite /= H2 H1 comp_chainE.
Qed.

Arguments comp_cont {D1 D2 D3 f1 f2}.

Lemma proj1_cont (D1 D2 : cpo) : continuous (@fst D1 D2).
Proof. by exists proj1_mono. Qed.

Lemma proj2_cont (D1 D2 : cpo) : continuous (@snd D1 D2).
Proof. by exists proj2_mono. Qed.

Arguments proj1_cont {D1 D2}.
Arguments proj2_cont {D1 D2}.

Lemma diag_cont (D : cpo) : continuous (fun x : D => (x, x)).
Proof.
exists diag_mono=>d; apply: poset_asym;
by split=>/=; [rewrite proj1_diagE | rewrite proj2_diagE].
Qed.

Arguments diag_cont {D}.

Lemma app_cont A (D : cpo) x : continuous (fun f : A -> D => f x).
Proof. by exists (app_mono x). Qed.

Lemma dapp_cont A (D : A -> cpo) x : continuous (fun f : dfunCPO D => f x).
Proof. by exists (dapp_mono x). Qed.

Arguments app_cont {A D}.
Arguments dapp_cont {A D}.

Lemma prod_cont (S1 S2 T1 T2 : cpo) (f1 : S1 -> T1) (f2 : S2 -> T2) :
        continuous f1 -> continuous f2 -> continuous (f1 \* f2).
Proof.
case=>M1 H1 [M2 H2]; exists (prod_mono M1 M2)=>d; apply: poset_asym;
by (split=>/=; [rewrite proj1_prodE H1 | rewrite proj2_prodE H2]).
Qed.

Arguments prod_cont {S1 S2 T1 T2 f1 f2}.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Lia.
Require Import Coq.Sorting.Permutation.
Import ListNotations.

Local Open Scope Z_scope.

Section FoldLemmas.

  Lemma fold_right_val_closed: forall (T : Type) (V: Type)
    (fT: T -> T -> T) (val: T -> Prop),
    (forall x y : T, val x -> val y -> val (fT x y)) ->
    forall (f: V -> T) t l,
      val t -> List.Forall (fun v : V => val (f v)) l -> val (fold_right fT t (map f l)).
  Proof.
    intros.
    induction l.
    - auto.
    - simpl. apply H; [ | apply IHl]; inversion H1; assumption.
  Qed.

  Lemma fold_right_map_cond: forall (T U V : Type)
    (fT: T -> T -> T) (fU: U -> U -> U) (TtoU: T -> U) (val: T -> Prop),
    (forall x y : T, val x -> val y -> fU (TtoU x) (TtoU y) = TtoU (fT x y)) ->
    (forall x y : T, val x -> val y -> val (fT x y)) ->
    forall (f : V -> T) l t u,
      TtoU t = u ->
      val t ->
      List.Forall (fun v : V => val (f v)) l ->
      fold_right fU u (map (fun x : V => TtoU (f x)) l) =
      TtoU (fold_right fT t (map f l)).
  Proof.
    intros.
    induction l.
    - auto.
    - simpl. rewrite IHl. rewrite H.
      + trivial.
      + inversion H3. assumption.
      + simpl. apply fold_right_val_closed; try assumption.
        inversion H3. assumption.
      + inversion H3. assumption.
  Qed.

  Lemma fold_right_map: forall (T U V : Type)
    (fT: T -> T -> T) (fU: U -> U -> U) (TtoU: T -> U),
    (forall x y : T, fU (TtoU x) (TtoU y) = TtoU (fT x y)) ->
    forall (f : V -> T) l t u,
      TtoU t = u ->
      fold_right fU u (map (fun x : V => TtoU (f x)) l) =
      TtoU (fold_right fT t (map f l)).
  Proof.
    intros.
    induction l.
    - auto.
    - simpl. rewrite IHl. rewrite H. trivial.
  Qed.

  Lemma app_cons: forall [A : Type] (l : list A) (a : A),
      a :: l = [a] ++ l.
  Proof.
    simpl. reflexivity.
  Qed.

  Lemma fold_right_flat_map: forall (T U : Type) (f: T -> list U) (l : list T),
    fold_right (@List.app _ ) [] (map f l) = flat_map f l.
  Proof.
    intros.
    induction l.
    - auto.
    - rewrite app_cons.
      rewrite map_app.
      rewrite fold_right_app.
      rewrite flat_map_app.
      rewrite IHl.
      simpl.
      rewrite app_nil_r.
      trivial.
  Qed.

End FoldLemmas.

Section TableMult.

  Context
    (P : Type)
    (addP : P -> P -> P)
    (doubleP : P -> P)
    (negP : P -> P)
    (mulP : Z -> P -> P)
    (O : P) (* zero element *)
    (B : P) (* base point *)
    (q : Z) (* order of B *)
    (odd_q : Zodd q)
    (addP_negP : forall Q R, addP (negP Q) (negP R) = negP (addP Q R))
    (mulP_q : mulP q B = O)
    (mulP_zero : forall Q, mulP 0 Q = O)
    (mulP_one : forall Q, mulP 1 Q = Q)
    (mulP_addP : forall m n Q, mulP (m + n) Q = addP (mulP m Q) (mulP n Q))
    (mulP_doubleP : forall n Q, mulP (2 * n) Q = doubleP (mulP n Q))
    (mulP_negP : forall n Q, mulP (- n) Q = negP (mulP n Q))
    (mulP_mulP : forall m n Q, mulP (m * n) Q = mulP m (mulP n Q)).

  Definition ZtoP (n : Z) : P := mulP n B.

  (* Table-based multiplication, as outlined in https://eprint.iacr.org/2012/309.pdf, Section 3.3 *)

  (* Here, n denotes # of blocks, s denotes spacing, t denotes # of teeth,
           and D = s * n * t denotes the total number of digits *)
  Context (s : Z) (t : Z) (n : Z) (nt : Z) (D : Z)
          (Hs: 0 <= s) (Ht: 1 <= t) (Hn: 1 <= n)
          (Hnt: nt = n * t) (HD: D = s * nt)
          (Hq: 0 < q) (HDq: q < 2 ^ D).

  Section Multicomb.

    (* ======================================== *)
    (* Definitions related to `eval` and `multicomb` *)

    (* A `state` is a list of (location, bit #). A state is `valid` if all locations are nonnegative. *)
    Definition state := list (Z * Z).
    Definition valid (st: state) : Prop
      := List.Forall (fun '(i, x) => i >= 0) st.

    (* `shift` shifts the location of every bit in a state by k *)
    Definition shift (k: Z) : state -> state := List.map (fun '(i, x) => (k+i, x)).

    (* `add` adds two states together *)
    Definition add : state -> state -> state := @List.app _ .

    (* Signed bit for a given odd e *)
    Definition sbit (e : Z) (x : Z) := 2 * Z.b2z (Z.testbit ((e + 2 ^ D - 1) / 2) x) - 1.

    (* Unscaled signed bit for a given odd e*)
    Definition sbit' (e : Z) (x : Z) := Z.b2z (Z.testbit ((e + 2 ^ D - 1) / 2) x).

    Definition eval (l: state) (e: Z): Z
      := List.fold_right Z.add 0 (List.map (fun '(i, x) => 2^i * (sbit e x)) l).

    Definition Zseq (k: Z) (l: Z) := List.map Z.of_nat (List.seq (Z.to_nat k) (Z.to_nat l)).

    Definition entry (bnum: Z) (offset: Z)
      := List.map (fun x => (s * x, s * x + offset)) (Zseq (t * bnum) t).

    Definition comb (offset: Z) : state
      := List.map (fun x => (s * x, s * x + offset)) (Zseq 0 nt).

    Definition multicomb : state
      := List.fold_right (fun x y => add x (shift 1 y)) [] (List.map (fun x => comb x) (Zseq 0 s)).

    Definition stateseq (k: Z) := List.map (fun x => (x, x)) (Zseq 0 k).

    (* ==================== *)
    (* Lemmas and theorems *)

    (* -------------------- *)
    (* Zseq *)

    Lemma Zseq_succ_r': forall m b : Z,
      0 <= m -> 0 <= b -> Zseq b (Z.succ m) = Zseq b m ++ [(b + m)].
    Proof.
      (* For some reason, Coq deduces the wrong dependencies when we don't
         clear out all context variables *)
      clear Hs Ht Hn Hnt HD HDq Hq odd_q mulP_q s t n nt q D.
      intros.
      unfold Zseq.
      rewrite Z2Nat.inj_succ by trivial.
      rewrite seq_S.
      rewrite map_app.
      simpl.
      f_equal.
      rewrite <- Z2Nat.inj_add by trivial.
      rewrite Z2Nat.id by lia; trivial.
    Qed.

    Lemma Zseq_succ_r: forall m : Z,
      0 <= m -> Zseq 0 (Z.succ m) = Zseq 0 m ++ [m].
    Proof.
      clear Hs Ht Hn Hnt HD HDq Hq odd_q mulP_q s t n nt q D.
      intros; apply Zseq_succ_r' with (b := 0); lia.
    Qed.

    Lemma Zseq_bound': forall r : Z, 0 <= r
      -> forall b : Z, 0 <= b
      -> (forall a : Z, In a (Zseq b r) <-> b <= a < b + r).
    Proof.
      refine (natlike_ind _ _ _).
      - intros. split; intro.
        + inversion H0.
        + lia.
      - intros.
        destruct (Z.eq_dec a (b + x)); split; intro.
        + lia.
        + rewrite Zseq_succ_r' by assumption.
          rewrite in_app_iff.
          right. subst. apply in_eq.
        + rewrite Zseq_succ_r' in H2 by assumption.
          apply in_app_or in H2.
          simpl in H1.
          destruct H2; split.
          1-2: apply H0 with (a := a) in H1;
               apply H1 in H2; lia.
          all: inversion H2; try lia; inversion H3.
        + rewrite Zseq_succ_r' by assumption.
          rewrite in_app_iff.
          left.
          assert (b <= a < b + x) by lia.
          apply H0; assumption.
    Qed.

    Lemma Zseq_bound: forall r : Z, 0 <= r
      -> forall a : Z, In a (Zseq 0 r) <-> 0 <= a < r.
    Proof.
      intros; apply Zseq_bound'; lia.
    Qed.

    Lemma Zseq_app: forall b r1 r2 : Z,
      0 <= b -> 0 <= r1 -> 0 <= r2
      -> Zseq b (r1 + r2) = Zseq b r1 ++ Zseq (b + r1) r2.
    Proof.
      intros.
      unfold Zseq.
      rewrite <- map_app.
      f_equal.
      rewrite Z2Nat.inj_add by trivial.
      rewrite seq_app.
      rewrite Z2Nat.inj_add by trivial.
      reflexivity.
    Qed.

    (* -------------------- *)
    (* shift, add *)

    Lemma shift_0: forall st : state,
      (shift 0 st) = st.
    Proof.
      intros.
      induction st; simpl.
      - trivial.
      - destruct a; rewrite IHst; trivial.
    Qed.

    Lemma valid_add: forall st1 st2 : state,
      valid st1 -> valid st2 -> valid (add st1 st2).
    Proof.
      intros.
      unfold valid in *.
      unfold add.
      apply Forall_app.
      intuition.
    Qed.

    Lemma valid_shift: forall st : state, forall k : Z,
      valid st -> 0 <= k -> valid (shift k st).
    Proof.
      intros.
      unfold valid in *.
      unfold shift.
      apply Forall_map.
      eapply Forall_impl; [ | exact H].
      intros.
      destruct a.
      lia.
    Qed.

    Lemma eval_add: forall st1 st2 : state, forall e : Z,
      eval (add st1 st2) e = eval st1 e + eval st2 e.
    Proof.
      intros st1 st2 e.
      unfold eval.
      induction st1.
      - simpl. reflexivity.
      - simpl. rewrite IHst1. rewrite Z.add_assoc. reflexivity.
    Qed.

    Lemma eval_shift: forall st : state, forall k e : Z,
      valid st -> 0 <= k -> eval (shift k st) e = 2^k * eval st e.
    Proof.
      intros.
      unfold eval.
      induction st.
      - simpl. ring.
      - simpl.
        rewrite IHst.
        clear IHst.
        destruct a.
        ring_simplify.
        f_equal.
        rewrite Z.pow_add_r.
        rewrite Z.mul_comm.
        rewrite Z.mul_assoc.
        trivial.
        trivial.
        + unfold valid in H.
          inversion H.
          lia.
        + unfold valid in H.
          inversion H.
          unfold valid.
          trivial.
    Qed.

    Lemma shift_add: forall st1 st2 k,
      add (shift k st1) (shift k st2) = shift k (add st1 st2).
    Proof.
      intros. unfold shift, add. rewrite map_app. trivial.
    Qed.

    Lemma shift_shift: forall st k l,
      shift k (shift l st) = shift (k + l) st.
    Proof.
      intros. unfold shift.
      rewrite map_map.
      apply map_ext_in.
      intros.
      destruct a.
      rewrite Z.add_assoc.
      trivial.
    Qed.

    Lemma fold_right_shift: forall t, 0 <= t -> forall (f : Z -> state) l,
      fold_right (fun x y => add x (shift 1 y)) l (map f (Zseq 0 t)) =
      fold_right add (shift t l) (map (fun n => (shift n (f n))) (Zseq 0 t)).
    Proof.
      refine (natlike_ind _ _ _).
      - intros. simpl. rewrite shift_0. trivial.
      - intros.
        repeat rewrite Zseq_succ_r by assumption.
        repeat rewrite map_app.
        repeat rewrite fold_right_app.
        rewrite H0.
        f_equal.
        simpl.
        rewrite <- shift_add.
        f_equal.
        rewrite shift_shift.
        f_equal.
    Qed.

    (* -------------------- *)
    (* eval, stateseq *)

    Lemma in_stateseq: forall n, 0 <= n -> forall x,
      In x (stateseq n) -> exists m, 0 <= m < n /\ x = (m, m).
    Proof.
      refine (natlike_ind _ _ _).
      - simpl. intuition.
      - unfold stateseq.
        intros.
        rewrite Zseq_succ_r in H1 by assumption.
        rewrite map_app in H1.
        simpl in H1.
        rewrite in_app_iff in H1.
        intuition.
        + apply H0 in H2.
          destruct H2.
          exists x1.
          intuition; lia.
        + exists x.
          intuition; try lia.
          inversion H2; try destruct H1; auto.
    Qed.

    Lemma mod_sub: forall a b c : Z, c <> 0 -> (a - b * c) mod c = a mod c.
    Proof.
      intros.
      rewrite <- Z.add_opp_r.
      rewrite <- Z.mul_opp_l.
      apply Z.mod_add.
      assumption.
    Qed.

    Theorem eval_stateseq_partial: forall n, 0 <= n < D
      -> forall e : Z, - 2 ^ D < e < 2 ^ D
                    -> Zodd e
                    -> eval (stateseq n) e = (e mod 2 ^ (n + 1)) - 2 ^ n.
    Proof.
      intros m Hm.
      destruct Hm.
      generalize dependent m.
      refine (natlike_ind _ _ _).
      - intros. unfold stateseq, eval.
        rewrite <- Zodd_bool_iff in H1.
        pose proof Zmod_odd e.
        rewrite H1 in H2.
        replace (2 ^ (0 + 1)) with 2 by nia.
        simpl.
        lia.
      - intro m. intros.
        unfold stateseq in *.
        rewrite Zseq_succ_r by trivial.
        rewrite map_app.
        rewrite eval_add.
        erewrite H0;[ | lia | trivial | trivial].
        unfold eval.
        simpl.
        rewrite <- Z.add_1_r.
        rewrite -> Z.add_0_r.
        unfold sbit.

        remember ((e + 2 ^ D - 1) / 2) as f.
        assert (e = 2 * f + 1 - 2 ^ D). {
          rewrite Heqf.
          erewrite <- Z_div_exact_2; try lia.
          apply Zodd_ex in H3.
          destruct H3.
          rewrite H3 in *.
          replace D with (D - 1 + 1) by lia.
          remember (D - 1) as E.
          assert (0 <= E) by lia.
          rewrite Z.pow_add_r; try lia.
          rewrite Z.pow_1_r.
          replace (2 * x + 1 + 2 ^ E * 2 - 1) with ((x + 2 ^ E) * 2) by lia.
          apply Z_mod_mult.
        }
        replace (n + 1 - 1) with n by lia.
        rewrite H4.
        rewrite Z.mul_sub_distr_l.
        rewrite Z.add_sub_assoc.
        rewrite Z.mul_1_r.
        rewrite Z.testbit_spec' by lia.
        replace D with (D - (m + 1) + (m + 1)) at 1 by lia.
        replace D with (D - (m + 1 + 1) + (m + 1 + 1)) at 2 by lia.
        rewrite Z.pow_add_r by lia.
        rewrite Z.pow_add_r with (c := m + 1 + 1) by lia.
        repeat rewrite mod_sub by lia.
        assert (f / 2 ^ m = (2 * f + 1) / (2 ^ m * 2)). {
          rewrite Z.mul_comm with (n := 2 ^ m).
          rewrite <- Z.div_div by lia.
          rewrite Z.mul_comm.
          rewrite Z.div_add_l by lia.
          replace (1 / 2) with 0 by auto.
          rewrite Z.add_0_r.
          trivial.
        }
        rewrite Z.mul_assoc.
        repeat rewrite Z.pow_add_r by lia.
        repeat rewrite Z.pow_1_r.
        rewrite H5.
        rewrite (Z.rem_mul_r (2 * f + 1) (2 ^ m * 2) 2) by lia.
        lia.
    Qed.

    Theorem eval_stateseq: forall e : Z,
      - 2 ^ D < e < 2 ^ D
      -> Zodd e
      -> eval (stateseq D) e = e.
    Proof.
      intros.
      assert (HD1: 1 <= D). {
        destruct D.
        - rewrite Z.pow_0_r in H.
          apply Zodd_ex in H0.
          destruct H0; lia.
        - lia.
        - nia.
      }
      assert (stateseq D = stateseq (D - 1) ++ [(D - 1, D - 1)]).
      {
        unfold stateseq.
        replace D with (Z.succ (D - 1)) at 1 by lia.
        rewrite Zseq_succ_r by lia.
        rewrite map_app.
        simpl.
        trivial.
      }
      rewrite H1.
      rewrite eval_add.
      erewrite eval_stateseq_partial with (n := (D - 1)) (e := e); try lia; try assumption.
      unfold eval.
      simpl.
      case_eq e; intros.
      - subst. inversion H0.
      - assert (1 <= e) by lia.
        rewrite <- H2.
        assert (sbit e (D - 1) = 1).
        {
          clear H1.
          unfold sbit.
          rewrite Z.testbit_spec' by lia.
          rewrite Z.div_div by lia.
          rewrite <- Z.pow_succ_r by lia.
          replace (Z.succ (D - 1)) with D by lia.
          replace (e + 2 ^ D - 1) with (e - 1 + (1 * 2 ^ D)) by lia.
          rewrite Z.div_add by lia.
          rewrite Z.div_small by lia.
          auto.
        }
        rewrite H4.
        rewrite Z.sub_add.
        rewrite Z.mod_small; lia.
      - assert (e <= -1) by lia.
        rewrite <- H2.
        assert (sbit e (D - 1) = -1).
        {
          clear H1.
          unfold sbit.
          rewrite Z.testbit_spec' by lia.
          rewrite Z.div_div by lia.
          rewrite <- Z.pow_succ_r by lia.
          replace (Z.succ (D - 1)) with D by lia.
          rewrite Z.div_small by lia.
          auto.
        }
        rewrite H4.
        rewrite Z.sub_add.
        replace e with (e + 2 ^ D - 1 * 2 ^ D) at 1 by lia.
        rewrite mod_sub by nia.
        rewrite Z.mod_small by lia.
        replace D with (D - 1 + 1) at 1 by lia.
        rewrite Z.pow_add_r by lia.
        nia.
    Qed.

    Theorem eval_permutation: forall st1 st2 : state, forall e : Z,
      Permutation st1 st2 -> eval st1 e = eval st2 e.
    Proof.
      induction 1; simpl; auto.
      - rewrite app_cons.
        rewrite (app_cons l' x).
        rewrite eval_add.
        rewrite eval_add.
        rewrite IHPermutation.
        trivial.
      - rewrite app_cons.
        rewrite (app_cons l x).
        rewrite (app_cons (y :: l) x).
        rewrite (app_cons l y).
        repeat progress rewrite eval_add.
        ring.
      - rewrite IHPermutation1.
        eapply IHPermutation2.
    Qed.

    Theorem permute_comb_correct: forall e : Z, forall st : state,
      - 2 ^ D < e < 2 ^ D -> Zodd e -> Permutation (stateseq D) st -> eval st e = e.
    Proof.
      intros.
      rewrite <- eval_permutation with (st1 := stateseq D).
      apply eval_stateseq.
      all: assumption.
    Qed.

    (* -------------------- *)
    (* comb, entry *)

    Lemma comb_entry: forall offset,
      comb offset = List.flat_map (fun x => entry x offset) (Zseq 0 n).
    Proof.
      assert (0 <= n) by lia.
      unfold comb.
      rewrite Hnt.
      clear Hn Hnt.
      generalize dependent n.
      refine (natlike_ind _ _ _).
      - simpl. trivial.
      - intros.
        rewrite Zseq_succ_r by assumption.
        rewrite flat_map_app.
        simpl.
        replace (Z.succ x * t) with (x * t + t) by nia.
        rewrite app_nil_r.
        rewrite Zseq_app by nia.
        rewrite map_app.
        unfold entry.
        f_equal.
        + apply H0.
        + f_equal.
          f_equal.
          nia.
    Qed.

    (* -------------------- *)
    (* multicomb *)

    Lemma multicomb_length:
      length multicomb = Z.to_nat D.
    Proof.
      unfold multicomb.
      erewrite <- fold_right_map with (u := 0%nat) (fU := Nat.add).
      - assert (map (fun x : Z => length (comb x)) (Zseq 0 s) = map (fun x : Z => Z.to_nat nt) (Zseq 0 s)).
        { apply map_ext_in.
          intros.
          unfold comb, Zseq.
          repeat rewrite map_length.
          apply seq_length. }
        rewrite H; clear H.
        rewrite HD; clear HD.
        generalize dependent s.
        refine (natlike_ind _ _ _).
        + auto.
        + intros.
          rewrite Zseq_succ_r by assumption.
          rewrite map_app.
          rewrite <- fold_symmetric by lia.
          rewrite fold_left_app.
          simpl.
          rewrite -> fold_symmetric by lia.
          rewrite H0.
          lia.
      - intros.
        unfold add.
        rewrite app_length.
        f_equal.
        unfold shift.
        rewrite map_length.
        trivial.
      - auto.
    Qed.

    Lemma multicomb_simple:
      multicomb = List.fold_right add [] (map (fun x =>
        (map (fun o => (s * o + x, s * o + x)) (Zseq 0 nt)))
        (Zseq 0 s)).
    Proof.
      unfold multicomb, comb.
      rewrite fold_right_shift by assumption.
      simpl.
      f_equal.
      apply map_ext_in; intros; unfold shift; rewrite map_map.
      apply map_ext_in; intros; rewrite Z.add_comm; trivial.
    Qed.

    Lemma multicomb_elts: forall n,
      0 <= n < D -> In (n, n) multicomb.
    Proof.
      intros.
      rewrite multicomb_simple.
      unfold add.
      setoid_rewrite fold_right_flat_map with
        (f := fun x : Z => map (fun o : Z => (s * o + x, s * o + x)) (Zseq 0 nt)) (l := (Zseq 0 s)).
      rewrite in_flat_map.
      exists (n0 mod s); split.
      - apply Zseq_bound; try apply Z.mod_pos_bound; lia.
      - apply in_map_iff.
        exists (n0 / s); split.
        + rewrite <- Z_div_mod_eq_full. trivial.
        + apply Zseq_bound; try nia; split.
          * apply Z_div_nonneg_nonneg; lia.
          * apply Z.div_lt_upper_bound; lia.
    Qed.

    Theorem multicomb_stateseq:
      Permutation (stateseq D) multicomb.
    Proof.
      eapply NoDup_Permutation_bis.
      - unfold stateseq, Zseq.
        apply NoDup_map_inv with (f := (fun '(i, x) => Z.to_nat i)).
        repeat rewrite map_map.
        assert (forall l, map (fun x : nat => Z.to_nat (Z.of_nat x)) l = l).
        { intros.
          induction l.
          - auto.
          - simpl. rewrite IHl. rewrite Nat2Z.id. trivial. }
        rewrite H.
        apply seq_NoDup.
      - rewrite multicomb_length.
        unfold stateseq, Zseq.
        repeat rewrite map_length.
        rewrite seq_length.
        auto.
      - rewrite incl_Forall_in_iff.
        rewrite Forall_forall.
        intros.
        apply in_stateseq in H; [ | lia ].
        destruct H. rename x0 into m.
        destruct H.
        rewrite H0.
        apply multicomb_elts; assumption.
    Qed.

    Theorem multicomb_correct: forall e : Z,
      - 2 ^ D < e < 2 ^ D -> Zodd e -> eval multicomb e = e.
    Proof.
      intros.
      apply permute_comb_correct; try assumption.
      exact multicomb_stateseq.
    Qed.

  End Multicomb.

  Section Table.

    (* ======================================== *)
    (* Definitions related to tables *)

    (*
                    1  0    0  1 = 9
      Table: c =  [+1; -1; -1; +1], offset |-> sum (c[i] * 2^(i*k))
          should be equal to eval (comb s t offset) e * P,
          where the c is the bits in the respective positions of e
    *)

    (* TODO *)
    (*
    - submit PR
    - make it clear which part is used at runtime
    - (potentially) split file into code and proofs
    *)

    (* To be replaced by looking up in an actual precomputed table *)
    Definition table_entry (bnum: Z) (d: Z) : P
      := List.fold_right addP O
      (List.map
        (fun x => ZtoP ((2 * (Z.b2z (Z.testbit d (x - t * bnum))) - 1) * 2 ^ (s * x)))
        (Zseq (t * bnum) t)).

    Definition table_entry' (bnum: Z) (d: Z) : P
      := List.fold_right addP O
      (List.map
        (fun x => ZtoP ((2 * (Z.b2z (Z.testbit d (x - t * bnum))) - 1) * 2 ^ (s * x)))
        (Zseq (t * bnum) t)).

    Lemma table_entry_hyp: forall bnum d : Z,
      0 <= d < 2 ^ (t - 1) ->
      table_entry bnum d = table_entry' bnum d.
    Proof. intros. reflexivity. Qed.

    Opaque table_entry.

    Definition table_lookup (bnum: Z) (d: Z) : P
      := if Z.testbit d (t - 1) then negP (table_entry bnum (2 ^ t - 1 - d)) else table_entry bnum d.

    (* Definition table := List.map table_entry (Zseq 0 (2 ^ t)). *)

    Definition extract_bits (offset: Z) (e: Z) : Z
      := List.fold_right Z.add 0 (
      List.map (fun x => (sbit' e (x * s + offset)) * (2 ^ x))
      (Zseq 0 t)).

    Definition table_comb (offset: Z) (e: Z) : P
      := List.fold_right addP O
      (List.map (fun x => table_lookup x (extract_bits (offset + x * s * t) e)) (Zseq 0 n)).

    Definition table_multicomb (e: Z) : P :=
      List.fold_right (fun x y => addP x (doubleP y)) O (List.map (fun x => table_comb x e) (Zseq 0 s)).

    (* ==================== *)
    (* Lemmas and theorems *)

    (* -------------------- *)
    (* extract_bits *)

    Lemma bitmap_bound: forall (t : Z), 0 <= t ->
      forall (f: Z -> bool),
        0 <= fold_right Z.add 0 (map (fun y : Z => Z.b2z (f y) * 2 ^ y) (Zseq 0 t)) < 2 ^ t.
    Proof.
      clear HD HDq D.
      refine (natlike_ind _ _ _).
      - intros. simpl. lia.
      - intros. simpl.
        rewrite Zseq_succ_r by lia.
        rewrite map_app.
        simpl.
        rewrite <- fold_symmetric by lia.
        rewrite fold_left_app.
        simpl.
        rewrite fold_symmetric by lia.
        specialize H0 with f.
        assert (0 <= Z.b2z (f x) * 2 ^ x <= 2 ^ x). {
          case (f x).
          - replace (Z.b2z true) with 1; [ lia | compute; trivial].
          - replace (Z.b2z false) with 0; [ lia | compute; trivial].
        }
        replace (2 ^ Z.succ x) with (2 ^ x + 2 ^ x); [ lia | ].
        rewrite <- Z.add_1_r.
        rewrite Z.pow_add_r by lia.
        nia.
    Qed.

    Lemma bitmap_testbit: forall (t : Z), 0 <= t ->
      forall (x : Z), 0 <= x < t ->
      forall (f: Z -> bool),
        Z.testbit (fold_right Z.add 0
          (map (fun y : Z => Z.b2z (f y) * 2 ^ y) (Zseq 0 t))) x
        = f x.
    Proof.
      clear HD HDq D.
      refine (natlike_ind _ _ _).
      - intros. lia.
      - intros.
        rewrite Zseq_succ_r by lia.
        rewrite map_app.
        simpl.
        rewrite <- fold_symmetric by lia.
        rewrite fold_left_app.
        simpl.
        rewrite fold_symmetric by lia.
        simpl.
        destruct (Z.eq_dec x0 x).
        + subst.
          rewrite <- Z.div_pow2_bits with (n := x) (m := 0) by lia.
          rewrite Z.div_add by nia.
          pose proof bitmap_bound x H f.
          rewrite Z.div_small by assumption.
          rewrite Z.add_0_l.
          apply Z.b2z_bit0.
        + assert (x0 < x) by lia.
          rewrite <- Z.mod_pow2_bits_low with (m := x0) (n := x) by lia.
          rewrite Z.mod_add by nia.
          rewrite Z.mod_small; [ apply H0 | apply bitmap_bound ]; lia.
    Qed.

    Lemma extract_bits_bound: forall offset e,
     0 <= extract_bits offset e < 2 ^ t.
    Proof.
      intros; unfold extract_bits; apply bitmap_bound; lia.
    Qed.

    Lemma extract_bits_spec: forall offset e x : Z,
      0 <= x -> 0 <= offset <= s * nt ->
        (x < t -> Z.testbit (extract_bits offset e) x
          = Z.testbit ((e + 2 ^ (s * nt) - 1) / 2) (s * x + offset))
        /\ (t <= x -> Z.testbit (extract_bits offset e) x = false).
    Proof.
      intros.
      unfold extract_bits, sbit'.
      rewrite HD in *.
      intuition.
      - rewrite Z.mul_comm with (m := x).
        apply bitmap_testbit with
          (f := fun x : Z => Z.testbit ((e + 2 ^ (s * nt) - 1) / 2) (x * s + offset));
          lia.
      - rewrite <- Z.div_pow2_bits with (n := x) (m := 0) by lia.
        assert (Ht' : 0 <= t) by lia.
        pose proof bitmap_bound t Ht' (fun x : Z =>
          Z.testbit ((e + 2 ^ (s * nt) - 1) / 2) (x * s + offset)).
        assert (0 < 2) by lia.
        pose proof Z.pow_le_mono_r 2 t x H4 H0.
        rewrite Z.div_small; [ auto | lia ].
    Qed.

    (* -------------------- *)
    (* fold_right with addP and shiftP *)

    Lemma fold_right_ZtoP: forall fZ fP,
      (forall x y, fP (ZtoP x) (ZtoP y) = ZtoP (fZ x y)) ->
      forall f l,
        fold_right fP O (map (fun x : Z => ZtoP (f x)) l ) =
        ZtoP (fold_right fZ 0 (map f l)).
    Proof.
      intros. apply fold_right_map. exact H. unfold ZtoP. apply mulP_zero.
    Qed.

    Lemma fold_right_addP: forall f l,
      fold_right addP O (map (fun x : Z => ZtoP (f x)) l) =
      ZtoP (fold_right Z.add 0 (map f l)).
    Proof.
      apply fold_right_ZtoP. unfold ZtoP. intros. rewrite mulP_addP. trivial.
    Qed.

    Lemma fold_right_addP_shiftP: forall f l,
      fold_right (fun x y : P => addP x (doubleP y)) O (map (fun x : Z => ZtoP (f x)) l) =
      ZtoP (fold_right (fun x y : Z => Z.add x (Z.double y)) 0 (map f l)).
    Proof.
      apply fold_right_ZtoP. unfold ZtoP. intros.
      rewrite mulP_addP. rewrite mulP_doubleP. trivial.
    Qed.

    (* -------------------- *)
    (* table_lookup *)

    Lemma table_entry'_spec: forall bnum offset e : Z,
      0 <= bnum < n -> 0 <= offset < s
        -> table_entry' bnum (extract_bits (offset + bnum * s * t) e) = ZtoP (eval (entry bnum offset) e).
    Proof.
      intros.
      unfold eval, entry, table_entry'.
      rewrite fold_right_addP.
      rewrite map_map.
      f_equal.
      f_equal.
      apply map_ext_in.
      intros.
      rewrite Z.mul_comm.
      f_equal.
      unfold sbit.
      f_equal.
      f_equal.
      f_equal.
      assert (Hb: 0 <= t * bnum) by nia.
      assert (Ht': 0 <= t) by lia.
      pose proof Zseq_bound' t Ht' (t * bnum) Hb.
      apply H2 in H1.
      replace a with (a - t * bnum + t * bnum) by lia.
      remember (a - t * bnum) as a'.
      rewrite Z.add_simpl_r.
      rewrite HD.
      replace (s * (a' + t * bnum) + offset) with (s * a' + (offset + bnum * s * t)) by nia.
      eapply extract_bits_spec; assert (0 < s * t) by nia; nia.
    Qed.

    Lemma testbit_flip: forall d t' b : Z,
      0 <= d < 2 ^ t' -> 0 <= b < t'
        -> Z.testbit (2 ^ t' - 1 - d) b = negb (Z.testbit d b).
    Proof.
      intros.
      rewrite <- Z.lnot_spec by lia.
      rewrite <- Z.mod_pow2_bits_low with (n := t') by lia.
      rewrite <- Z.mod_pow2_bits_low with (n := t') (a := Z.lnot d) by lia.
      f_equal.
      rewrite <- mod_sub with (b := 1) by nia.
      f_equal.
      pose proof Z.add_lnot_diag d.
      lia.
    Qed.

    Lemma b2z_testbit_flip: forall d t' b : Z,
      0 <= d < 2 ^ t' -> 0 <= b < t'
        -> 2 * (Z.b2z (Z.testbit (2 ^ t' - 1 - d) b)) - 1
           = - (2 * (Z.b2z (Z.testbit d b)) - 1).
    Proof.
      intros.
      rewrite testbit_flip by assumption.
      case (Z.testbit d b); reflexivity.
    Qed.

    Lemma testbit_top_bit: forall d t' : Z,
      1 <= t' -> 0 <= d < 2 ^ t'
        -> Z.testbit d (t' - 1) = (2 ^ (t' - 1) <=? d).
    Proof.
      intros.
      assert (0 <= t' - 1) by lia.
      case_eq (2 ^ (t' - 1) <=? d); intro.
      - rewrite Z.leb_le in H2.
        replace (t' - 1) with (0 + (t' - 1)) by lia.
        rewrite <- Z.div_pow2_bits by lia.
        replace (d / 2 ^ (t' - 1)) with 1; auto.
        replace d with (d - 2 ^ (t' - 1) + 1 * 2 ^ (t' - 1)) by lia.
        rewrite Z.div_add by nia.
        replace 1 with (0 + 1) at 1 by lia.
        apply Z.add_cancel_r.
        symmetry.
        apply Z.div_small.
        replace (2 ^ t') with (2 ^ (t' - 1) + 2 ^ (t' - 1)) in H0.
        lia.
        replace t' with (t' - 1 + 1) at 3 by lia.
        rewrite Z.pow_add_r by lia.
        nia.
      - rewrite Z.leb_gt in H2.
        replace (t' - 1) with (0 + (t' - 1)) by lia.
        rewrite <- Z.div_pow2_bits by lia.
        replace (d / 2 ^ (t' - 1)) with 0; auto.
        symmetry.
        apply Z.div_small.
        lia.
    Qed.

    Lemma table_entry'_flip: forall bnum d : Z,
      0 <= d < 2 ^ t -> 0 <= bnum
        -> table_entry' bnum (2 ^ t - 1 - d) = negP (table_entry' bnum d).
    Proof.
      intros.
      unfold table_entry'.
      assert (rewrite_map:
        map (fun x : Z => ZtoP ((2 * Z.b2z (Z.testbit (2 ^ t - 1 - d) (x - t * bnum)) - 1) * 2 ^ (s * x)))
        (Zseq (t * bnum) t) =
        map (fun x : Z => negP (ZtoP ((2 * Z.b2z (Z.testbit d (x - t * bnum)) - 1) * 2 ^ (s * x))))
        (Zseq (t * bnum) t)).
      {
        apply map_ext_in.
        intros.
        rewrite Zseq_bound' in H1 by lia.
        rewrite b2z_testbit_flip by lia.
        unfold ZtoP.
        rewrite <- mulP_negP.
        f_equal.
        nia.
      }
      rewrite rewrite_map.
      apply fold_right_map.
      - exact addP_negP.
      - rewrite <- mulP_zero with (Q := B).
        rewrite <- mulP_negP.
        f_equal; lia.
    Qed.

    Lemma table_lookup_spec: forall bnum offset e : Z,
      0 <= bnum < n -> 0 <= offset < s
        -> table_lookup bnum (extract_bits (offset + bnum * s * t) e) = ZtoP (eval (entry bnum offset) e).
    Proof.
      intros.
      pose proof extract_bits_bound (offset + bnum * s * t) e.
      unfold table_lookup.
      pose proof testbit_top_bit (extract_bits (offset + bnum * s * t) e) t Ht H1.
      case_eq (Z.testbit (extract_bits (offset + bnum * s * t) e) (t - 1)); intro; rewrite H3 in *.
      - symmetry in H2.
        rewrite Z.leb_le in H2.
        replace (2 ^ t) with (2 ^ (t - 1) + 2 ^ (t - 1)) in *;
          [ | replace t with (t - 1 + 1) at 3 by lia; rewrite Z.pow_add_r; nia ].
        rewrite table_entry_hyp by lia.
        rewrite <- table_entry'_flip.
        + rewrite <- table_entry'_spec by lia.
          f_equal.
          replace (2 ^ t) with (2 ^ (t - 1) + 2 ^ (t - 1)) in *;
            [ lia | replace t with (t - 1 + 1) at 3 by lia; rewrite Z.pow_add_r; nia ].
        + replace (2 ^ t) with (2 ^ (t - 1) + 2 ^ (t - 1)) in *;
            [ lia | replace t with (t - 1 + 1) at 3 by lia; rewrite Z.pow_add_r; nia ].
        + lia.
      - symmetry in H2.
        rewrite Z.leb_gt in H2.
        rewrite table_entry_hyp by lia.
        apply table_entry'_spec; assumption.
    Qed.

    (* -------------------- *)
    (* table_comb *)

    Lemma table_comb_spec: forall offset e : Z,
      0 <= offset < s -> table_comb offset e = ZtoP (eval (comb offset) e).
    Proof.
      intros.
      unfold table_comb.
      assert (rewrite_map: map (fun x : Z => table_lookup x (extract_bits (offset + x * s * t) e))
                (Zseq 0 n) = map (fun x : Z => ZtoP (eval (entry x offset) e)) (Zseq 0 n)). {
        apply map_ext_in.
        intros.
        apply table_lookup_spec; apply Zseq_bound in H0; lia.
      }
      rewrite rewrite_map.
      rewrite fold_right_addP.
      f_equal.
      f_equal.
      rewrite comb_entry.
      rewrite <- fold_right_flat_map.
      rewrite fold_right_map with (t := []) (fT := add) (TtoU := fun x => eval x e).
      - f_equal.
      - intros. rewrite eval_add. trivial.
      - trivial.
    Qed.

    (* -------------------- *)
    (* table_multicomb *)

    Theorem table_multicomb_spec: forall e : Z,
      table_multicomb e = ZtoP (eval multicomb e).
    Proof.
      intros.
      unfold table_multicomb.
      unfold ZtoP.
      unfold multicomb.
      assert (rewrite_map: fold_right (fun x y : P => addP x (doubleP y)) O
                (map (fun x : Z => table_comb x e) (Zseq 0 s)) =
              fold_right (fun x y : P => addP x (doubleP y)) O
                (map (fun x : Z => ZtoP (eval (comb x) e)) (Zseq 0 s))).
      { f_equal.
        apply map_ext_in.
        intros.
        pose proof Zseq_bound s Hs.
        apply H0 in H.
        apply table_comb_spec; assumption. }
      rewrite rewrite_map.
      rewrite fold_right_addP_shiftP.
      unfold ZtoP.
      f_equal.
      eapply fold_right_map_cond with (TtoU := fun st : state => eval st e) (val := valid).
      - intros.
        rewrite eval_add.
        rewrite eval_shift by (try assumption; lia).
        nia.
      - intros.
        apply valid_add; try apply valid_shift; try assumption; lia.
      - compute. trivial.
      - unfold valid. auto.
      - unfold comb.
        rewrite Forall_forall.
        intros.
        unfold valid.
        rewrite Forall_map.
        rewrite Forall_forall.
        intros.
        apply Zseq_bound in H0; nia.
    Qed.

    Theorem table_multicomb_correct: forall e : Z,
      - 2 ^ D < e < 2 ^ D -> Zodd e -> table_multicomb e = ZtoP e.
    Proof.
      intros. rewrite table_multicomb_spec. f_equal.
      apply multicomb_correct; assumption.
    Qed.

  End Table.

  Section Oddify.

    (* ======================================== *)
    (* Oddify: support any value of e by reducing mod q to an odd number in bounds. *)

    Definition oddify (e: Z) : Z := if Z.odd e then e else (e - q).
    Definition positify (e: Z) : Z := (2 ^ D - 1 + oddify (e mod q)) / 2.
    (*
      This can always be computed without negative intermediate values:
      if oddify (e mod q) <= 0 then this amounts to flipping the last D bits from  - (oddify (e mod q));
      else, we compute 2 ^ (D - 1) + (oddify (e mod q) >> 1).
    *)

    (*
    Definition positify' (e: Z) : Z :=
     let e := e mod q in
     if Z.odd e then
       2 ^ (D - 1) + (e >> 1)
     else
      ((2 ^ D - 1) - (q - e)) >> 1.

    Definition positify'' (e: Z) : Z :=
     let e := e mod q in
     let o := 2 ^ D - 1 + e in
     let i := if Z.odd e then o else o - q in
     Z.shiftr i 1.
     *)

    Definition extract_bits_positify (offset: Z) (e: Z) : Z
    := List.fold_right Z.add 0 (
    List.map (fun x => Z.b2z (Z.testbit (positify e) (x * s + offset)) * (2 ^ x))
    (Zseq 0 t)).

    Definition table_comb_positify (offset: Z) (e: Z) : P
    := List.fold_right addP O
    (List.map (fun x => table_lookup x (extract_bits_positify (offset + x * s * t) e)) (Zseq 0 n)).

    (* This is the definition used at runtime! *)
    Definition table_multicomb_positify (e: Z) : P :=
    List.fold_right (fun x y => addP x (doubleP y)) O (List.map (fun x => table_comb_positify x e) (Zseq 0 s)).

    (* Evenify has been replaced by positify *)
    (*
    Definition evenify (e: Z) : Z := if Z.odd e then e + q else e.

    Definition sbit_evenify (e: Z) (x: Z) := 2 * Z.b2z (Z.testbit (evenify (e + 2 ^ D - 1) / 2) x) - 1.
    Definition sbit'_evenify (e: Z) (x: Z) := Z.b2z (Z.testbit (evenify (e + 2 ^ D - 1) / 2) x).
    *)

    (* ==================== *)
    (* Lemmas and theorems *)

    (* -------------------- *)
    (* oddify *)

    Lemma oddify_odd: forall (e : Z), Zodd (oddify (e mod q)).
    Proof.
      intros.
      unfold oddify.
      case_eq (Z.odd (e mod q)); intros.
      - apply Zodd_bool_iff. assumption.
      - apply Zeven_plus_Zodd.
        apply Zeven_equiv.
        apply Z.even_spec.
        rewrite Zodd_even_bool in H.
        rewrite Bool.negb_false_iff in H.
        assumption.
        rewrite Z.opp_eq_mul_m1.
        apply Zodd_mult_Zodd; [ assumption | ].
        rewrite Zodd_ex_iff.
        exists (- 1).
        lia.
    Qed.

    Lemma oddify_bounds: forall (e : Z), - 2 ^ D < oddify (e mod q) < 2 ^ D.
    Proof.
      intros.
      unfold oddify.
      pose proof (Z.mod_pos_bound e q Hq).
      case_eq (Z.odd (e mod q)); intros; lia.
    Qed.

    Lemma oddify_mod_q: forall (e : Z), (oddify (e mod q)) mod q = e mod q.
    Proof.
      intros.
      unfold oddify.
      case_eq (Z.odd (e mod q)); intros.
      - rewrite Z.mod_mod; lia.
      - replace q with (1 * q) at 2 by lia.
        rewrite mod_sub by lia.
        rewrite Z.mod_mod; lia.
    Qed.

    Lemma ZtoP_oddify: forall (e : Z), ZtoP (oddify (e mod q)) = ZtoP e.
    Proof.
      intros.
      assert ((oddify (e mod q) - e) mod q = 0). {
        rewrite Zminus_mod.
        rewrite <- oddify_mod_q with (e := e) at 2.
        rewrite Z.sub_diag.
        rewrite Z.mod_0_l; lia.
      }
      apply Z.div_exact in H; [ | lia].
      rewrite Z.sub_move_r in H.
      rewrite H.
      rewrite Z.add_comm.
      unfold ZtoP.
      rewrite mulP_addP.
      rewrite Z.mul_comm.
      rewrite mulP_mulP.
      rewrite mulP_q.
      rewrite <- mulP_zero with (Q := B).
      rewrite <- mulP_mulP.
      rewrite Z.mul_0_r.
      rewrite <- mulP_addP.
      f_equal.
      lia.
    Qed.

    Theorem table_multicomb_oddify_correct: forall e : Z,
      table_multicomb (oddify (e mod q)) = ZtoP e.
    Proof.
      intros. rewrite table_multicomb_correct.
      - apply ZtoP_oddify.
      - apply oddify_bounds.
      - apply oddify_odd.
    Qed.

    (* -------------------- *)
    (* evenify *)

    (*
    Lemma oddify_evenify: forall e, 0 <= e < q ->
    exists f, f mod q = (oddify e) mod q /\
    (f + 2 ^ D - 1) / 2 = evenify (e + 2 ^ D - 1) / 2.
    Proof.
      intros.
      unfold oddify, evenify.
      f_equal.
      case_eq (Z.odd e); intros.
      - replace (Z.odd (e + 2 ^ D - 1)) with false.
        exists e.
        auto.
        admit.
      - replace (Z.odd (e + 2 ^ D - 1)) with true by admit.
        exists (e + q).
        split.
        admit.
        f_equal.
        lia.
    Admitted.
    *)

    (* -------------------- *)
    (* positify *)

    Lemma positify_spec: forall e, 0 <= positify e < 2 ^ D.
    Proof.
      intros.
      unfold positify.
      pose proof oddify_bounds e.
      intuition.
      - apply Z.div_pos; lia.
      - apply Z.div_lt_upper_bound; lia.
    Qed.

    Lemma extract_bits_positify_spec: forall offset e,
      extract_bits_positify offset e = extract_bits offset (oddify (e mod q)).
    Proof.
      intros.
      unfold extract_bits, extract_bits_positify.
      f_equal.
      apply map_ext_in.
      intros.
      unfold sbit', positify.
      f_equal.
      f_equal.
      f_equal.
      f_equal.
      lia.
    Qed.

    Lemma table_comb_positify_spec: forall offset e,
      table_comb_positify offset e = table_comb offset (oddify (e mod q)).
    Proof.
      intros.
      unfold table_comb, table_comb_positify.
      f_equal.
      apply map_ext_in.
      intros.
      f_equal.
      apply extract_bits_positify_spec.
    Qed.

    Lemma table_multicomb_positify_spec: forall e,
      table_multicomb_positify e = table_multicomb (oddify (e mod q)).
    Proof.
      intros.
      unfold table_multicomb, table_multicomb_positify.
      f_equal.
      apply map_ext_in.
      intros.
      apply table_comb_positify_spec.
    Qed.

    Lemma table_multicomb_positify_correct: forall e,
      table_multicomb_positify e = ZtoP e.
    Proof.
      intros.
      rewrite table_multicomb_positify_spec.
      apply table_multicomb_oddify_correct.
    Qed.

  End Oddify.

End TableMult.

Print Transparent Dependencies table_multicomb_positify.

Section Instantiations.

Section AddMod.

  Require Import Spec.ModularArithmetic.

  Definition P := F ( 101 ).
  Definition O : P := F.zero.
  Definition B : P := F.of_Z _ 2.
  Definition addP : P -> P -> P := F.add.
  Definition doubleP : P -> P := F.mul (F.of_Z _ 2).
  Definition mulP (n : Z) : P -> P := F.mul (F.of_Z _ n).
  Definition negP : P -> P := F.opp.

  Definition n := 1.
  Definition s := 2.
  Definition t := 3.
  Definition D := s * t.

  Compute mulP 4 B.

  Print table_entry.
  Compute table_entry P addP mulP O B s t 0 1.
  (* (-16 -4 +1) * 2 mod 101 = 63 *)

  Print extract_bits.
  Compute extract_bits s t D 1 1.

  Print table_comb.
  Compute table_comb P addP negP mulP O B s t n D 1 1.

  Print table_multicomb.
  Compute table_multicomb P addP doubleP negP mulP O B s t n D (-7).

End AddMod.

(* TODO test on multiplication over F_p, using FLT to do negative exponents *)
(* TODO instantiate this for Curve25519 *)

End Instantiations.


Require Export Bmc.Core.

Definition naive_post (I : prop) (T : trans) (P : prop) (k : nat) : Prop :=
  safety_nth I T P (S k).

Definition induction_post (I : prop) (T : trans) (P : prop) : Prop :=
  (forall (s:state), I s -> P s) /\
  (forall (s s':state), P s -> T s s' -> P s').

(**)

Theorem soundness_naive_bounded :
  forall (I:prop) (T:trans) (P:prop) (k:nat),
  naive_post I T P k ->
  forall (i:nat), i <= (S k) ->
  prop_nth_init I T P i.
Proof.
  intros * H i H0 ss.
  unfold naive_post in H.
  induction (S k) as [|k' IHk].
  - assert (i = 0) as A by omega.
    simpl in H.
    unfold prop_nth_init in H.
    rewrite -> A.
    apply H.
  - destruct (Nat.le_gt_cases i k').
    + apply IHk.
      { apply H. }
      { apply H1. }
    + assert (i = S k') by omega.
      destruct k'; rewrite H2; firstorder.
Qed.

Theorem soundness_naive_f :
  forall (I : prop) (T : trans) (P : prop),
  (exists k, ~naive_post I T P k) ->
  ~( forall (i:nat), prop_nth_init I T P i ).
Proof.
  intros * H.
  destruct H as [k].
  contradict H.
  unfold naive_post.
  induction (S k) as [|k' IHk].
  - unfold safety_nth, prop_nth_init.
    intros *.
    apply H.
  - simpl.
    split.
    + apply IHk.
    + unfold prop_nth_init.
      intros *.
      apply H.
Qed.

Theorem completeness_naive_f :
  forall (I : prop) (T : trans) (P : prop),
  ~( forall (i:nat), prop_nth_init I T P i ) ->
  (*exists k, ~naive_post I T P k.*)
  ~( forall k, naive_post I T P k ).
Proof.
  intros * H.
  contradict H.
  unfold prop_nth_init.
  intros *.
  destruct i.
  - specialize (H 0).
    unfold safety_nth, prop_nth_init in H.
    apply H.
  - specialize (H i).
    unfold naive_post, safety_nth in H.
    destruct H as [_ H].
    unfold prop_nth_init in H.
    apply H.
Qed.

Theorem soundness_induction :
  forall (I:prop) (T:trans) (P:prop),
  induction_post I T P ->
    forall (i:nat), prop_nth_init I T P i.
Proof.
  unfold prop_nth_init.
  intros * H *.
  unfold induction_post in H.
  destruct H as [H H0].
  induction i as [|i IHi].
  - firstorder.
  - intros H1 H2.
    rewrite -> snoc_path in H2.
    destruct H2 as [H2 H3].
    rewrite -> Nat.add_0_l in H3.
    apply H0 with (s:=ss.[i]).
    apply IHi.
    apply H1.
    apply H2.
    apply H3.
Qed.

Theorem completeness_naive_basecase :
  forall (I:prop) (T:trans) (P:prop),
  ( forall (i:nat), prop_nth_init I T P i ) ->
      forall (ss:sseq), I ss.[0] -> P ss.[0].
Proof.
  intros * H *.
  assert (forall (ss:sseq),
    I ss.[0] -> path T ss 0 0 -> P ss.[0]) as A
    by apply H.
  simpl in A.
  firstorder.
Qed.

(**)

Require Export Bmc.CoreConj.

Definition naive_post_conj (I : prop) (T : trans) (P : prop) (k : nat) : Prop :=
  safety_nth_conj I T P (S k).

Theorem naive_post_conj_eq :
  forall (I:prop) (T:trans) (P:prop) (k:nat),
  naive_post I T P k <-> naive_post_conj I T P k.
Proof.
  intros *.
  unfold naive_post, naive_post_conj.
  apply safety_nth_conj_eq.
Qed.

(* eof *)


Require Export Iron.Language.SystemF2Effect.Type.Exp.Base.
Require Export Iron.Language.SystemF2Effect.Type.Relation.EquivT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.SubsT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.KindTs.

(********************************************************************)
Inductive EquivTs : kienv -> stprops -> list ty -> list ty -> ki -> Prop :=
 | EqsSum
   :  forall ke sp ts1 ts2 k
   ,  SumKind k
   -> KindTs ke sp ts1 k
   -> KindTs ke sp ts2 k
   -> Forall (fun t2 => In t2 ts1) ts2
   -> Forall (fun t1 => In t1 ts2) ts1
   -> EquivTs ke sp ts1 ts2 k.

(********************************************************************)
Lemma equivTs_app
 :  forall ke sp ts1 ts1' ts2 ts2' k
 ,  EquivTs ke sp ts1 ts1' k
 -> EquivTs ke sp ts2 ts2' k
 -> EquivTs ke sp (ts1 ++ ts2) (ts1' ++ ts2') k.
Proof.
 intros.
 inverts H. inverts H0.
 eapply EqsSum; snorm.
  eapply in_app_split in H0. inverts H0.
   eauto. eauto.
  eapply in_app_split in H0. inverts H0.
   eauto. eauto.
Qed.
Hint Resolve equivTs_app.

Lemma equivTs_sumkind
 :  forall  ks sp ts1 ts2 k
 ,  EquivTs ks sp ts1 ts2 k
 -> SumKind k.
Proof. intros. inverts H; auto. Qed.
Hint Resolve equivTs_sumkind.

Lemma equivTs_kinds_left
 :  forall  ks sp ts1 ts2 k
 ,  EquivTs ks sp ts1 ts2 k
 -> KindTs  ks sp ts1 k.
Proof. intros. inverts H; auto. Qed.
Hint Resolve equivTs_kinds_left.

Lemma equivTs_kinds_right
 :  forall  ks sp ts1 ts2 k
 ,  EquivTs ks sp ts1 ts2 k
 -> KindTs  ks sp ts2 k.
Proof. intros. inverts H; auto. Qed.
Hint Resolve equivTs_kinds_right.

Lemma equivTs_refl
 :  forall  ke sp ts k
 ,  SumKind k
 -> KindTs  ke sp ts k
 -> EquivTs ke sp ts ts k.
Proof.
 intros.
 induction ts.
  eapply EqsSum; auto.
  eapply EqsSum; auto.
   norm. norm.
Qed.
Hint Resolve equivTs_refl.

Lemma equivTs_sym
 :  forall ke sp ts1 ts2 k
 ,  SumKind k
 -> KindTs  ke sp ts1 k
 -> KindTs  ke sp ts2 k
 -> EquivTs ke sp ts1 ts2 k
 -> EquivTs ke sp ts2 ts1 k.
Proof.
 intros. inverts H2.
 eapply EqsSum; auto.
Qed.

Lemma equivTs_trans
 :  forall ke sp ts1 ts2 ts3 k
 ,  EquivTs ke sp ts1 ts2 k
 -> EquivTs ke sp ts2 ts3 k
 -> EquivTs ke sp ts1 ts3 k.
Proof.
 intros.
 inverts H. inverts H0.
 eapply EqsSum; snorm.
Qed.