(**

  mech.v

  A Mechanism definition framework, for "pure" (i.e., "deterministic") strategies.

  Extensions could include agent-specific actions [A_i], interdependent true values,
  the implementation problem and non-deterministism.

  References:
  - [0] N. Nisan, T. Roughgarden, E. Tardos, & V. Vazirani (Eds.), Algorithmic
        Game Theory (pp. 3-26). Cambridge: Cambridge University Press.
  - [1] Tardos, E., and Vazirani, V. (2007). Basic Solution Concepts and
        Computational Issues. In [0] (pp. 3-26).
  - [2] www.cril.univ-artois.fr/~konieczny/enseignement/TheorieDesJeux.pdf
  - [3] Nisan, N. (2007). Introduction to Mechanism Design (for Computer Scientists).
        In [0] (pp. 209-242).
  - [4] www.soas.ac.uk/cedep-demos/000_P570_IEEP_K3736-Demo/unit1/page_26.htm
  - [5] A good overview paper for more theorems to include:
        https://www.nobelprize.org/uploads/2018/06/advanced-economicsciences2007.pdf

  Authors: Emilio J. Gallego Arias (++), Pierre Jouvelot (+).

  Date: November, 2021.

  (+) Mines Paris, PSL University, France
  (++) Inria, France

  Licence: CeCILL-B.

*)

From mathcomp Require Import all_ssreflect all_algebra all_fingroup.

Require Import Coq.Logic.IndefiniteDescription.
Require Import Coq.Logic.Classical.
Require Import Coq.Logic.Decidable.

From mech Require Import lib labelling.

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

(** Agent. *)

Module agent.

Section Agent.

Variable n : nat.     (* number of agents in the mechanism *)

Definition type := 'I_n.

Definition pred := @ord_pred n.
Definition succ (n : nat) := @ord_succ n.
Definition last (n : nat) : 'I_n.+1 := ord_max.

Definition agents : n.-tuple type := ord_tuple n.

End Agent.

End agent.

(** Mechanism, for a given domain [A] of actions, also called "messages", of [n] agents *)

Module mech.

Section Mech.

Record type {A : Type} (n : nat) :=
    new {
        O : Type;            (* domain of outcomes *)
        M : n.-tuple A -> O;  (* social outcome for the agents' actions *)
      }.

End Mech.

End mech.

Coercion mech.M : mech.type >-> Funclass.

(** Maps of agents' preferences, also called "profiles", for a given mechanism [m]. *)

Module prefs.

Section Prefs.

Variable (A : Type) (n : nat).

Definition mech : Type := @mech.type A n.

Notation agent := (agent.type n).
Notation strategy := (agent -> A).

Record type (m : mech) :=
  new {
      v : strategy;               (* "true value" strategy, mapping each agent private true
                                     value, or "type", to an action/message *)
      U : agent -> mech.O m -> nat;   (* utility *)
      s : strategy                (* strategy used in [m] *)
    }.

End Prefs.

End prefs.

(** Strategy, dominance, Nash equilibrium and Pareto properties. *)

Section Strategy.

Variable (A : eqType) (n : nat).

Variable (m : @mech.type A n).
Variable (p : @prefs.type A n m).

Definition U := prefs.U p.

Definition true_value_strategy := prefs.v p.

Notation agent := (agent.type n).
Notation strategy := (agent -> A).

Definition actions (s : strategy) := [tuple s j | j < n].
Definition set_in_actions (s s' : strategy) i :=
  [tuple if j == i then s' j else s j | j < n].

Section Dominance. (* See [1] *)

Definition dominates (g : rel nat) (s s' : strategy) (i : agent) :=
  g (U i (m (set_in_actions s' s i))) (U i (m (actions s'))).

Variable (s : strategy).

Definition weakly_dominant := forall i s', dominates geq s s' i.
Definition strictly_dominant := forall i s', ~ (s =1 s') -> dominates gtn s s' i.

Lemma dominant_strict_is_weak : strictly_dominant -> weakly_dominant.
Proof.
move=> d i s'.
move: (d i s').
have [eqss' _|/eqfunP ness' /(_ ness')] := boolP ([forall i, s i == s' i]); last by exact: ltnW.
rewrite /dominates /= eq_leq //.
congr (U _ (_ _)).
apply: eq_from_tnth => j.
rewrite !tnth_map tnth_ord_tuple.
move: eqss' => /forallP /(_ j) /eqP ->.
by rewrite if_same.
Qed.

End Dominance.

Section Nash. (* See [1] *)

Definition Nash_equilibrium (s : strategy) :=
  forall (i : agent) (s' : strategy),
    U i (m (actions s)) >= U i (m (set_in_actions s s' i)).

Variable s : strategy.

Lemma dominant_is_Nash : weakly_dominant s -> Nash_equilibrium s.
Proof.
move=> d i s' /=.
move: (d i (fun j => if j == i then s' j else s j)).
have [eqss'|_ ltuu'] := boolP ([forall i, s i == s' i]).
- rewrite eq_leq //; congr (U i (m _)).
  apply: eq_from_tnth => j.
  rewrite !tnth_map !tnth_ord_tuple.
  move: eqss' => /forallP /(_ j) /eqP ->.
  by rewrite if_same.
- apply: (leq_trans ltuu').
  rewrite eq_leq //; congr (U i (m _)).
  apply: eq_from_tnth => j.
  rewrite !tnth_mktuple.
  by case: (j == i).
Qed.

Lemma Nash_uniq : strictly_dominant s -> forall s', Nash_equilibrium s' -> s' =1 s.
Proof.
rewrite /strictly_dominant /dominates /Nash_equilibrium /= => d s' N i.
move: (d i s').
have [/eqfunP -> //|/eqfunP ness' /(_ ness')] := boolP ([forall i, s i == s' i]).
by rewrite ltnNge N.
Qed.

(* Another version of Nash_uniq. *)

Notation finstrategy := {ffun agent -> A}.

Variant Nash_equilibrium_spec : finstrategy -> Type :=
  NashEquilibriumSpec (s : finstrategy) of Nash_equilibrium s : Nash_equilibrium_spec s.

Definition fins := [ffun i : agent => s i].

Lemma fins_Nash_equilibrium_spec : Nash_equilibrium s -> Nash_equilibrium_spec fins.
Proof.
move=> NE.
have/NashEquilibriumSpec //: Nash_equilibrium fins.
  move=> i s'.
  rewrite /actions /set_in_actions.
  have -> : [tuple fins j | j < n] = [tuple s j | j < n].
    apply: eq_from_tnth => j.
    by rewrite !tnth_mktuple ffunE.
  have -> : [tuple if j == i then s' j else fins j  | j < n] =
           [tuple if j == i then s' j else s j  | j < n].
    apply: eq_from_tnth => j.
    by rewrite !tnth_mktuple ffunE.
  exact: NE.
Qed.

Lemma Nash_singleton : strictly_dominant s -> singleton Nash_equilibrium_spec.
Proof.
move=> d _ _ [s1 NE1] [s2 NE2].
apply/ffunP => i.
move: (d i s1).
have [/forallP/(_ i)/eqP <-|/eqfunP ness1 /(_ ness1)] := boolP ([forall i, s i == s1 i]);
  last by rewrite /dominates /= ltnNge NE1.
move: (d i s2).
have [/forallP/(_ i)/eqP <- //|/eqfunP ness2 /(_ ness2)] := boolP ([forall i, s i == s2 i]).
by rewrite /dominates /= ltnNge NE2.
Qed.

(* Multiple equilibria. See [2]. *)

Definition Nash_equiv (s' : strategy) :=
  Nash_equilibrium s /\ Nash_equilibrium s' ->
  forall i, U i (m (actions s)) = U i (m (actions s')).

Definition Nash_exchangeable (s' : strategy) :=
  Nash_equilibrium s /\ Nash_equilibrium s' ->
  (forall i, Nash_equilibrium (fun j => if j == i then s j else s' j) /\
        Nash_equilibrium (fun j => if j == i then s' j else s j)).

End Nash.

Section Pareto.

Variable (s : strategy).

Definition Pareto_optimal :=  (* See [4] *)
  forall (s' : strategy) (i: agent),
    let aa := actions s in
    let a'a := set_in_actions s s' i in
    U i (m a'a) > U i (m aa) -> (exists i', U i' (m a'a) < U i' (m aa)).

(* See [2] *)

Variable (s' : strategy).

Definition Pareto_strictly_dominates :=
  (forall i, U i (m (actions s')) < U i (m (actions s))).

Definition Pareto_dominates :=
  (forall i, U i (m (actions s')) <= U i (m (actions s))) /\
  (exists i, U i (m (actions s')) < U i (m (actions s))).

Lemma Pareto_weaken_strict :
  0 < n -> Pareto_strictly_dominates -> Pareto_dominates.
Proof.
move=> lt0n ps.
split => [i|]; first by exact: ltnW.
exists (Ordinal lt0n).
exact: ps.
Qed.

End Pareto.

End Strategy.

(** Truthfulness (i.e., "incentive-compatible") Prop and bool definitions and properties. *)

Section Truthfulness. (* for arbitrary action types *)

Variable (n : nat) (A : Type).

Notation prefs := (@prefs.type A n).

Variable m : @mech.type A n.

Variable p : @prefs m.

Notation "'v_ i" := (prefs.v p i) (at level 10).
Notation "'U_ i" := (prefs.U p i) (at level 10).
Notation "'s_ i" := (prefs.s p i) (at level 10).

Notation bids := (n.-tuple A).

Definition action_on := tnth.

Definition differ_on (bs bs' : bids) i :=
  forall j, j != i -> action_on bs' j = action_on bs j.

Definition truthful' (bs bs' : bids) i :=
  differ_on bs bs' i -> action_on bs i = 'v_i -> 'U_i (m bs') <= 'U_i (m bs).

Definition truthful := forall bs bs' i, truthful' bs bs' i.

Section CounterExample.

Definition counter_example bs bs' i :=
  differ_on bs bs' i /\ action_on bs i = 'v_i /\ 'U_i (m bs) < 'U_i (m bs').

Lemma not_truthful :
  (exists i bs bs', counter_example bs bs' i) -> ~ truthful.
Proof.
move=> [i] [bs] [bs'] [d [a /= ltuu']].
apply: ex_not_not_all; exists bs.
apply: ex_not_not_all; exists bs'.
apply: ex_not_not_all; exists i.
move: ltuu'.
apply: contraPnot => /(_ d a) /=.
rewrite leqNgt.
by apply: contraNnot.
Qed.

Lemma not_truthful_inv
      (decbs : forall bs, decidable (exists y z, ~ truthful' bs y z))
      (decbsbs' : forall bs bs', decidable (exists z, ~ truthful' bs bs' z)) :
  ~ truthful -> exists i bs bs', counter_example bs bs' i.
Proof.
have cl3 : forall T T' T'' (P : T -> T' -> T'' -> Prop)
             (dec1 : forall x, decidable (exists y z, ~ P x y z))
             (dec2 : forall x y, decidable (exists z, ~ P x y z)),
      (~ forall x y z, P x y z) -> exists x y z, ~ P x y z.
  move=> T T' T'' P dec1 dec2 na.
  apply: not_all_not_ex.
  move: (@not_all_ex_not _ _ na) => [x] nx /(_ x).
  apply/(not_not_iff (exists y z, ~ P x y z)) => //.
  apply: not_all_not_ex.
  move: (@not_all_ex_not _ _ nx) => [y] ny /(_ y).
  apply/(not_not_iff (exists z, ~ P x y z)) => //.
  apply: not_all_not_ex.
  by move: (@not_all_ex_not _ _ ny) => [z] nz /(_ z) /NNPP.
move/(@cl3 _ _ _ _ decbs decbsbs') => /constructive_indefinite_description [xbs].
move=> /constructive_indefinite_description [xbs'].
move=> /constructive_indefinite_description [xi].
move/(@imply_to_and (differ_on xbs xbs' xi)) => [diff].
move/(@imply_to_and (action_on xbs xi = 'v_xi)) => [tv] /=.
exists xi. exists xbs. exists xbs'.
split => //. split => //=.
by rewrite ltnNge (@contra_notN (('U_xi (mech.M m xbs')) <= ('U_xi (mech.M m xbs)))).
Qed.

End CounterExample.

End Truthfulness.

Section Truthfulnessb. (* for finite action types -- no decidability issues *)

Variable (n : nat) (A : finType).

Notation agent := (agent.type n).
Notation prefs := (@prefs.type A n).

Variable m : @mech.type A n.

Variable p : @prefs m.

Notation "'v_ i" := (prefs.v p i) (at level 10).
Notation "'U_ i" := (prefs.U p i) (at level 10).

Notation bids := (n.-tuple A).

Definition differ_onb (bs bs' : bids) i :=
  [forall j, (j != i) ==> (action_on bs' j == action_on bs j)].

Lemma equiv_diff bs bs' i: differ_onb bs bs' i <-> differ_on bs bs' i.
Proof.
split => [d j neji|d]; first by apply/eqP; move/forallP/(_ j)/implyP/(_ neji): d.
apply/forallP => j.
apply/implyP => neji.
apply/eqP.
exact: d.
Qed.

Definition truthfulb' bs bs' i :=
  differ_onb bs bs' i ==> (action_on bs i == 'v_i) ==> ('U_i (m bs') <= 'U_i (m bs)).

Definition truthfulb := [forall bs, forall bs', forall i, truthfulb' bs bs' i].

Lemma truthfulP : reflect (truthful p) truthfulb.
Proof.
apply: forallPP => bs.
apply: forallPP => bs'.
apply: forallPP => i.
apply: introP => [imp d a|].
- have ab : action_on bs i == 'v_ i by apply/eqP.
  by move/implyP/(_ (iffRL (equiv_diff bs bs' i) d))/implyP/(_ ab): imp.
- apply: contraNnot => imp.
  apply/implyP => db.
  apply/implyP => ab.
  apply: imp; first by exact: (iffLR (equiv_diff bs bs' i) db).
  exact: eqP.
Qed.

Section CounterExample.

Definition counter_exampleb bs bs' i := ~~ truthfulb' bs bs' i.

Lemma is_counter_exampleb bs bs' i :
  counter_exampleb bs bs' i= (differ_onb bs bs' i &&
                              (action_on bs i == 'v_i) &&
                              ('U_i (m bs) < 'U_i (m bs'))).
Proof. by rewrite /counter_exampleb !negb_imply ltnNge andbA. Qed.

Lemma not_truthfulb :
  ~~ truthfulb <-> exists i, exists bs, exists bs', counter_exampleb bs bs' i.
Proof.
split.
- move/forallPn/sigW => [xbs] /forallPn /sigW [xbs'] /forallPn /sigW [xi] ntP.
  exists xi. exists xbs. exists xbs'.
  rewrite is_counter_exampleb /=.
  rewrite /truthfulb' in ntP.
  by move: ntP; rewrite ltnNge !negb_imply => /andP [-> /andP [-> ->]].
- move=> [xi] [xbs] [xbs'].
  rewrite is_counter_exampleb => /andP [/andP [d a]] ub.
  apply/truthfulP/not_truthful.
  exists xi. exists xbs. exists xbs'.
  split; first by exact: (iffLR (equiv_diff xbs xbs' xi) d).
  by split; first by apply/eqP.
Qed.

Lemma not_truthful_invb :
  ~ truthful p -> exists i, exists bs, exists bs', counter_example p bs bs' i.
Proof.
move=> /truthfulP /not_truthfulb [i] [bs] [bs'].
rewrite /counter_exampleb !negb_imply => /and3P [d /eqP a u].
exists i. exists bs. exists bs'.
rewrite /counter_example a ltnNge u /differ_on.
split => [j neji|]; last by split.
by move: d => /forallP /(_ j) /implyP /(_ neji) /eqP.
Qed.

End CounterExample.

End Truthfulnessb.

(** Class [truthfulMech] of truthful mechanisms, as a subclass of [mech]. *)

Module truthfulMech.

Section TruthfulMech.

Variable (A : Type) (n : nat).

Record type :=
    new {
        b :> @mech.type A n;             (* base mechanism *)
        p : prefs.type b;                (* preferences *)
        _ : truthful p                   (* truthful prop *)
      }.

End TruthfulMech.

Section Properties.

Variable (A : eqType) (n : nat).

Variable m : @truthfulMech.type A n.

Notation agent := (agent.type n).
Notation prefs := (@prefs.type A n).

Notation p := (p m).

Notation "'v_ i" := (prefs.v p i) (at level 10).

Notation bids := (n.-tuple A).

Notation weakly_dominates := (dominates p geq).

Local Lemma eq_bsbs'_bs (bs bs' : bids) (i : agent) (d : differ_on bs bs' i) :
  [tuple if j == i then action_on bs j else action_on bs' j  | j < n] = bs.
Proof.
apply: eq_from_tnth => j.
rewrite tnth_map tnth_ord_tuple.
case eqji: (j == i) => //.
exact: (d j (negbT _)).
Qed.

Lemma truthful_iff_weakly_dominates_i i bs (tvi : action_on bs i = 'v_i)
      bs' (d : differ_on bs bs' i) :
  truthful' p bs bs' i <-> weakly_dominates (action_on bs) (action_on bs') i.
Proof.
rewrite /dominates /truthful' /actions /set_in_actions /prefs.U /=.
rewrite /differ_on /action_on in d tvi *.
rewrite tuple_of_tnth eq_bsbs'_bs //.
split => //.
by move=> ->.
Qed.

Local Lemma truthful_iff_weakly_dominant_i i bs (tvi : action_on bs i = 'v_i) :
  (forall bs', truthful' p bs bs' i) <->
  (forall bs', differ_on bs bs' i -> weakly_dominates (action_on bs) (action_on bs') i).
Proof.
split => [/(_ _)/(truthful_iff_weakly_dominates_i tvi) //|dom bs' d _].
apply/(iffRL (truthful_iff_weakly_dominates_i tvi d)) => //.
exact: dom.
Qed.

Lemma truthful_iff_weakly_dominant :
  truthful p <-> weakly_dominant p (true_value_strategy p).
Proof.
rewrite /truthful /truthful' /differ_on /action_on /weakly_dominant /dominates.
split=> [t i s' /=|/= d bs bs' i diff tv].
- apply: t => [j nejij|]; last by rewrite tnth_mktuple eq_refl.
  by rewrite !tnth_mktuple ifF // (@negbTE (j == i)).
- move: (d i (tnth bs')).
  rewrite /actions /set_action tuple_of_tnth => ltuu.
  rewrite (leq_trans ltuu) // eq_leq //; congr (U _ _ (m _)).
  apply: eq_from_tnth => j.
  rewrite tnth_map tnth_ord_tuple.
  have [/eqP ->|/diff //] := boolP (j == i).
  by rewrite tv.
Qed.

Lemma Nash_truthful: Nash_equilibrium p (true_value_strategy p).
Proof. by apply/dominant_is_Nash/(iffLR truthful_iff_weakly_dominant); case: m. Qed.

End Properties.

End truthfulMech.

Coercion truthfulMech.b : truthfulMech.type >-> mech.type.

(** Invariance of mechanisms over agent permutations and sorting. *)

Section Perm.

Variable (n : nat) (A : eqType).

Variable m : @mech.type A n.

Notation O := (mech.O m).

Variable p : prefs.type m.

Notation v := (prefs.v p).
Notation U := (prefs.U p).

Import GroupScope.

Definition ptuple Pi (bs : n.-tuple A) := [tuple tnth bs (Pi i)| i < n].

Variable M_perm_ind : forall Pi bs, m (ptuple Pi bs) = m bs.

Variable (bs bs' : n.-tuple A).

Variable (s : (@agent.type n -> A)).

Variable Pi : {perm 'I_n}.

Let Pm := @mech.new A n O (m \o (ptuple Pi)).
Let Pp := @prefs.new A n Pm (v \o Pi) (U \o Pi) s.

Lemma truthful_permP i:
  truthful' Pp (ptuple Pi bs) (ptuple Pi bs') (Pi^-1 i) <-> truthful' p bs bs' i.
Proof.
split; move=> H d_i a_t /=.
- rewrite /truthful' in H.
  have dinv: differ_on (ptuple Pi bs) (ptuple Pi bs') (Pi^-1 i).
    rewrite /differ_on in d_i * => j neji.
    have/(d_i (Pi j)): Pi j != i.
      move: neji.
      apply: contra_neq => <-.
      by rewrite permK.
    by rewrite /action_on /ptuple !tnth_map !tnth_ord_tuple.
  have tvinv: action_on (ptuple Pi bs) (Pi^-1 i) = (v \o Pi) (Pi^-1 i).
    move: a_t.
    by rewrite /action_on /ptuple !tnth_map !tnth_ord_tuple /= permKV.
  move: (H dinv tvinv) => /=.
  by rewrite permKV !M_perm_ind.
- rewrite permKV !M_perm_ind.
  apply: H.
  - rewrite /differ_on /action_on in d_i * => j neji.
    have/(d_i (Pi^-1 j)): Pi^-1 j != Pi^-1 i.
      move: neji.
      by apply: contra_neq => /perm_inj ->.
    by rewrite /ptuple !tnth_map !tnth_ord_tuple permKV.
  - rewrite /action_on /ptuple in a_t *.
    move: a_t.
    rewrite !tnth_map !tnth_ord_tuple permKV => -> /=.
    by rewrite permKV.
Qed.

End Perm.

Section Sorted.

Variable (n : nat) (A : eqType).

Variable m : @mech.type A n.

Notation O := (mech.O m).

Variable p : prefs.type m.

Notation v := (prefs.v p).
Notation U := (prefs.U p).

Variable M_perm_ind : forall Pi bs,  m (ptuple Pi bs) = m bs.

Variable (bs bs' : n.-tuple A) (i : 'I_n).

Variable (s : @agent.type n -> A).

Variable leq_act : rel A.

Definition idx := idxa leq_act bs i.

Let sorting_fun := tnth (tlabel leq_act bs).

Lemma sorting_inj: injective sorting_fun.
Proof. apply: labelling_inj. exact: tlabelP. Qed.

Let Pi := perm sorting_inj.

Import GroupScope.

Definition Pm := @mech.new A n O (m \o (ptuple Pi)).
Definition Pp := @prefs.new A n Pm (v \o Pi) (U \o Pi) s.

Lemma truthful_sorted :
  truthful' Pp (tsort leq_act bs) (ptuple Pi bs') idx -> truthful' p bs bs' i.
Proof.
have -> : idx = Pi^-1 i.
  have: injective Pi by exact: perm_inj.
  apply.
  by rewrite permKV permE /sorting_fun cancel_idxa.
have -> : tsort leq_act bs = ptuple Pi bs; last by rewrite truthful_permP.
  apply: eq_from_tnth => j.
  rewrite tnth_map tnth_ord_tuple permE /sorting_fun.
  move: (labellingP leq_act bs) => /forallP /(_ j) /eqP ->.
  congr (tnth _ (tnth _ _)); last exact: uniq_labelling.
Qed.

End Sorted.

(** Relational mapping between mechanisms. *)

Section Relational.

Variable (n : nat ) (A1 A2 : Type).

Notation agent := (agent.type n).

Variable (m1 : @mech.type A1 n) (m2 : @mech.type A2 n).

Notation O1 := (mech.O m1).
Notation O2 := (mech.O m2).

(* Relation between inputs. *)

Variable Ra : agent -> A1 -> A2 -> Prop.

Definition Ri (i1 : n.-tuple A1) (i2 : n.-tuple A2) : Prop :=
  forall i, Ra i (action_on i1 i) (action_on i2 i).

(* Special case when the input for M1 can be produced from the input for M2. *)

Variable fR : agent -> A2 -> A1.

Definition fRi (bs2 : n.-tuple A2) := [tuple fR i (tnth bs2 i) | i < n].

Variable p1 : prefs.type m1.
Variable p2 : prefs.type m2.

Notation v1 := (@prefs.v _ n m1 p1).
Notation v2 := (@prefs.v _ n m2 p2).

Hypothesis fRP : forall i a2, Ra i (fR i a2) a2.
Hypothesis fRvP : forall i, fR i (v2 i) = v1 i.

Lemma fRiP bs2:  Ri (fRi bs2) bs2.
Proof. by rewrite /fRi /Ri => i; rewrite /action_on !tnth_map !tnth_ord_tuple. Qed.

Lemma fRdP bs2 bs2' i (hd : differ_on bs2 bs2' i) :
  differ_on (fRi bs2) (fRi bs2') i.
Proof.
move=> j /hd ha; rewrite /action_on in ha.
by rewrite /fRi /action_on !tnth_map !tnth_ord_tuple ha.
Qed.

Lemma fRviP cs i (ha : action_on cs i = v2 i) : action_on (fRi cs) i = v1 i.
Proof. by rewrite /action_on /fRi !tnth_map !tnth_ord_tuple in ha *; rewrite ha fRvP. Qed.

(* There are two lemmas to prove to use the relational framework:

   - refinement: M1 M2 send related inputs to related outputs;
   - compatibility of Ro with utility: if outcomes are related, utilities
      are related (here, with equality).  *)

Variable Ro : O1 -> O2 -> Prop.

Variable MR : forall bs1 bs2 (ri : Ri bs1 bs2), Ro (m1 bs1) (m2 bs2).

Notation U1 := (@prefs.U A1 _ m1 p1).
Notation U2 := (@prefs.U A2 _ m2 p2).

Variable RelFP : forall o1 o2, Ro o1 o2 -> U1^~o1 =1 U2^~o2.

Lemma MP : truthful p1 -> truthful p2.
Proof.
move=> h1 bs2 bs2' i hd1 ht1 /=.
have ho := MR (fRiP bs2).
have ho' := MR (fRiP bs2').
have hu := RelFP ho.
have hu' := RelFP ho'.
rewrite -hu -hu'.
by apply/h1; [apply/fRdP|apply/fRviP].
Qed.

End Relational.

(** Direct revelation mechanism, as a [mech] instance. *)

Module directRevelationMech. (* See [3] *)

Section DirectRevelation.

Variable (n' : nat).

Definition n := n'.+1.

Definition players := agent.agents n.

Variable (V : {ffun 'I_n -> Type}).

Definition V0 : Type := V ord0.

Definition V1n : Type := foldl prod V0 (map V (behead players)).

Variable (A : Type).

Definition choice := V1n -> A.

Definition price := 'I_n -> V1n -> nat.

Variable (c : choice) (p : price).

Definition mech := mech.new (fun u : n.-tuple unit => (c, p)).

End DirectRevelation.

End directRevelationMech.

(** Auction, as a subclass of [mech].

    An [auction] is a mechanism that has the following properties (Krishna, "Auction", 2010).
    - Universality. Outcomes are only defined in terms of actions, here, bids, and are
      independant of the details of the goods to be auctioned.
    - Anonymity. The identities of the bidders play no role in the outcome and prices. *)

Module auction.

Section Auction.

Variable (n m : nat).

Notation A := ('I_m).       (* Actions are bids, coded as ordinals, less than [m] *)
Notation agent := (@agent.type n).

Record type :=
    new {
        b :> @mech.type A n;              (* base mechanism *)
        p : mech.O b -> agent -> option nat
                                  (* price to pay for the outcome, per (winning) agent *)
      }.

Variable (a : type) (v : agent -> A).

(* Default auction a utility, given a true value strategy v. *)

Definition U := fun i (o : mech.O a) =>
                  match p o i with
                  | Some p => v i - p
                  | _ => 0
                  end.

(* Default [prefs] for auction [a], given true value [v] (and [s] = [v]). *)

Definition prefs := prefs.new v U v.

(* Properties *)

(* This definition of [no_positive_transfer] would ony make sense with [int] prices! *)

Definition no_positive_transfer := forall i (o : mech.O a), 0 <= p o i.

Theorem trivial_no_positive_transfer : no_positive_transfer.
Proof. by move=> i o. Qed.

Definition individual_rational i := forall (o : mech.O a),
    match p o i with
    | Some p => p <= v i
    | _ => true
    end.

Lemma individual_rational_if_strictly_useful i (lt0u : forall o, 0 < U i o) :
  individual_rational i.
Proof.
move=> o.
move: (lt0u o).
rewrite /U.
case: (p o i) => // p.
rewrite subn_gt0.
exact: ltnW.
Qed.

Definition rational := forall i, individual_rational i.

Lemma rational_if_strictly_useful (lt0u : forall i o, 0 < U i o) : rational.
Proof. by move=> i; apply/individual_rational_if_strictly_useful/lt0u. Qed.

(* Auctions must be [anonymous]. *)

Definition is_winner i (o : mech.O a) :=
  match p o i with
  | Some _ => true
  | _ => false
  end.

Definition price i (o : mech.O a) :=
  match p o i with
  | Some p => p
  | _ => 0
  end.

Definition anonymous :=
  forall bs i1 i2, let m := mech.M (b a) in
              let o :=  m bs in
              let o21 := m [tuple tnth bs (aperm i (tperm i1 i2)) | i < n]
              in is_winner i1 o  -> is_winner i2 o21
                                   /\ price i1 o = price i2 o21
                                   /\ (forall i, i != i1 /\ i != i2 -> p o i = p o21 i).
End Auction.

(** Relational mapping between auctions. *)

Section Relational.

Variable (n m : nat ).

Notation agent := (agent.type n).
Notation A := 'I_m.   (* actions are bids *)

Variable (m1 : @mech.type A n) (m2 : @mech.type A n).

Notation O1 := (mech.O m1).
Notation O2 := (mech.O m2).

Variable p1 : prefs.type m1.
Variable p2 : prefs.type m2.

Notation v1 := (@prefs.v _ n m1 p1).
Notation v2 := (@prefs.v _ n m2 p2).

(* Auction prices *)

Variable r1 : mech.O m1 -> agent -> option nat.
Variable r2 : mech.O m2 -> agent -> option nat.

Definition act1 := new r1.
Definition act2 := new r2.

(* Relational framework *)

Variable Ro : O1 -> O2 -> Prop.

Variable RelFP : forall o1 o2 i, Ro o1 o2 -> @p _ _ act1 o1 i = @p _ _ act2 o2 i.
Variable RelFvP : forall i, v1 i = v2 i.

(* Functional variant *)

Variable Mo : O2 -> O1.

Hypothesis fRo : forall o2, Ro (Mo o2) o2.

Lemma MP : rational act1 v1 -> rational act2 v2.
Proof.
move=> h1 i o2.
rewrite -(@RelFP (Mo o2) o2 i) -?RelFvP; last exact: fRo.
exact: h1.
Qed.

End Relational.

End auction.

Coercion auction.b : auction.type >-> mech.type.


Require Import PArith.
Require Import ZArith.
Require Import Lia.
Require Import FunctionalExtensionality.
Require Export Classical.
Require Import ClassicalFacts.
Require Import Relations.
Require Import RelationClasses.
Require Import EquivDec.
Require Import List.
Require Import SetoidList.
Require Import Permutation.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import sflib.
Require Import PacoNotation.
Require Import HahnRelationsBasic.

Set Implicit Arguments.

Axiom devil: False.
Ltac admit := exfalso; clear; case devil.

Ltac refl := reflexivity.
Ltac congr := congruence.
Ltac etrans := etransitivity.
Ltac etrans' :=
  match goal with
  | [H: @PreOrder ?A ?R |- ?R (_:?A) (_:?A)] =>
    eapply (@PreOrder_Transitive _ _ H)
  end.
Ltac antisym :=
  match goal with
  | [H: @PartialOrder ?A ?EQ _ ?LE _ |- ?EQ (_:?A) (_:?A)] =>
    apply (partial_order_antisym H)
  end.
Ltac funext := apply functional_extensionality.
Axiom propext: prop_extensionality.
Ltac propext := apply propext.

Ltac condtac :=
  match goal with
  | [|- context[if ?c then _ else _]] =>
    let X := fresh "X" in
    destruct c eqn:X
  end.

Ltac cleartriv :=
    repeat (
      match goal with
      | [H: ?a = ?a |- _] => clear H
      | [H: True |- _] => clear H
      end).

Ltac eqvtac :=
  repeat (repeat
  (match goal with
         | [H: context [@equiv_dec ?a ?b ?c ?d ?x ?y] |- _] => destruct (@equiv_dec a b c d x y) as [deq|]; ss; inv deq
         end; try subst; cleartriv)).

Definition proj_sumbool (P Q: Prop) (a: {P} + {Q}) : bool :=
  if a then true else false.
Arguments proj_sumbool [P Q].
Coercion proj_sumbool: sumbool >-> bool.

Notation rtc := (clos_refl_trans_1n _). (* reflexive transitive closure *)
Notation rc := (clos_refl _). (* reflexive transitive closure *)
Notation tc := (clos_trans_1n _). (* transitive closure *)
Hint Immediate rt1n_refl rt1n_trans t1n_step.
Hint Resolve Relation_Operators.rt1n_trans.

Program Instance rtc_PreOrder A (R:A -> A -> Prop): PreOrder (rtc R).
Next Obligation.
  ii. revert H0. induction H; auto. i.
  exploit IHclos_refl_trans_1n; eauto.
Qed.

Lemma rtc_step_tc
      A a b c
      (rel:relation A)
      (AB: rtc rel a b)
      (BC: rel b c):
  tc rel a c.
Proof.
  revert c BC. induction AB.
  - i. econs. ss.
  - i. exploit IHAB; eauto. i.
    eapply Relation_Operators.t1n_trans; eauto.
Qed.

Lemma rtc_mon
      A (r1 r2:relation A)
      (LE: forall x y, r1 x y -> r2 x y):
  forall x y, rtc r1 x y -> rtc r2 x y.
Proof. i. induction H; eauto. Qed.

Inductive rtcn A (R: A -> A -> Prop): forall (n:nat) (a1 a2:A), Prop :=
| rtcn_nil
    a:
    rtcn R 0 a a
| rtcn_cons
    a1 a2 a3 n
    (A12: R a1 a2)
    (A23: rtcn R n a2 a3):
    rtcn R (S n) a1 a3
.
Hint Constructors rtcn.

Lemma rtcn_rtc A (R: A -> A -> Prop) n a1 a2
      (RTCN: rtcn R n a1 a2):
  rtc R a1 a2.
Proof.
  induction RTCN; auto. econs; eauto.
Qed.

Lemma rtc_rtcn A (R: A -> A -> Prop) a1 a2
      (RTC: rtc R a1 a2):
  exists n, rtcn R n a1 a2.
Proof.
  induction RTC; eauto. i. des.
  esplits; eauto.
Qed.

Lemma tc_rtcn A (R: A -> A -> Prop) a1 a2
      (TC: R⁺ a1 a2):
  exists n, rtcn R n a1 a2 /\ n > 0.
Proof.
  apply t_step_rt in TC. des. apply clos_rt_rt1n in TC0.
  apply rtc_rtcn in TC0. des. esplits; eauto. lia.
Qed.

Lemma rtcn_tc A (R: A -> A -> Prop) n a1 a2
      (RTCN: rtcn R n a1 a2)
      (N: n > 0):
  R⁺ a1 a2.
Proof.
  inv RTCN; [lia|]. apply t_step_rt. esplits; eauto.
  apply clos_rt1n_rt. eapply rtcn_rtc. eauto.
Qed.

Lemma rtcn_snoc A (R: A -> A -> Prop) n a1 a2 a3
      (RTCN: rtcn R n a1 a2)
      (REL: R a2 a3):
  rtcn R (S n) a1 a3.
Proof.
  revert a3 REL. induction RTCN; eauto.
Qed.

Lemma rtcn_app A (R: A -> A -> Prop) n1 n2 a1 a2 a3
      (RTCN1: rtcn R n1 a1 a2)
      (RTCN2: rtcn R n2 a2 a3):
  rtcn R (n1 + n2) a1 a3.
Proof.
  revert n1 a1 RTCN1. induction RTCN2.
  { i. rewrite Nat.add_0_r. ss. }
  i. exploit rtcn_snoc; try exact A12; eauto. i.
  exploit IHRTCN2; eauto. replace (n1 + S n) with (S n1 + n) by lia. ss.
Qed.

Lemma rtcn_inv A (R: A -> A -> Prop) n a1 a2
      (RTCN: rtcn R n a1 a2):
  rtcn (fun a b => R b a) n a2 a1.
Proof.
  induction RTCN; eauto. eapply rtcn_snoc; eauto.
Qed.

Lemma rtcn_imply
      A (R1 R2: A -> A -> Prop) n a1 a2
      (LE: R1 <2= R2)
      (RTCN: rtcn R1 n a1 a2):
  rtcn R2 n a1 a2.
Proof.
  induction RTCN; auto. econs; eauto.
Qed.

Inductive opt_pred A (pred: A -> Prop): forall (a:option A), Prop :=
| opt_pred_intro
    a
    (PRED: pred a):
    opt_pred pred (Some a)
.
Hint Constructors opt_pred.

Inductive opt_rel A B (rel: A -> B -> Prop): forall (a:option A) (b:option B), Prop :=
| opt_rel_None:
    opt_rel rel None None
| opt_rel_Some
    a b
    (REL: rel a b):
    opt_rel rel (Some a) (Some b)
.
Hint Constructors opt_rel.

Inductive opt_rel6 A B C D E F (rel6: A -> B -> C -> D -> E -> F -> Prop):
  forall (a: option A) (b: option B) (c: option C) (d: option D) (e: option E) (f: option F), Prop :=
| opt_rel6_None:
    opt_rel6 rel6 None None None None None None
| opt_rel6_Some
    a b c d e f
    (REL6: rel6 a b c d e f):
    opt_rel6 rel6 (Some a) (Some b) (Some c) (Some d) (Some e) (Some f)
.
Hint Constructors opt_rel6.

Inductive opt_rel7 A B C D E F G (rel7: A -> B -> C -> D -> E -> F -> G -> Prop):
  forall (a: option A) (b: option B) (c: option C) (d: option D) (e: option E) (f: option F) (g: option G), Prop :=
| opt_rel7_None:
    opt_rel7 rel7 None None None None None None None
| opt_rel7_Some
    a b c d e f g
    (REL7: rel7 a b c d e f g):
    opt_rel7 rel7 (Some a) (Some b) (Some c) (Some d) (Some e) (Some f) (Some g)
.
Hint Constructors opt_rel7.

Fixpoint filter_map A B (f: A -> option B) (l: list A): list B :=
  match l with
  | [] => []
  | a::l =>
    match f a with
    | None => filter_map f l
    | Some b => b :: filter_map f l
    end
  end.

Lemma in_filter_map_iff A B (f: A -> option B) (l: list A) (b: B):
  List.In b (filter_map f l) <-> exists a, List.In a l /\ f a = Some b.
Proof.
  induction l; ss.
  { econs; i; des; ss. }
  destruct (f a) eqn:FA; ss.
  - rewrite IHl. intuition; des; subst; eauto.
    rewrite FA in H2. inv H2. auto.
  - rewrite IHl. intuition; des; subst; eauto. congr.
Qed.

Lemma filter_map_app A B (f: A -> option B) (l1 l2: list A):
  filter_map f (l1 ++ l2) = filter_map f l1 ++ filter_map f l2.
Proof.
  induction l1; ss. destruct (f a); ss. rewrite IHl1. ss.
Qed.

Lemma filter_map_in_length
      A B (f:A -> option B) (l:list A)
      a (IN: List.In a l) (FA: f a <> None):
  length (filter_map f l) <> 0.
Proof.
  revert IN. induction l; ss. i. des.
  - subst. destruct (f a); ss.
  - destruct (f a0); eauto. s. lia.
Qed.

Lemma nth_error_some A
      (l:list A) n a
      (SOME: nth_error l n = Some a):
  n < length l.
Proof.
  apply nth_error_Some. rewrite SOME. ss.
Qed.

Lemma nth_error_filter_map_inv A B
      f (l:list A) n (fa:B)
      (NTH: List.nth_error (filter_map f l) n = Some fa):
  exists m a,
    <<NTH: List.nth_error l m = Some a>> /\
    <<FA: f a = Some fa>> /\
    <<N: length (filter_map f (List.firstn (S m) l)) = S n>>.
Proof.
  revert n fa NTH. induction l; ss.
  { i. apply List.nth_error_In in NTH. inv NTH. }
  destruct (f a) eqn:FA.
  - destruct n; ss.
    + i. inv NTH. exists 0. esplits; ss.
    + i. exploit IHl; eauto. i. des.
      exists (S m). esplits; eauto.
  - i. exploit IHl; eauto. i. des.
    exists (S m). esplits; eauto.
Qed.

Lemma SetoidList_findA_rev
      (A B : Type) (eqA : A -> A -> Prop)
      (EQUIV: Equivalence eqA)
      (eqA_dec : forall x y : A, {eqA x y} + {~ eqA x y})
      (l : list (A * B))
      (a : A) (b : B)
      (NODUP: SetoidList.NoDupA (fun p p' : A * B => eqA (fst p) (fst p')) l):
  SetoidList.findA (fun a' : A => if eqA_dec a a' then true else false) l =
  SetoidList.findA (fun a' : A => if eqA_dec a a' then true else false) (List.rev l).
Proof.
  hexploit SetoidList.NoDupA_rev; try exact NODUP; [|i].
  { econs; ii.
    - refl.
    - symmetry. ss.
    - etrans; eauto.
  }

  match goal with
  | [|- ?f = _] => destruct f eqn:FIND
  end.
  { rewrite <- SetoidList.findA_NoDupA in FIND; ss.
    rewrite <- SetoidList.InA_rev in FIND.
    rewrite SetoidList.findA_NoDupA in FIND; ss.
    eauto.
  }

  match goal with
  | [|- _ = ?f] => destruct f eqn:FIND'
  end.
  { rewrite <- SetoidList.findA_NoDupA in FIND'; ss.
    rewrite SetoidList.InA_rev in FIND'.
    rewrite SetoidList.findA_NoDupA in FIND'; ss.
    rewrite FIND' in FIND. congr.
  }

  ss.
Qed.

Lemma List_nth_error_firstn
      A (l:list A) n m a
      (NTH: List.nth_error l n = Some a)
      (LE: n < m):
  List.nth_error (List.firstn m l) n = Some a.
Proof.
  revert n l a NTH LE. induction m; destruct n, l; ss.
  - i. lia.
  - i. lia.
  - i. exploit IHm; eauto. lia.
Qed.

Lemma List_firstn_S A
      (l:list A) n a
      (NTH: List.nth_error l n = Some a):
  List.firstn (S n) l = (List.firstn n l) ++ [a].
Proof.
  revert n a NTH. induction l; destruct n; ss.
  - i. inv NTH. ss.
  - i. erewrite IHl; ss.
Qed.

Lemma List_skipn_nil
      A n:
  @List.skipn A n [] = [].
Proof. induction n; ss. Qed.

Lemma List_firstn_le
      n m (LE: n <= m)
      A (l:list A):
  List.firstn m l = List.firstn n l ++ List.firstn (m - n) (List.skipn n l).
Proof.
  revert n m LE. induction l.
  { i. rewrite List_skipn_nil, ? List.firstn_nil. ss. }
  i. destruct m, n; ss.
  { lia. }
  erewrite IHl; ss. lia.
Qed.

Lemma List_nth_error_skipn
      A (l:list A) n m a
      (NTH: List.nth_error l n = Some a)
      (LE: m <= n):
  List.nth_error (List.skipn m l) (n - m) = Some a.
Proof.
  revert n l a NTH LE. induction m.
  { i. destruct n; ss. }
  i. destruct n, l; ss.
  - lia.
  - exploit IHm; eauto. lia.
Qed.

Lemma List_skipn_cons A
      (l:list A) n a
      (NTH: List.nth_error l n = Some a):
  List.skipn n l = a :: (List.skipn (S n) l).
Proof.
  revert n a NTH. induction l; destruct n; ss.
  - i. inv NTH. ss.
  - i. erewrite IHl; ss.
Qed.

Definition lastn A (n: nat) (l: list A) :=
  List.rev (List.firstn n (List.rev l)).

Lemma lastn_snoc A n (l:list A) x:
  lastn (S n) (l ++ [x]) = (lastn n l) ++ [x].
Proof.
  revert n. induction l using List.rev_ind; ss.
  unfold lastn. s. rewrite List.rev_app_distr. ss.
Qed.

Lemma lastn_cons A n a (l:list A)
      (N: n <= length l):
  lastn n (a::l) = lastn n l.
Proof.
  revert n N. induction l using List.rev_ind; ss.
  { i. destruct n; ss. unfold lastn. s. destruct n; lia. }
  i. destruct n; ss. rewrite List.app_comm_cons, ? lastn_snoc. f_equal.
  eapply IHl. rewrite List.app_length in N. ss. lia.
Qed.

Lemma lastn_one A
      (l: list A)
      (LENGTH: List.length l >= 1):
  exists a, lastn 1 l = [a].
Proof.
  destruct l using List.rev_ind; ss; [lia|]. rewrite lastn_snoc. s. eauto.
Qed.

Lemma lastn_all A n (l: list A)
      (N: n >= length l):
  lastn n l = l.
Proof.
  revert n N. induction l using List.rev_ind; ss.
  { destruct n; ss. }
  i. rewrite List.app_length in N. ss. destruct n; [lia|].
  rewrite lastn_snoc, IHl; ss. lia.
Qed.

Lemma lastn_length A n (l: list A):
  length (lastn n l) = min n (length l).
Proof.
  revert n. induction l using List.rev_ind; ss.
  { destruct n; ss. }
  i. destruct n; ss. rewrite lastn_snoc, ? List.app_length, IHl. s.
  rewrite (Nat.add_comm (length l)). s. lia.
Qed.

Lemma lastn_S A n (l: list A)
      (LENGTH: List.length l > 0):
  exists a l', lastn (S n) l = a :: l'.
Proof.
  generalize (lastn_length (S n) l). i.
  destruct (lastn (S n) l) eqn:LASTN; eauto.
  destruct l; ss. lia.
Qed.

Lemma lastn_S1 A
      (l: list A) n a l'
      (N: n < List.length l)
      (LASTN: lastn (S n) l = a :: l'):
  lastn n l = l'.
Proof.
  rewrite <- List.rev_length in N. apply List.nth_error_Some in N.
  destruct (List.nth_error (List.rev l) n) eqn:NTH; ss.
  revert LASTN. unfold lastn. erewrite List_firstn_S; eauto.
  rewrite List.rev_app_distr. s. i. inv LASTN. ss.
Qed.

Lemma lastn_sub_S A (l l1 l2: list A)
      (SUBL: l = l1 ++ l2)
      (LENGTH: List.length l2 > 0):
  exists n, lastn (S n) l = l2.
Proof.
  eexists (length l2 - 1). rewrite <- Nat.add_1_r.
  replace (length l2 - 1 + 1) with (length l2); [|lia].
  rewrite SUBL. clear SUBL.
  unfold lastn. rewrite List.firstn_rev. rewrite List.rev_involutive.
  rewrite List.app_length. rewrite Nat.add_comm. rewrite minus_plus.
  rewrite List.skipn_app. rewrite List.skipn_all. rewrite minus_diag. ss.
Qed.

Lemma lastn_sub_S1 A n (l l1 l2: list A)
          (LASTN: lastn n l = l2):
  exists l1, l = l1 ++ l2.
Proof.
  revert LASTN. revert n l2.
  induction l; i.
  { eexists ([]). destruct l2; ss. destruct n; ss. }
  destruct (le_lt_dec n (length l)).
  - rewrite lastn_cons in LASTN; [| lia]. apply IHl in LASTN. des.
    eexists (a :: l3). ss. rewrite LASTN. ss.
  - rewrite lastn_all in LASTN; ss.
    eexists ([]). rewrite LASTN. ss.
Qed.

Lemma lastn_length_S A n (l: list A)
      (N: n < List.length l):
  length (lastn (S n) l) = length (lastn n l) + 1.
Proof.
  unfold lastn. repeat rewrite List.rev_length. rewrite <- List.rev_length in N.
  destruct (List.rev l); ss; try lia.
  repeat rewrite List.firstn_length_le; ss; try lia.
Qed.

Lemma lastn_length_incr A n k (l: list A)
      (N: n < List.length l):
  length (lastn n l) < length (lastn (n + (S k)) l).
Proof.
  induction k.
  { rewrite Nat.add_1_r. exploit lastn_length_S; try exact N; eauto. lia. }
  replace (n + S (S k)) with (S (n + (S k))); try lia.
  destruct (le_lt_dec (length l) (n + S k)).
  - replace (length (lastn (S (n + S k)) l)) with (length (lastn (n + S k) l)); ss.
    repeat rewrite lastn_all; ss. lia.
  - etrans; eauto. exploit lastn_length_S; try exact l0; eauto. lia.
Qed.

Lemma app_some_not_eq A x
      (l : list A):
  l ++ [x] <> l.
Proof.
  ii. induction l; ss. injection H. eauto.
Qed.

Fixpoint List_find_pos A (pred:A -> bool) (l:list A): option nat :=
  match l with
  | [] => None
  | a::l =>
    if pred a
    then Some 0
    else option_map S (List_find_pos pred l)
  end.

Lemma List_find_pos_inv A pred (l:list A) n
      (POS: List_find_pos pred l = Some n):
  exists a,
    <<NTH: List.nth_error l n = Some a>> /\
    <<PRED: pred a>> /\
    <<NPRED: forall m b
               (M: m < n)
               (B: List.nth_error l m = Some b),
    ~ pred b>>.
Proof.
  revert n POS. induction l; ss.
  destruct (pred a) eqn:PA.
  - i. inv POS. esplits; ss. i. lia.
  - destruct ((List_find_pos pred l)) eqn:POS; ss. i. inv POS0.
    exploit IHl; eauto. i. des.
    esplits; eauto. i. destruct m; ss.
    + inv B. rewrite PA. ss.
    + eapply NPRED; eauto. lia.
Qed.

Lemma List_in_find_pos A `{_: EqDec A eq} a (l:list A)
      (IN: List.In a l):
  exists n, List_find_pos (fun a' => a' == a) l = Some n.
Proof.
  revert IN. induction l; ss. i. des.
  - subst. destruct (equiv_dec a a); [|congr]. s. eauto.
  - destruct (equiv_dec a0 a); s; eauto.
    specialize (IHl IN). des. rewrite IHl. s. eauto.
Qed.

Lemma List_nth_error_find_pos A `{_: EqDec A eq}
      (l:list A) n a
      (NTH: List.nth_error l n = Some a)
      (NODUP: List.NoDup l):
  List_find_pos (fun a' => a' == a) l = Some n.
Proof.
  revert n a NTH NODUP. induction l.
  { i. apply List.nth_error_In in NTH. inv NTH. }
  destruct n; s.
  - i. inv NTH. destruct (equiv_dec a0 a0); [|congr]. ss.
  - i. inv NODUP. exploit IHl; eauto. i. rewrite x.
    destruct (equiv_dec a a0); ss. inv e.
    contradict H2. eapply List.nth_error_In. eauto.
Qed.

Lemma nth_error_app_inv
      A
      (l1 l2:list A)
      n a
      (FIND: List.nth_error (l1 ++ l2) n = Some a):
  (n < length l1 /\ List.nth_error l1 n = Some a) \/
  (n >= length l1 /\ List.nth_error l2 (n - (length l1)) = Some a).
Proof.
  destruct (lt_dec n (length l1)).
  - left. splits; ss. rewrite List.nth_error_app1 in FIND; ss.
  - right. splits; [lia|]. rewrite List.nth_error_app2 in FIND; [|lia]. ss.
Qed.

Lemma nth_error_singleton_inv
      A
      n (a b:A)
      (FIND: List.nth_error [a] n = Some b):
  n = 0 /\ a = b.
Proof.
  destruct n; ss.
  - inv FIND. ss.
  - destruct n; ss.
Qed.

Lemma nth_error_snoc_inv
      A
      (l:list A) x
      n a
      (FIND: List.nth_error (l ++ [x]) n = Some a):
  (n < length l /\ List.nth_error l n = Some a) \/
  (n = length l /\ x = a).
Proof.
  exploit nth_error_app_inv; eauto. i. des; [left|right]; ss.
  exploit nth_error_singleton_inv; eauto. i. des. subst. splits; ss. lia.
Qed.

Lemma nth_error_snoc_inv_last
      A
      (l:list A) x
      a
      (FIND: List.nth_error (l ++ [x]) (length l) = Some a):
  x = a.
Proof.
  exploit nth_error_snoc_inv; eauto. i. des; ss. lia.
Qed.

Lemma nth_error_app_mon
      A
      (l1 l2:list A)
      n a
      (FIND: List.nth_error l1 n = Some a):
  List.nth_error (l1 ++ l2) n = Some a.
Proof.
  rewrite List.nth_error_app1; ss. apply List.nth_error_Some. congr.
Qed.

Lemma nth_error_last A (l: list A) a:
  nth_error (l ++ [a]) (length l) = Some a.
Proof.
  destruct (nth_error (l ++ [a]) (length l)) eqn:H.
  - exploit nth_error_snoc_inv_last; eauto. congr.
  - rewrite nth_error_None in *. rewrite app_length in *. ss. nia.
Qed.

Lemma strong_nat_ind
      (P: nat -> Prop)
      (STEP: forall n, (forall m, m < n -> P m) -> P n):
  forall n, P n.
Proof.
  cut (forall n, forall m, m < n -> P m).
  { i. eapply H. eauto. }
  induction n; i; [lia|]. apply STEP. i. apply IHn. lia.
Qed.

Lemma partition A
      (l: list A)
      (pred: A -> Prop):
  exists l1 l2,
    Permutation (l1 ++ l2) l /\
    List.Forall pred l1 /\
    List.Forall (fun a => ~ (pred a)) l2.
Proof.
  induction l.
  { esplits; eauto. s. eauto. }
  des. destruct (classic (pred a)).
  - exists (a::l1), l2. esplits; eauto. s. econs. ss.
  - exists l1, (a::l2). esplits; eauto. rewrite <- Permutation_middle. econs. ss.
Qed.

Definition linearized A
           (rel:relation A)
           (l:list A): Prop :=
  forall i j x y
    (I: List.nth_error l i = Some x)
    (J: List.nth_error l j = Some y)
    (REL: rel x y),
    i < j.
Hint Unfold linearized.

Lemma linearize A
      (l: list A)
      (rel: relation A)
      (ACYCLIC: acyclic rel):
  exists l',
    <<PERM: Permutation l' l>> /\
    <<REL: linearized rel l'>>.
Proof.
  remember (length l) as n eqn:LEN. revert l LEN.
  induction n using strong_nat_ind. i. subst.
  destruct l.
  { esplits; eauto. ii. destruct i; ss. }
  generalize (partition l (fun b => rtc rel b a)). i. des.

  exploit (H (length l1)); ss.
  { erewrite <- (Permutation_length H0), List.app_length. lia. }
  i. des.

  exploit (H (length l2)); ss.
  { erewrite <- (Permutation_length H0), List.app_length. lia. }
  i. des.

  exists (l' ++ a :: l'0). esplits.
  { rewrite <- Permutation_middle. econs.
    rewrite Permutation_app; eauto.
  }
  rewrite List.Forall_forall in H1, H2. ii.
  destruct (Nat.compare_spec (length l') i), (Nat.compare_spec (length l') j);
    repeat (subst;
            match goal with
            | [X: List.nth_error (?l ++ _) (length ?l) = Some _ |- _] =>
              rewrite List.nth_error_app2 in X; ss
            | [X: List.nth_error (?l ++ _) ?i = Some _,
                  Y: ?i < length ?l |- _] =>
              rewrite List.nth_error_app1 in X; [|lia]
            | [X: List.nth_error (?l ++ _) ?i = Some _,
                  Y: length ?l < ?i |- _] =>
              rewrite List.nth_error_app2 in X; [|lia]
            | [X: List.nth_error (_ :: _) (?i - ?j) = Some _, Y: ?j < ?i |- _] =>
              let XX := fresh "XX" in
              hexploit Nat.sub_gt; try exact Y; eauto; i; destruct (i - j) eqn:XX
            | [X: context[?x - ?x] |- _] => rewrite Nat.sub_diag in X
            | [X: Some _ = Some _ |- _] => inv X
            end;
            ss).
  - exfalso. eapply ACYCLIC. econs. eauto.
  - hexploit H1.
    { eapply Permutation_in; eauto.
      eapply List.nth_error_In; eauto.
    }
    i. exfalso. eapply ACYCLIC. apply clos_t1n_trans.
    hexploit rtc_step_tc; eauto.
  - hexploit H2.
    { eapply Permutation_in; eauto.
      eapply List.nth_error_In; eauto.
    }
    i. contradict H5. econs; eauto.
  - exploit REL0; try exact REL1; eauto. lia.
  - hexploit H1.
    { eapply Permutation_in; eauto.
      eapply List.nth_error_In; eauto.
    }
    hexploit H2.
    { eapply Permutation_in; eauto.
      eapply List.nth_error_In; eauto.
    }
    i. contradict H6. etrans; eauto.
  - lia.
  - exploit REL; try exact REL1; eauto.
Qed.

Definition list_rev_list_rect
           (A:Type)
           (P:list A -> Type)
           (INIT: P [])
	         (STEP: forall (a:A) (l:list A), P (List.rev l) -> P (List.rev (a :: l))):
	forall l:list A, P (List.rev l).
Proof.
  induction l; auto.
Defined.

Definition list_rev_rect
           (A:Type)
           (P:list A -> Type)
           (INIT: P [])
           (STEP: forall x l, P l -> P (l ++ [x])):
  forall l, P l.
Proof.
  intros.
  generalize (List.rev_involutive l).
  intros E; rewrite <- E.
  apply (list_rev_list_rect P).
  auto.

  simpl.
  intros.
  apply (STEP a (List.rev l0)).
  auto.
Defined.

Instance Pos_eqdec: EqDec positive eq := Pos.eq_dec.
Instance Z_eqdec: EqDec Z eq := Z.eq_dec.

Module Id := Pos.

Module IdMap.
  Include PositiveMap.

  Lemma add_spec
        A id' id (a:A) am:
    find id' (add id a am) =
    if id' == id
    then Some a
    else find id' am.
  Proof.
    erewrite PositiveMapAdditionalFacts.gsspec; eauto.
    repeat condtac; ss.
  Qed.

  Lemma map_spec
        A B (f: A -> B) am id:
    find id (map f am) = option_map f (find id am).
  Proof.
    destruct (find id am) eqn:FIND; s.
    - eapply map_1 in FIND; eauto.
    - destruct (find id (map f am)) eqn:FIND'; ss.
      exploit map_2; [by econs; eauto|].
      intro X. inv X. congr.
  Qed.

  Lemma mapi_spec
        A B (f: key -> A -> B) am id:
    find id (mapi f am) = option_map (f id) (find id am).
  Proof.
    destruct (find id am) eqn:FIND; s.
    - eapply mapi_1 in FIND; eauto. des.
      inv FIND. inv FIND0. eauto.
    - destruct (find id (mapi f am)) eqn:FIND'; ss.
      exploit mapi_2; [by econs; eauto|].
      intro X. inv X. congr.
  Qed.

  Lemma elements_spec A id (am:t A):
    find id am = SetoidList.findA (fun id' => if id == id' then true else false) (elements am).
  Proof.
    generalize (elements_3w am).
    destruct (find id am) eqn:FIND.
    - apply elements_correct in FIND. revert FIND.
      induction (elements am); ss. i. des.
      + subst. destruct (equiv_dec id id); ss. congr.
      + destruct a0; ss. inv H. rewrite <- IHl; eauto.
        destruct (equiv_dec id k); ss. inv e.
        exfalso. apply H2. apply SetoidList.InA_alt. esplits; eauto. econs.
    - match goal with
      | [|- context[_ = ?f]] => destruct f eqn:FIND'
      end; ss.
      i. eapply SetoidList.findA_NoDupA in FIND'; eauto; cycle 1.
      { apply eq_equivalence. }
      apply elements_2 in FIND'. congr.
  Qed.

  Lemma mapi_mapi
        A B C
        (f: Id.t -> A -> B)
        (g: Id.t -> B -> C)
        m:
    mapi g (mapi f m) = mapi (fun tid a => g tid (f tid a)) m.
  Proof.
    unfold mapi. generalize 1%positive. induction m; ss.
    i. rewrite IHm1, IHm2. f_equal. destruct o; ss.
  Qed.

  Lemma add_add A i v1 v2 (m:t A):
    add i v1 (add i v2 m) = add i v1 m.
  Proof.
    revert m. induction i; destruct m; ss; try congruence.
  Qed.

  Lemma add_add_diff A i j v1 v2 (m:t A) (DIFF: i <> j):
    add i v1 (add j v2 m) = add j v2 (add i v1 m).
  Proof.
    revert j m DIFF. induction i; destruct j, m; ss; try congruence.
    - i. f_equal. apply IHi. contradict DIFF. congr.
    - i. f_equal. apply IHi. contradict DIFF. congr.
    - i. f_equal. apply IHi. contradict DIFF. congr.
    - i. f_equal. apply IHi. contradict DIFF. congr.
  Qed.

  Definition Forall2 A B
             (rel: Id.t -> A -> B -> Prop)
             (a: t A)
             (b: t B)
    : Prop :=
    forall id, opt_rel (rel id) (find id a) (find id b).

  Definition Forall6 A B C D E F
             (rel6: Id.t -> A -> B -> C -> D -> E -> F -> Prop)
             (a: t A)
             (b: t B)
             (c: t C)
             (d: t D)
             (e: t E)
             (f: t F)
    : Prop :=
    forall id, opt_rel6 (rel6 id) (find id a) (find id b) (find id c) (find id d) (find id e) (find id f).

  Definition Forall7 A B C D E F G
             (rel7: Id.t -> A -> B -> C -> D -> E -> F -> G -> Prop)
             (a: t A)
             (b: t B)
             (c: t C)
             (d: t D)
             (e: t E)
             (f: t F)
             (g: t G)
    : Prop :=
    forall id, opt_rel7 (rel7 id) (find id a) (find id b) (find id c) (find id d) (find id e) (find id f) (find id g).

  Definition Forall A
             (pred: Id.t -> A -> Prop)
             (m: t A)
    : Prop :=
    forall id a (FIND: find id m = Some a),
      pred id a.

  Inductive interleaving A (m:t (list A)): forall (l:list A), Prop :=
  | interleaving_nil
      (NIL: Forall (fun _ l => l = []) m):
      interleaving m []
  | interleaving_cons
      id a l res
      (FIND: find id m = Some (a::l))
      (INTERLEAVING: interleaving (add id l m) res):
      interleaving m (a::res)
  .
End IdMap.

Module IdSet.
  Include PositiveSet.

  Lemma add_o x' x s:
    mem x' (add x s) =
    if x' == x
    then true
    else mem x' s.
  Proof.
    destruct (equiv_dec x' x).
    - inv e. apply mem_1. apply add_spec. intuition.
    - destruct (mem x' s) eqn:MEM.
      + apply mem_1. apply add_spec. intuition.
      + destruct (mem x' (add x s)) eqn:MEM'; ss.
        apply mem_1 in MEM'. apply add_spec in MEM'. des; intuition.
        apply mem_1 in MEM'. eauto.
  Qed.

  Lemma remove_o x' x s:
    mem x' (remove x s) =
    if x' == x
    then false
    else mem x' s.
  Proof.
    destruct (equiv_dec x' x).
    - inv e. destruct (mem x (remove x s)) eqn:MEM; ss.
      apply remove_spec in MEM. des; ss.
    - destruct (mem x' s) eqn:MEM.
      + apply mem_1. apply remove_spec. intuition.
      + destruct (mem x' (remove x s)) eqn:MEM'; ss.
        apply mem_1 in MEM'. apply remove_spec in MEM'. des.
        apply mem_1 in MEM'0. eauto.
  Qed.
End IdSet.

Inductive inverse A (rel:relation A) (codom:A -> Prop) (a:A): Prop :=
| inverse_intro
    a'
    (REL: rel a a')
    (CODOM: codom a')
.
Hint Constructors inverse.

Lemma inverse_mon A (r1 r2:relation A)
      (REL: r1 ⊆ r2):
  inverse r1 <2= inverse r2.
Proof.
  i. inv PR. econs; eauto.
Qed.

Lemma inverse_union A (r1 r2:relation A) s:
  inverse (r1 ∪ r2) s = inverse r1 s \1/ inverse r2 s.
Proof.
  funext. i. propext. econs; i.
  - inv H. inv REL; eauto.
  - des; inv H; econs; eauto.
    + left. ss.
    + right. ss.
Qed.


From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
From Equations Require Import Equations.
From Translation Require Import util SAst SLiftSubst.
From Translation Require Sorts.
Import ListNotations.

Section Common.

Context `{Sort_notion : Sorts.notion}.

Definition scontext := list sterm.

Definition ssnoc (Γ : scontext) (d : sterm) := d :: Γ.

Notation " Γ ,, d " := (ssnoc Γ d) (at level 20, d at next level) : s_scope.
Delimit Scope s_scope with s.

Record squash (A : Set) : Prop := { _ : A }.

(* Common lemmata *)

(* Lemma max_id : *)
(*   forall s, @Sorts.max Sorts.nat_sorts s s = s. *)
(* Proof. *)
(*   intro s. cbn. auto with arith. *)
(* Defined. *)

(* Lemma max_id : *)
(*   forall s, @Sorts.max Sorts.type_in_type s s = s. *)
(* Proof. *)
(*   intro s. cbn. auto with arith. *)
(* Defined. *)

(* Lemma max_succ_id : *)
(*   forall s, max_sort (succ_sort s) s = succ_sort s. *)
(* Proof. *)
(*   intro s. unfold max_sort, succ_sort. *)
(*   auto with arith. *)
(* Defined. *)

Definition sapp_context (Γ Γ' : scontext) : scontext := (Γ' ++ Γ)%list.
Notation " Γ  ,,, Γ' " := (sapp_context Γ Γ') (at level 25, Γ' at next level, left associativity) : s_scope.

Fact cat_nil :
  forall {Γ}, Γ ,,, [] = Γ.
Proof.
  reflexivity.
Defined.

Fact nil_cat :
  forall {Γ}, [] ,,, Γ = Γ.
Proof.
  induction Γ.
  - reflexivity.
  - cbn. f_equal. assumption.
Defined.

Fact length_cat :
  forall {A} {Γ Δ : list A}, #|Γ ++ Δ| = (#|Γ| + #|Δ|)%nat.
Proof.
  intros A Γ. induction Γ ; intro Δ.
  - cbn. reflexivity.
  - cbn. f_equal. apply IHΓ.
Defined.

(** Global contexts of axioms
    Basically a list of ITT types.
 *)
Record glob_decl := { dname : ident ; dtype : sterm }.

Definition sglobal_context : Type := list glob_decl.

Fixpoint lookup_glob (Σ : sglobal_context) (id : ident) : option sterm :=
  match Σ with
  | nil => None
  | d :: Σ =>
    if ident_eq id (dname d) then Some (dtype d)
    else lookup_glob Σ id
  end.

(* Lifting of context *)

Fixpoint lift_context n Γ : scontext :=
  match Γ with
  | nil => nil
  | A :: Γ => (lift n #|Γ| A) :: (lift_context n Γ)
  end.

Fact lift_context0 :
  forall {Γ}, lift_context 0 Γ = Γ.
Proof.
  intro Γ. induction Γ.
  - reflexivity.
  - cbn. rewrite lift00. rewrite IHΓ. reflexivity.
Defined.

Fact lift_context_length :
  forall {k Ξ}, #|lift_context k Ξ| = #|Ξ|.
Proof.
  intros k Ξ.
  induction Ξ.
  - cbn. reflexivity.
  - cbn. f_equal. assumption.
Defined.

(* Substitution in context *)

Fixpoint subst_context u Δ :=
  match Δ with
  | nil => nil
  | A :: Δ => (A{ #|Δ| := u }) :: (subst_context u Δ)
  end.

Fact subst_context_length :
  forall {u Ξ}, #|subst_context u Ξ| = #|Ξ|.
Proof.
  intros u Ξ.
  induction Ξ.
  - cbn. reflexivity.
  - cbn. f_equal. assumption.
Defined.

End Common.

Delimit Scope s_scope with s.
Notation " Γ ,, d " :=
  (ssnoc Γ d) (at level 20, d at next level) : s_scope.
Notation " Γ  ,,, Γ' " :=
  (sapp_context Γ Γ')
    (at level 25, Γ' at next level, left associativity) : s_scope.


(** A little module for doing naive congruence closure; we don't need anything
    much fancier because in practice, for spatial entailments, we only discover
    a few new equalities in each call to the superposition subsystem.

    Pure entailments are another matter entirely, but for now we seem to be fine
    on those (see, eg, test/test.pure.entailments.sf) *)

Load loadpath.
Require Import List veric.Coqlib2 msl.base.
Require Import msl.predicates_sa.
Require Import veristar.datatypes veristar.clauses veristar.clause_lemmas
               veristar.list_denote veristar.basic veristar.compare.
Require Import veristar.model_type veristar.model.

Section cclosure.
Context (A B : Type).
Variables
  (A_cmp : A -> A -> comparison)
  (B_cmp : B -> B -> comparison)
  (fAB : A -> B).

Notation canons := (list (A*B)).

(*Definition isEq (c : comparison) := match c with Eq => true | _ => false end.*)

Fixpoint lookC (a: A) (cs: canons) : B :=
  match cs with nil => fAB a
  | (a1, b1)::cs' => if isEq (A_cmp a a1) then b1
                     else lookC a cs'
  end.

Fixpoint rewriteC (b1 b2 : B) (cs: canons) : canons :=
  match cs with nil => nil
  | (a1, b1')::cs' =>
    let new_cs := rewriteC b1 b2 cs' in
    if isEq (B_cmp b1 b1') then (a1, b2)::new_cs else (a1, b1')::new_cs end.

Definition mergeC (a1 a2 : A) (cs: canons) : canons :=
  match lookC a1 cs, lookC a2 cs with b1, b2 =>
    if isEq (B_cmp b1 b2) then cs
    else (a1, b2)::(a2, b2)::rewriteC b1 b2 cs end.

(* sanity lemmas *)
(*
Lemma lookC_cons a1 b cs : lookC a1 ((a1, b)::cs) = b.
Proof. unfold lookC; simpl. if_tac; auto. exfalso; apply H; auto. Qed.

Lemma lookC_cons2 a1 a2 b cs :
  lookC a1 ((a2, b)::cs) = if A_eq_dec a1 a2 then b else lookC a1 cs.
Proof. unfold lookC; simpl. if_tac; auto. Qed.

Lemma mergeC_lookC a1 a2 cs :
  lookC a1 (mergeC a1 a2 cs) = lookC a2 (mergeC a1 a2 cs).
Proof with simpl; auto; try solve[congruence].
induction cs... unfold mergeC. if_tac... if_tac... if_tac... if_tac...
unfold mergeC; if_tac; auto.
rewrite lookC_cons. rewrite lookC_cons2. if_tac; auto. rewrite lookC_cons...
Qed.
*)
End cclosure.

(*
Module TestCClosure.
Require Import NatOrderedType. Import Nat_as_DT.

Notation lookC := (lookC _ _ eq_dec (fun n => n)).
Notation rewriteC := (@rewriteC nat nat eq_dec).
Notation mergeC := (mergeC _ _ eq_dec eq_dec (fun n => n)).

Compute mergeC 1 2 nil.
Compute mergeC 1 2 (mergeC 3 4 nil).
Compute lookC 3 (mergeC 1 2 (mergeC 3 4 (mergeC 5 6 nil))).
Compute lookC 3 (mergeC 4 5 (mergeC 3 4 (mergeC 5 6 nil))).
Compute lookC 3 (mergeC 1 8 (mergeC 3 4 (mergeC 1 3 (mergeC 1 2 nil)))).

End TestCClosure.
*)

Notation expr_get := (lookC _ _ expr_cmp (@id _)).
Notation expr_merge := (mergeC _ _ expr_cmp expr_cmp (@id _)).

(* used internally *)
Local Notation expr_rewriteC := (rewriteC expr _ expr_cmp).

Fixpoint cclose_aux (l : list clause) : list (expr * expr) :=
  match l with
  | PureClause nil [Eqv s t] _ _ :: l' => expr_merge s t (cclose_aux l')
  | _ => nil
  end.

Definition cclose (l : list clause) : list clause :=
  map (fun p => match p with (e1, e2) => mkPureClause nil [Eqv e1 e2] end)
    (cclose_aux l).

(** Correctness proof *)

Module CCSound (VSM : VERISTAR_MODEL).
Import VSM VeriStarLogic.

Definition expr_eqs_denote (l : list (expr * expr)) :=
  listd (fun p => match p with (e1, e2) => (e1 === e2) end) inter TT l.

Lemma expr_get_sound e l s : expr_eqs_denote l s -> (e === expr_get e l) s.
Proof with simpl; auto.
induction l... unfold id... intros; apply var_eq_refl.
destruct a. intros [H1 H2]. remember (expr_cmp e e0) as b. destruct b...
assert (H3 : true = expr_eq e e0). unfold expr_eq. rewrite <-Heqb...
apply expr_eq_eq' in H3; subst...
Qed.

Lemma expr_rewriteC_sound e1 e2 l s :
  (e1 === e2) s -> expr_eqs_denote l s ->
  expr_eqs_denote (expr_rewriteC e1 e2 l) s.
Proof with simpl; auto.
intros H0; induction l... intros [H1 H2]; destruct a as [e e0].
spec IHl H2. remember (isEq (expr_cmp e1 e0)). destruct b...
split; auto.
apply var_eq_trans with (y:=e0)...
apply var_eq_trans with (y:=e1)...
do_comp expr_cspec e1 e0; try solve[simpl in Heqb; congruence].
split; auto.
Qed.

Lemma expr_merge_sound e1 e2 l s :
  expr_eqs_denote l s -> (e1 === e2) s ->
  expr_eqs_denote (expr_merge e1 e2 l) s.
Proof with simpl; auto.
induction l... unfold lookC, mergeC, id... if_tac... firstorder.
destruct a. intros [H1 H2]. unfold mergeC.
remember (isEq (expr_cmp (expr_get e1 ((e, e0) :: l))
                             (expr_get e2 ((e, e0) :: l)))) as b.
destruct b. simpl. intros H3. split; auto.
intros H3. unfold expr_eqs_denote. rewrite listd_cons.
split; auto.
assert (H4 : (e2 === expr_get e2 ((e, e0) :: l)) s).
  apply expr_get_sound. simpl. split; auto.
apply var_eq_trans with (y:=e2); auto.
rewrite listd_cons. split.
apply expr_get_sound. simpl. split; auto.
apply expr_rewriteC_sound.
assert (H4 : (e1 === expr_get e1 ((e, e0) :: l)) s).
  apply expr_get_sound... split...
apply var_eq_trans with (y:=e1). apply var_eq_sym; auto.
apply var_eq_trans with (y:=e2); auto. apply expr_get_sound.
split; auto.
simpl; split; auto.
Qed.

Lemma cclose_aux_sound l s :
  listd clause_denote inter TT l s -> expr_eqs_denote (cclose_aux l) s.
Proof with simpl; auto.
induction l...
destruct a... destruct gamma... destruct delta...
destruct p... destruct delta...
intros [H1 H2]. simpl in H1. spec H1. auto.
inversion H1 as [H3|H3]; [|inversion H3].
apply expr_merge_sound...
Qed.

Lemma cclose_sound l s :
  listd clause_denote inter TT l s -> listd clause_denote inter TT (cclose l) s.
Proof.
intros H1. unfold cclose. apply listd_map_pred
  with (f:=(fun p => match p with (e1, e2) => (e1 === e2) end)).
intros [a1 a2]; simpl; firstorder.
apply cclose_aux_sound; auto.
Qed.

End CCSound.


From Chapter10 Require Import sysf.
Require Import core fintype.
Import ScopedNotations.

Check scons_comp'.
Check scons_p_comp'.

(* TODO this is a substitution lemma not solved by asimpl. *)
Goal forall m n k l (s: tm l n) (sigma: fin m -> tm l n) (f: fin n -> tm l k) (x: fin (S m)),
    subst_tm var_ty f ((s .: sigma) x) = (subst_tm var_ty f s .: sigma >> subst_tm var_ty f) x.
Proof.
  intros *.
  (* asimpl_fext can solve it immediately. *)
  (* now asimpl_fext. *)
  (* I have to manually fold the function composition. Then asimpl can solve the goal.
     This is a disadvantage of the setoid asimpl
     It relies too much on a syntactic funcomp. *)
  change (subst_tm var_ty f ((s .: sigma) x)) with ((funcomp (subst_tm var_ty f) (s .: sigma)) x).
  revert x. apply pointwise_forall.
  now asimpl.
  (* TODO here I get the same problem as with scons_p
   * so the problem seems to be that we don't need any morphism.
   * the top is eq and scons follows directly after.
   * In other situations where the rewrite would first have to use a morphisms to traverse e.g a subst_tm, it works correctly.
   * So could we introduce a bogus morphism? *)
Qed.

Require Setoid Morphisms.
Inductive AsimplWrapper {A} := AW : A -> AsimplWrapper.

Goal forall m n k l (s: tm l n) (sigma: fin m -> tm l n) (f: fin n -> tm l k) (x: fin (S m)),
    AW (subst_tm var_ty f ((s .: sigma) x)) = AW ((subst_tm var_ty f s .: sigma >> subst_tm var_ty f) x).
Proof.
  intros *.
  (* yeah that works but it's ugly *)
  rewrite scons_comp'.
  reflexivity.
Qed.

Goal forall m n k l (s: tm l n) (sigma: fin m -> tm l n) (f: fin n -> tm l k) (x: fin (S m)),
    id (subst_tm var_ty f ((s .: sigma) x)) = id ((subst_tm var_ty f s .: sigma >> subst_tm var_ty f) x).
Proof.
  intros *.
  (* yeah that works but it's ugly *)
  rewrite scons_comp'.
  reflexivity.
Qed.

Ltac wrap_id := match goal with
                | [ |- ?x = ?y ] => change (x = y) with (id x = id y)
                | [ |- ?x ] => change x with (id x)
                end.

Goal forall m n k l (s: tm l n) (sigma: fin m -> tm l n) (f: fin n -> tm l k) (x: fin (S m)),
    (subst_tm var_ty f ((s .: sigma) x)) = ((subst_tm var_ty f s .: sigma >> subst_tm var_ty f) x).
Proof.
  intros *.
  (* yeah that works but it's ugly *)
  wrap_id.
  rewrite scons_comp'.
  reflexivity.
Qed.

Goal forall m n k k' l (f: fin m -> tm l k) (g: fin n -> tm l k) (h: fin k -> tm l k') (x: fin (m + n)),
    (subst_tm var_ty h (scons_p m f g x)) = scons_p m (f >> subst_tm var_ty h) (g >> subst_tm var_ty h) x.
Proof.
  intros *.
  rewrite scons_p_comp'.
  Restart.
  intros *.
  wrap_id.
  rewrite scons_p_comp'.
  reflexivity.
Qed.


Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.ZArith.ZArith.
Require Export Coq.Strings.String.
Require Export Coq.Logic.Classical.

Open Scope Z.

(* ################################################################# *)
(** * Hoare Logic *)

(** In the last lecture, we introduced a denotational semantics and a small
step semantics for a programming language with possible run time error and
nondeterministic behavior. This time, we complete this part of material by
a Hoare logic for it. *)

(* ================================================================= *)
(** ** The meaning of a Hoare triple *)

(** Originally, we use a Hoare triple [ {{ P }} c {{ Q }} ] to claim: if
command [c] is started in a state satisfying assertion [P], and if [c]
eventually terminates, then the ending state will satisfy assertion [Q]. Now,
since run-time-error and nondeterminism are taken into consideration, we
modify its meaning as follows:

      - If command [c] is started in a state satisfying assertion [P],
        its execution is always safe. In addition, if it terminates, the
        ending state should satisfy [Q].

There are two key points in this statement. (1) As long as the precondition
holds, the execution is run-time-error free, no matter what choices are made at
every nondeterministic point. (2) As long as the precondition holds and the
execution terminates, the ending state satisfies the postcondition, no matter
what choices are made at every nondeterministic point. *)

(* ================================================================= *)
(** ** Unchanged rules *)

(** It might be surprising that some Hoare logic proof rules do not need to be
changed even though we modify Hoare triple's meaning.

Axiom hoare_seq : forall (P Q R: Assertion) (c1 c2: com),
  {{P}} c1 {{Q}} ->
  {{Q}} c2 {{R}} ->
  {{P}} c1;;c2 {{R}}.

Axiom hoare_skip : forall P,
  {{P}} Skip {{P}}.

Axiom hoare_consequence : forall (P P' Q Q' : Assertion) c,
  P |-- P' ->
  {{P'}} c {{Q'}} ->
  Q' |-- Q ->
  {{P}} c {{Q}}.

We can check them one by one and see whether they are actually sound. *)

(* ================================================================= *)
(** ** Rules with evaluation *)

(** Assignment commands, if commands and while commands are all related to
expression evaluation. In the following proof rules, an assertion with form
[Safe(E)] says "evaluating [E] is safe".

Axiom hoare_if : forall P Q b c1 c2,
  {{ P AND {[b]} }} c1 {{ Q }} ->
  {{ P AND NOT {[b]} }} c2 {{ Q }} ->
  {{ P AND Safe(b) }} If b Then c1 Else c2 EndIf {{ Q }}.

Axiom hoare_while : forall P b c,
  P |-- Safe(b) ->
  {{ P AND {[b]} }} c {{P}} ->
  {{P}} While b Do c EndWhile {{ P AND NOT {[b]} }}.

Axiom hoare_asgn_fwd : forall P (X: var) E,
  {{ P AND Safe(E) }}
      X ::= E
  {{ EXISTS x, P [X |-> x] AND
               {[X]} == {[ E [X |-> x] ]} }}.

Axiom hoare_asgn_bwd : forall P (X: var) E,
  {{ P [ X |-> E] AND Safe(E) }} X ::= E {{ P }}.

Those additional conjuncts in preconditions are necessary because Hoare triples
ensure safe execution now. *)

(* ################################################################# *)
(** * Type Safe Language *)

(** Run time errors are harmful. Typical run-time-errors caused by careless
coding includes arithmetic error, dangling pointer, no initialized value etc.
For decades, computer scientist attempts to design programming languages that
is safe by syntax. Consider the following expressions. *)

Definition var: Type := nat.

Definition state: Type := var -> Z.

Open Scope Z.

Inductive mexp : Type :=
  | MNum (n : Z)
  | MId (X : var)
  | MPlus (a1 a2 : mexp)
  | MMinus (a1 a2 : mexp)
  | MMult (a1 a2 : mexp)
  | MTrue
  | MFalse
  | MEq (a1 a2 : mexp)
  | MLe (a1 a2 : mexp)
  | MNot (b : mexp)
  | MAnd (b1 b2 : mexp)
.

(** Here, boolean operators and integer operators are allowed to appear in one
single expression. For casting between integers and boolean values, we assume:

      - boolean values will be cast to 0 and 1 when necessary;

      - integers cannot be treated as booleans.

Based on these assumptions, we can formalize its denotational semantics as
follows: *)

Inductive val: Type :=
| Vint (n: Z)
| Vbool (b: bool).

Definition val2Z (v: val): Z :=
  match v with
  | Vint n => n
  | Vbool true => 1
  | Vbool false => 0
  end.

Inductive meval : mexp -> state -> val -> Prop :=
  | E_MNum n st:
      meval (MNum n) st (Vint n)
  | E_MId X st:
      meval (MId X) st (Vint (st X))
  | E_MPlus (e1 e2: mexp) (v1 v2: val) st
      (H1 : meval e1 st v1)
      (H2 : meval e2 st v2) :
      meval (MPlus e1 e2) st (Vint (val2Z v1 + val2Z v2))
  | E_MMinus (e1 e2: mexp) (v1 v2: val) st
      (H1 : meval e1 st v1)
      (H2 : meval e2 st v2) :
      meval (MMinus e1 e2) st (Vint (val2Z v1 - val2Z v2))
  | E_MMult (e1 e2: mexp) (v1 v2: val) st
      (H1 : meval e1 st v1)
      (H2 : meval e2 st v2) :
      meval (MMult e1 e2) st (Vint (val2Z v1 * val2Z v2))
  | E_MTrue st:
      meval MTrue st (Vbool true)
  | E_MFalse st:
      meval MFalse st (Vbool false)
  | E_MEqTrue (e1 e2: mexp) (v1 v2: val) st
      (H1 : meval e1 st v1)
      (H2 : meval e2 st v2)
      (H3 : val2Z v1 = val2Z v2) :
      meval (MEq e1 e2) st (Vbool true)
  | E_MEqFalse (e1 e2: mexp) (v1 v2: val) st
      (H1 : meval e1 st v1)
      (H2 : meval e2 st v2)
      (H3 : val2Z v1 <> val2Z v2) :
      meval (MEq e1 e2) st (Vbool false)
  | E_MLeTrue (e1 e2: mexp) (v1 v2: val) st
      (H1 : meval e1 st v1)
      (H2 : meval e2 st v2)
      (H3 : val2Z v1 < val2Z v2) :
      meval (MLe e1 e2) st (Vbool true)
  | E_MLeFalse (e1 e2: mexp) (v1 v2: val) st
      (H1 : meval e1 st v1)
      (H2 : meval e2 st v2)
      (H3 : val2Z v1 >= val2Z v2) :
      meval (MLe e1 e2) st (Vbool false)
  | E_MNot (e: mexp) (b: bool) st
      (H1 : meval e st (Vbool b)):
      meval (MNot e) st (Vbool (negb b))
  | E_MAnd (e1 e2: mexp) (b1 b2: bool) st
      (H1 : meval e1 st (Vbool b1))
      (H2 : meval e2 st (Vbool b2)):
      meval (MAnd e1 e2) st (Vbool (andb b1 b2))
      .

(** Also, we can define its small step semantics as follows. *)

Inductive mexp_halt: mexp -> Prop :=
  | MH_num : forall n, mexp_halt (MNum n)
  | MH_true: mexp_halt MTrue
  | MH_false: mexp_halt MFalse.

Inductive bool2Z_step: mexp -> mexp -> Prop :=
  | BZS_True: bool2Z_step MTrue (MNum 1)
  | BZS_False: bool2Z_step MFalse (MNum 0).

Inductive mstep : state -> mexp -> mexp -> Prop :=
  | MS_Id : forall st X,
      mstep st
        (MId X) (MNum (st X))

  | MS_Plus1 : forall st a1 a1' a2,
      mstep st
        a1 a1' ->
      mstep st
        (MPlus a1 a2) (MPlus a1' a2)
  | MS_Plus2 : forall st a1 a2 a2',
      mexp_halt a1 ->
      mstep st
        a2 a2' ->
      mstep st
        (MPlus a1 a2) (MPlus a1 a2')
  | MS_Plus3 : forall st a1 a1' a2,                    (* <-- new *)
      mexp_halt a2 ->
      bool2Z_step a1 a1' ->
      mstep st
        (MPlus a1 a2) (MPlus a1' a2)
  | MS_Plus4 : forall st n1 a2 a2',                    (* <-- new *)
      bool2Z_step a2 a2' ->
      mstep st
        (MPlus (MNum n1) a2) (MPlus (MNum n1) a2')
  | MS_Plus : forall st n1 n2,
      mstep st
        (MPlus (MNum n1) (MNum n2)) (MNum (n1 + n2))

  | MS_Minus1 : forall st a1 a1' a2,
      mstep st
        a1 a1' ->
      mstep st
        (MMinus a1 a2) (MMinus a1' a2)
  | MS_Minus2 : forall st a1 a2 a2',
      mexp_halt a1 ->
      mstep st
        a2 a2' ->
      mstep st
        (MMinus a1 a2) (MMinus a1 a2')
  | MS_Minus3 : forall st a1 a1' a2,                   (* <-- new *)
      mexp_halt a2 ->
      bool2Z_step a1 a1' ->
      mstep st
        (MMinus a1 a2) (MMinus a1' a2)
  | MS_Minus4 : forall st n1 a2 a2',                   (* <-- new *)
      bool2Z_step a2 a2' ->
      mstep st
        (MMinus (MNum n1) a2) (MMinus (MNum n1) a2')
  | MS_Minus : forall st n1 n2,
      mstep st
        (MMinus (MNum n1) (MNum n2)) (MNum (n1 - n2))

  | MS_Mult1 : forall st a1 a1' a2,
      mstep st
        a1 a1' ->
      mstep st
        (MMult a1 a2) (MMult a1' a2)
  | MS_Mult2 : forall st a1 a2 a2',
      mexp_halt a1 ->
      mstep st
        a2 a2' ->
      mstep st
        (MMult a1 a2) (MMult a1 a2')
  | MS_Mult3 : forall st a1 a1' a2,                    (* <-- new *)
      mexp_halt a2 ->
      bool2Z_step a1 a1' ->
      mstep st
        (MMult a1 a2) (MMult a1' a2)
  | MS_Mult4 : forall st n1 a2 a2',                    (* <-- new *)
      bool2Z_step a2 a2' ->
      mstep st
        (MMult (MNum n1) a2) (MMult (MNum n1) a2')
  | MS_Mult : forall st n1 n2,
      mstep st
        (MMult (MNum n1) (MNum n2)) (MNum (n1 * n2))

  | MS_Eq1 : forall st a1 a1' a2,
      mstep st
        a1 a1' ->
      mstep st
        (MEq a1 a2) (MEq a1' a2)
  | MS_Eq2 : forall st a1 a2 a2',
      mexp_halt a1 ->
      mstep st
        a2 a2' ->
      mstep st
        (MEq a1 a2) (MEq a1 a2')
  | MS_Eq3 : forall st a1 a1' a2,                    (* <-- new *)
      mexp_halt a2 ->
      bool2Z_step a1 a1' ->
      mstep st
        (MEq a1 a2) (MEq a1' a2)
  | MS_Eq4 : forall st n1 a2 a2',                    (* <-- new *)
      bool2Z_step a2 a2' ->
      mstep st
        (MEq (MNum n1) a2) (MEq (MNum n1) a2')
  | MS_Eq_True : forall st n1 n2,
      n1 = n2 ->
      mstep st
        (MEq (MNum n1) (MNum n2)) MTrue
  | MS_Eq_False : forall st n1 n2,
      n1 <> n2 ->
      mstep st
        (MEq (MNum n1) (MNum n2)) MFalse

  | MS_Le1 : forall st a1 a1' a2,
      mstep st
        a1 a1' ->
      mstep st
        (MLe a1 a2) (MLe a1' a2)
  | MS_Le2 : forall st a1 a2 a2',
      mexp_halt a1 ->
      mstep st
        a2 a2' ->
      mstep st
        (MLe a1 a2) (MLe a1 a2')
  | MS_Le3 : forall st a1 a1' a2,                    (* <-- new *)
      mexp_halt a2 ->
      bool2Z_step a1 a1' ->
      mstep st
        (MLe a1 a2) (MLe a1' a2)
  | MS_Le4 : forall st n1 a2 a2',                    (* <-- new *)
      bool2Z_step a2 a2' ->
      mstep st
        (MLe (MNum n1) a2) (MLe (MNum n1) a2')
  | MS_Le_True : forall st n1 n2,
      n1 <= n2 ->
      mstep st
        (MLe (MNum n1) (MNum n2)) MTrue
  | MS_Le_False : forall st n1 n2,
      n1 > n2 ->
      mstep st
        (MLe (MNum n1) (MNum n2)) MFalse

  | MS_NotStep : forall st b1 b1',
      mstep st
        b1 b1' ->
      mstep st
        (MNot b1) (MNot b1')
  | MS_NotTrue : forall st,
      mstep st
        (MNot MTrue) MFalse
  | MS_NotFalse : forall st,
      mstep st
        (MNot MFalse) MTrue

  | MS_AndStep : forall st b1 b1' b2,
      mstep st
        b1 b1' ->
      mstep st
       (MAnd b1 b2) (MAnd b1' b2)
  | MS_AndTrue : forall st b,
      mstep st
       (MAnd MTrue b) b
  | MS_AndFalse : forall st b,
      mstep st
       (MAnd MFalse b) MFalse.

(** Till now, everything is not very interesting. We have learnt how to define
denotational semantics and small step semantics of expression evaluation with
potential run time error.

But this time, we can do more. We can determine whether an expression can be
safely evaluated only by its syntax -- it does not depent on the program state.

The following function is a decision procedure. *)

Inductive type_check_result:Type :=
| TCR_int
| TCR_bool
| TCR_illegal.

Fixpoint type_check (m: mexp): type_check_result :=
  match m with
  | MNum _
  | MId _          =>

        TCR_int

  | MPlus m1 m2
  | MMinus m1 m2
  | MMult m1 m2    =>

        match type_check m1, type_check m2 with
        | TCR_illegal, _ => TCR_illegal
        | _, TCR_illegal => TCR_illegal
        | _, _           => TCR_int
        end

  | MTrue
  | MFalse         =>

        TCR_bool

  | MEq m1 m2
  | MLe m1 m2      =>

        match type_check m1, type_check m2 with
        | TCR_illegal, _ => TCR_illegal
        | _, TCR_illegal => TCR_illegal
        | _, _           => TCR_bool
        end

  | MNot m1        =>

        match type_check m1 with
        | TCR_bool => TCR_bool
        | _        => TCR_illegal
        end

  | MAnd m1 m2     =>

        match type_check m1, type_check m2 with
        | TCR_bool, TCR_bool => TCR_bool
        | _, _               => TCR_illegal
        end

  end
.

Declare Scope mexp.
Delimit Scope mexp with mexp.
Local Open Scope mexp.

Coercion MNum : Z >-> mexp.
Coercion MId : var >-> mexp.
Notation "x + y" := (MPlus x y) (at level 50, left associativity) : mexp.
Notation "x - y" := (MMinus x y) (at level 50, left associativity) : mexp.
Notation "x * y" := (MMult x y) (at level 40, left associativity) : mexp.
Notation "x <= y" := (MLe x y) (at level 70, no associativity) : mexp.
Notation "x == y" := (MEq x y) (at level 70, no associativity) : mexp.
Notation "x && y" := (MAnd x y) (at level 40, left associativity) : mexp.
Notation "'!' b" := (MNot b) (at level 39, right associativity) : mexp.
Notation "[ x ; .. ; y ]" := (@cons mexp x .. (@cons mexp y (@nil mexp)) ..).

Parameter P: var.
Parameter X: var.
Search nat.
Goal clos_refl_trans (mstep (fun x:var =>
    if eqb x P then 0
    else if eqb x X then 1 else 2))
    ((P == 0) && (X && (X + 1))) ( 1 && (X + 1)).

(** That means, we can check whether an [mexp] expression is legal in
compilation time. *)

(* ################################################################# *)
(** * Progress *)

(** How to justify that every [mexp] expression that passes [type_check] is
safe to evaluate? There are two important theorems: _progress_ and
_preservation_.

"Progress" says every [mexp] that passes [type_check] will either take a step
to evaluate or is already a constant. *)

Lemma mexp_halt_fact: forall m,
  mexp_halt m ->
  exists n, bool2Z_step m (MNum n) \/ m = MNum n.
Proof.
  intros.
  inversion H; subst.
  + exists n.
    right.
    reflexivity.
  + exists 1.
    left.
    apply BZS_True.
  + exists 0.
    left.
    apply BZS_False.
Qed.

Lemma mexp_halt_bool_fact: forall m,
  mexp_halt m ->
  type_check m = TCR_bool ->
  m = MTrue \/ m = MFalse.
Proof.
  intros.
  inversion H; subst.
  + simpl in H0.
    discriminate H0.
  + left.
    reflexivity.
  + right.
    reflexivity.
Qed.

Theorem Progress: forall m st,
  type_check m <> TCR_illegal ->
  (exists m', mstep st m m') \/ mexp_halt m.
Proof.
  intros.
  induction m.
  + right.
    apply MH_num.
  + left.
    exists (MNum (st X)).
    apply MS_Id.
  + assert (type_check m1 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H0 in H.
      apply H; reflexivity.
    }
    assert (type_check m2 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H1 in H.
      destruct (type_check m1); apply H; reflexivity.
    }
    specialize (IHm1 H0).
    specialize (IHm2 H1).
    clear H H0 H1.
    destruct IHm1 as [[m1' ?] |].
    {
      left.
      exists (MPlus m1' m2).
      apply MS_Plus1.
      exact H.
    }
    destruct IHm2 as [[m2' ?] |].
    {
      left.
      exists (MPlus m1 m2').
      apply MS_Plus2.
      - exact H.
      - exact H0.
    }
    apply mexp_halt_fact in H.
    destruct H as [n1 [? | ?]].
    {
      left.
      exists (MPlus (MNum n1) m2).
      apply MS_Plus3.
      - exact H0.
      - exact H.
    }
    subst m1.
    apply mexp_halt_fact in H0.
    destruct H0 as [n2 [? | ?]].
    {
      left.
      exists (MPlus (MNum n1) (MNum n2)).
      apply MS_Plus4.
      exact H.
    }
    {
      subst m2.
      left.
      exists (MNum (n1 + n2)).
      apply MS_Plus.
    }
  + assert (type_check m1 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H0 in H.
      apply H; reflexivity.
    }
    assert (type_check m2 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H1 in H.
      destruct (type_check m1); apply H; reflexivity.
    }
    specialize (IHm1 H0).
    specialize (IHm2 H1).
    clear H H0 H1.
    destruct IHm1 as [[m1' ?] |].
    {
      left.
      exists (MMinus m1' m2).
      apply MS_Minus1.
      exact H.
    }
    destruct IHm2 as [[m2' ?] |].
    {
      left.
      exists (MMinus m1 m2').
      apply MS_Minus2.
      - exact H.
      - exact H0.
    }
    apply mexp_halt_fact in H.
    destruct H as [n1 [? | ?]].
    {
      left.
      exists (MMinus (MNum n1) m2).
      apply MS_Minus3.
      - exact H0.
      - exact H.
    }
    subst m1.
    apply mexp_halt_fact in H0.
    destruct H0 as [n2 [? | ?]].
    {
      left.
      exists (MMinus (MNum n1) (MNum n2)).
      apply MS_Minus4.
      exact H.
    }
    {
      subst m2.
      left.
      exists (MNum (n1 - n2)).
      apply MS_Minus.
    }
  + assert (type_check m1 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H0 in H.
      apply H; reflexivity.
    }
    assert (type_check m2 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H1 in H.
      destruct (type_check m1); apply H; reflexivity.
    }
    specialize (IHm1 H0).
    specialize (IHm2 H1).
    clear H H0 H1.
    destruct IHm1 as [[m1' ?] |].
    {
      left.
      exists (MMult m1' m2).
      apply MS_Mult1.
      exact H.
    }
    destruct IHm2 as [[m2' ?] |].
    {
      left.
      exists (MMult m1 m2').
      apply MS_Mult2.
      - exact H.
      - exact H0.
    }
    apply mexp_halt_fact in H.
    destruct H as [n1 [? | ?]].
    {
      left.
      exists (MMult (MNum n1) m2).
      apply MS_Mult3.
      - exact H0.
      - exact H.
    }
    subst m1.
    apply mexp_halt_fact in H0.
    destruct H0 as [n2 [? | ?]].
    {
      left.
      exists (MMult (MNum n1) (MNum n2)).
      apply MS_Mult4.
      exact H.
    }
    {
      subst m2.
      left.
      exists (MNum (n1 * n2)).
      apply MS_Mult.
    }
  + right.
    apply MH_true.
  + right.
    apply MH_false.
  + assert (type_check m1 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H0 in H.
      apply H; reflexivity.
    }
    assert (type_check m2 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H1 in H.
      destruct (type_check m1); apply H; reflexivity.
    }
    specialize (IHm1 H0).
    specialize (IHm2 H1).
    clear H H0 H1.
    destruct IHm1 as [[m1' ?] |].
    {
      left.
      exists (MEq m1' m2).
      apply MS_Eq1.
      exact H.
    }
    destruct IHm2 as [[m2' ?] |].
    {
      left.
      exists (MEq m1 m2').
      apply MS_Eq2.
      - exact H.
      - exact H0.
    }
    apply mexp_halt_fact in H.
    destruct H as [n1 [? | ?]].
    {
      left.
      exists (MEq (MNum n1) m2).
      apply MS_Eq3.
      - exact H0.
      - exact H.
    }
    subst m1.
    apply mexp_halt_fact in H0.
    destruct H0 as [n2 [? | ?]].
    {
      left.
      exists (MEq (MNum n1) (MNum n2)).
      apply MS_Eq4.
      exact H.
    }
    {
      subst m2.
      left.
      destruct (Z.eq_dec n1 n2).
      - exists MTrue.
        apply MS_Eq_True.
        exact e.
      - exists MFalse.
        apply MS_Eq_False.
        exact n.
    }
  + assert (type_check m1 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H0 in H.
      apply H; reflexivity.
    }
    assert (type_check m2 <> TCR_illegal).
    {
      simpl in H.
      intro.
      rewrite H1 in H.
      destruct (type_check m1); apply H; reflexivity.
    }
    specialize (IHm1 H0).
    specialize (IHm2 H1).
    clear H H0 H1.
    destruct IHm1 as [[m1' ?] |].
    {
      left.
      exists (MLe m1' m2).
      apply MS_Le1.
      exact H.
    }
    destruct IHm2 as [[m2' ?] |].
    {
      left.
      exists (MLe m1 m2').
      apply MS_Le2.
      - exact H.
      - exact H0.
    }
    apply mexp_halt_fact in H.
    destruct H as [n1 [? | ?]].
    {
      left.
      exists (MLe (MNum n1) m2).
      apply MS_Le3.
      - exact H0.
      - exact H.
    }
    subst m1.
    apply mexp_halt_fact in H0.
    destruct H0 as [n2 [? | ?]].
    {
      left.
      exists (MLe (MNum n1) (MNum n2)).
      apply MS_Le4.
      exact H.
    }
    {
      subst m2.
      left.
      destruct (Z_le_gt_dec n1 n2).
      - exists MTrue.
        apply MS_Le_True.
        exact l.
      - exists MFalse.
        apply MS_Le_False.
        exact g.
    }
  + assert (type_check m = TCR_bool).
    {
      simpl in H.
      destruct (type_check m).
      - exfalso; apply H; reflexivity.
      - reflexivity.
      - exfalso; apply H; reflexivity.
    }
    assert (type_check m <> TCR_illegal).
    {
      rewrite H0; intro.
      discriminate H1.
    }
    specialize (IHm H1).
    clear H H1.
    destruct IHm as [[m' ?] | ?].
    {
      left.
      exists (MNot m').
      apply MS_NotStep.
      exact H.
    }
    pose proof mexp_halt_bool_fact _  H H0.
    destruct H1; subst.
    {
      left.
      exists MFalse.
      apply MS_NotTrue.
    }
    {
      left.
      exists MTrue.
      apply MS_NotFalse.
    }
  + assert (type_check m1 = TCR_bool).
    {
      simpl in H.
      destruct (type_check m1).
      - exfalso; apply H; reflexivity.
      - reflexivity.
      - exfalso; apply H; reflexivity.
    }
    assert (type_check m1 <> TCR_illegal).
    {
      rewrite H0; intro.
      discriminate H1.
    }
    specialize (IHm1 H1).
    clear H H1 IHm2.
    destruct IHm1 as [[m1' ?] | ?].
    {
      left.
      exists (MAnd m1' m2).
      apply MS_AndStep.
      exact H.
    }
    pose proof mexp_halt_bool_fact _  H H0.
    destruct H1; subst.
    {
      left.
      exists m2.
      apply MS_AndTrue.
    }
    {
      left.
      exists MFalse.
      apply MS_AndFalse.
    }
Qed.

(* ################################################################# *)
(** * Preservation *)

(** "Preservation" says: if an [mexp] type checks then it will only step to
type-checked another expression. *)

Lemma bool2Z_step_fact: forall m1 m2,
  bool2Z_step m1 m2 ->
  type_check m1 = TCR_bool /\ type_check m2 = TCR_int.
Proof.
  intros.
  inversion H; subst.
  + split; reflexivity.
  + split; reflexivity.
Qed.

Lemma Preservation_aux: forall st m1 m2,
  mstep st m1 m2 ->
  type_check m1 <> TCR_illegal ->
  type_check m1 = type_check m2.
Proof.
  intros.
  rename H0 into TC.
  induction H.
  + simpl in TC.
    simpl.
    reflexivity.
  + assert (type_check a1 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H0 in TC.
      apply TC; reflexivity.
    }
    specialize (IHmstep H0).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + assert (type_check a2 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H1 in TC.
      destruct (type_check a1); apply TC; reflexivity.
    }
    specialize (IHmstep H1).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H0.
    destruct H0.
    rewrite H0, H1.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H.
    destruct H.
    rewrite H, H0.
    reflexivity.
  + simpl.
    reflexivity.
  + assert (type_check a1 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H0 in TC.
      apply TC; reflexivity.
    }
    specialize (IHmstep H0).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + assert (type_check a2 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H1 in TC.
      destruct (type_check a1); apply TC; reflexivity.
    }
    specialize (IHmstep H1).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H0.
    destruct H0.
    rewrite H0, H1.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H.
    destruct H.
    rewrite H, H0.
    reflexivity.
  + simpl.
    reflexivity.
  + assert (type_check a1 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H0 in TC.
      apply TC; reflexivity.
    }
    specialize (IHmstep H0).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + assert (type_check a2 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H1 in TC.
      destruct (type_check a1); apply TC; reflexivity.
    }
    specialize (IHmstep H1).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H0.
    destruct H0.
    rewrite H0, H1.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H.
    destruct H.
    rewrite H, H0.
    reflexivity.
  + simpl.
    reflexivity.
  + assert (type_check a1 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H0 in TC.
      apply TC; reflexivity.
    }
    specialize (IHmstep H0).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + assert (type_check a2 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H1 in TC.
      destruct (type_check a1); apply TC; reflexivity.
    }
    specialize (IHmstep H1).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H0.
    destruct H0.
    rewrite H0, H1.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H.
    destruct H.
    rewrite H, H0.
    reflexivity.
  + simpl.
    reflexivity.
  + simpl.
    reflexivity.
  + assert (type_check a1 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H0 in TC.
      apply TC; reflexivity.
    }
    specialize (IHmstep H0).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + assert (type_check a2 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H1 in TC.
      destruct (type_check a1); apply TC; reflexivity.
    }
    specialize (IHmstep H1).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H0.
    destruct H0.
    rewrite H0, H1.
    reflexivity.
  + simpl.
    apply bool2Z_step_fact in H.
    destruct H.
    rewrite H, H0.
    reflexivity.
  + simpl.
    reflexivity.
  + simpl.
    reflexivity.
  + assert (type_check b1 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H0 in TC.
      apply TC; reflexivity.
    }
    specialize (IHmstep H0).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + simpl.
    reflexivity.
  + simpl.
    reflexivity.
  + assert (type_check b1 <> TCR_illegal).
    {
      simpl in TC.
      intro.
      rewrite H0 in TC.
      apply TC; reflexivity.
    }
    specialize (IHmstep H0).
    simpl.
    rewrite IHmstep.
    reflexivity.
  + simpl.
    simpl in TC.
    destruct (type_check b).
    - exfalso. apply TC. reflexivity.
    - reflexivity.
    - reflexivity.
  + simpl.
    simpl in TC.
    destruct (type_check b).
    - exfalso. apply TC. reflexivity.
    - reflexivity.
    - exfalso. apply TC. reflexivity.
Qed.

Theorem Preservation: forall st m1 m2,
  mstep st m1 m2 ->
  type_check m1 <> TCR_illegal ->
  type_check m2 <> TCR_illegal.
Proof.
  intros.
  pose proof Preservation_aux _ _ _ H H0.
  rewrite <- H1.
  exact H0.
Qed.

(* Tue May 19 13:37:57 CST 2020 *)


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Arith.
Require Import Compare.
Require Export Nbinomial.
Require Export Ndiv.
Require Export Npow.
Require Export Nfinite_sum.
Open Scope nat_scope.

(** * Definition of a newton sum *)
Definition Nnewton_sum n a b : nat :=
  Nfinite_sum_0_n n (fun k => (Nbinomial n k) * (a ^ k) * (b ^ (n - k))).

(** * Newton sum theorem *)
Theorem Nnewton : forall n a b,
  (a + b) ^ n = Nnewton_sum n a b.
Proof.
(* the coq proof is highly technical whereas the mathematical proof is stupid *)
induction n.
compute.
reflexivity.
intros.
rewrite Npower_succ.
rewrite mult_plus_distr_r.
rewrite IHn.
unfold Nnewton_sum.
rewrite Nfinite_sum_mult_distrib.
assert (forall k, a * (Nbinomial n k * a ^ k * b ^ (n - k))=
  (Nbinomial n k * a ^ (S k) * b ^ (n - k))).
intro.
assert (a * (Nbinomial n k * a ^ k * b ^ (n - k)) =
Nbinomial n k * (a * a ^ k) * b ^ (n - k)).
ring.
rewrite H.
rewrite Npower_succ.
reflexivity.
assert (Nfinite_sum_0_n n (fun k : nat => a * (Nbinomial n k * a ^ k * b ^ (n - k))) =
  Nfinite_sum_0_n n (fun k : nat => (Nbinomial n k * a ^(S k) * b ^ (n - k)))).
apply Nfinite_sum_eq_compat.
exact H.
rewrite H0. clear H0.
rewrite Nfinite_sum_mult_distrib.
assert (forall k:nat, b * (Nbinomial n k * a ^ k * b ^ (n - k)) =
  Nbinomial n k * a ^ k * b ^ (S (n - k))).
intro.
assert (b * (Nbinomial n k * a ^ k * b ^ (n - k)) =
Nbinomial n k * (a ^ k) * (b * b ^ (n - k))).
ring.
rewrite H0.
rewrite Npower_succ.
reflexivity.
assert (Nfinite_sum_0_n n (fun k : nat => b * (Nbinomial n k * a ^ k * b ^ (n - k))) =
  Nfinite_sum_0_n n (fun k : nat => (Nbinomial n k * a ^k)* b ^ (S (n - k)))).
apply Nfinite_sum_eq_compat.
exact H0.
rewrite H1.
clear H1. clear H0. clear H. clear IHn.

rewrite Nfinite_sum_split_lower.
simpl.
rewrite plus_0_r.
assert (Nfinite_sum_0_n n
  (fun k : nat => Nbinomial (S n) (S k) * a ^ S k * b ^ (n - k)) =
  Nfinite_sum_0_n n
  (fun k : nat => Nbinomial n (S k) * a ^ S k * b ^ (n - k) +
    Nbinomial n k * a ^ S k * b ^ (n - k))).
apply Nfinite_sum_subtle_eq_compat.
intros.
rewrite <- Nbinomial_pascal.
ring.
exact H.
rewrite H. clear H.
rewrite <- Nfinite_sum_plus_compat.

assert (b ^ S n +
  Nfinite_sum_0_n n (fun k : nat => Nbinomial n (S k) * a ^ S k * b ^ (n - k)) =
  Nfinite_sum_0_n (S n) (fun k : nat => Nbinomial n k * a ^ k * b ^ (S (n - k)))).
rewrite Nfinite_sum_split_lower.
rewrite Nbinomial_0.
simpl.
rewrite <- minus_n_O.
rewrite plus_0_r.
assert (Nfinite_sum_0_n n
  (fun k : nat => Nbinomial n (S k) * a ^ S k * b ^ (n - k)) =
  Nfinite_sum_0_n n
  (fun k : nat => Nbinomial n (S k) * a ^ S k * b ^ S (n - S k))).
apply Nfinite_sum_subtle_eq_compat.
intros.
apply le_le_S_eq in H.
destruct H.
intros.
assert (S(n-S k)=n-k).
induction n.
apply le_Sn_O in H.
contradiction.
apply le_le_S_eq in H.
destruct H.
rewrite <- minus_Sn_m.
rewrite IHn.
apply  minus_Sn_m.
apply le_S_n.
auto with arith.
apply le_S_n.
auto with arith.
apply le_S_n.
auto with arith.
apply eq_eq_nat in H.
unfold eq_nat in H.
apply eq_nat_eq in H.
rewrite H.
rewrite minus_diag.
rewrite <- minus_Sn_m.
rewrite minus_diag.
reflexivity.
auto with arith.
rewrite H0.
reflexivity.
rewrite H.
rewrite Nbinomial_outside.
simpl.
reflexivity.
auto with arith.
rewrite H. clear H.
reflexivity.

assert (b ^ S n +
 (Nfinite_sum_0_n n (fun k : nat => Nbinomial n (S k) * a ^ S k * b ^ (n - k)) +
  Nfinite_sum_0_n n (fun k : nat => Nbinomial n k * a ^ S k * b ^ (n - k)))
  =
  (b ^ S n + Nfinite_sum_0_n n (fun k : nat => Nbinomial n (S k) * a ^ S k * b ^ (n - k)) +
  (Nfinite_sum_0_n n (fun k : nat => Nbinomial n k * a ^ S k * b ^ (n - k))))).
rewrite plus_assoc.
auto with arith.
rewrite H0. clear H0.
rewrite H. clear H.

assert (Nfinite_sum_0_n n (fun k : nat => Nbinomial n k * a ^ k * b ^ S (n - k)) =
  Nfinite_sum_0_n (S n) (fun k : nat => Nbinomial n k * a ^ k * b ^ S (n - k))).
rewrite Nfinite_sum_split_upper.
rewrite Nbinomial_outside.
simpl.
auto with arith.
auto with arith.
rewrite H.
auto with arith.
Qed.


(* This file is developed by Qinxiang Cao, Aquinas Hobor and Shengyi Wang in 2015. *)

Require Export veric.base.
Require Import veric.tycontext.
Require Import veric.expr2.

Lemma range_overlap_spec: forall l1 n1 l2 n2,
  n1 > 0 ->
  n2 > 0 ->
  (range_overlap l1 n1 l2 n2 <-> adr_range l1 n1 l2 \/ adr_range l2 n2 l1).
Proof.
  intros.
  unfold range_overlap, adr_range.
  destruct l1, l2.
  split; intros.
  + destruct H1 as [[? ?] [[? ?] [? ?]]].
    subst.
    destruct (zle z z0); [left | right].
    - split; auto.
      omega.
    - split; auto.
      omega.
  + destruct H1 as [[? ?] | [? ?]].
    - exists (b0, z0). repeat split; auto; omega.
    - exists (b, z). repeat split; auto; omega.
Qed.

Lemma range_overlap_comm: forall l1 n1 l2 n2, range_overlap l1 n1 l2 n2 -> range_overlap l2 n2 l1 n1.
Proof.
  unfold range_overlap.
  intros.
  destruct H as [l ?].
  exists l.
  tauto.
Qed.

Lemma range_overlap_non_zero: forall l1 n1 l2 n2, range_overlap l1 n1 l2 n2 -> n1 > 0 /\ n2 > 0.
Proof.
  unfold range_overlap.
  intros.
  destruct H as [l [? ?]].
  apply adr_range_non_zero in H.
  apply adr_range_non_zero in H0.
  auto.
Qed.

Definition pointer_range_overlap p n p' n' :=
  exists l l', val2adr p l /\ val2adr p' l' /\ range_overlap l n l' n'.

Lemma pointer_range_overlap_dec: forall p1 n1 p2 n2, {pointer_range_overlap p1 n1 p2 n2} + {~ pointer_range_overlap p1 n1 p2 n2}.
Proof.
  unfold pointer_range_overlap.
  intros.
  destruct p1;
  try solve
   [right;
    intros [[? ?] [[? ?] [HH [_ _]]]];
    inversion HH].
  destruct p2;
  try solve
   [right;
    intros [[? ?] [[? ?] [_ [HH _]]]];
    inversion HH].
  destruct (zlt 0 n1); [| right; intros [[? ?] [[? ?] [_ [_ HH]]]]; apply range_overlap_non_zero in HH; omega].
  destruct (zlt 0 n2); [| right; intros [[? ?] [[? ?] [_ [_ HH]]]]; apply range_overlap_non_zero in HH; omega].
  destruct (Clight_lemmas.block_eq_dec b b0).
  + subst b0.
    unfold val2adr.
    forget (Int.unsigned i) as i1;
    forget (Int.unsigned i0) as i2;
    clear i i0.
    destruct (range_dec i1 i2 (i1 + n1)); [| destruct (range_dec i2 i1 (i2 + n2))].
    - left.
      exists (b, i1), (b, i2); repeat split; auto.
      apply range_overlap_spec; try omega.
      left; simpl; auto.
    - left.
      exists (b, i1), (b, i2); repeat split; auto.
      apply range_overlap_spec; try omega.
      right; simpl; auto.
    - right.
      intros [[? ?] [[? ?] [? [? HH]]]].
      inversion H; inversion H0; subst.
      apply range_overlap_spec in HH; [| omega | omega].
      simpl in HH; omega.
  + right.
    intros [[? ?] [[? ?] [? [? HH]]]].
    simpl in H, H0.
    inversion H; inversion H0; subst.
    apply range_overlap_spec in HH; [| omega | omega].
    simpl in HH.
    pose proof @eq_sym _ b0 b.
    tauto.
Qed.

Lemma pointer_range_overlap_refl: forall p n1 n2,
  isptr p ->
  n1 > 0 ->
  n2 > 0 ->
  pointer_range_overlap p n1 p n2.
Proof.
  intros.
  destruct p; try inversion H.
  exists (b, Int.unsigned i), (b, Int.unsigned i).
  repeat split; auto.
  apply range_overlap_spec; auto.
  left.
  simpl.
  split; auto; omega.
Qed.

Lemma pointer_range_overlap_comm: forall p1 n1 p2 n2,
  pointer_range_overlap p1 n1 p2 n2 <->
  pointer_range_overlap p2 n2 p1 n1.
Proof.
  cut (forall p1 n1 p2 n2,
         pointer_range_overlap p1 n1 p2 n2 ->
         pointer_range_overlap p2 n2 p1 n1).
  Focus 1. {
    intros.
    pose proof H p1 n1 p2 n2.
    pose proof H p2 n2 p1 n1.
    tauto.
  } Unfocus.
  unfold pointer_range_overlap.
  intros.
  destruct H as [l [l' [? [? ?]]]].
  exists l', l.
  repeat split; auto.
  apply range_overlap_comm.
  auto.
Qed.

Lemma pointer_range_overlap_non_zero: forall p1 n1 p2 n2,
  pointer_range_overlap p1 n1 p2 n2 -> n1 > 0 /\ n2 > 0.
Proof.
  intros.
  destruct H as [? [? [? [? ?]]]].
  eapply range_overlap_non_zero; eauto.
Qed.

Lemma pointer_range_overlap_isptr: forall p1 n1 p2 n2,
  pointer_range_overlap p1 n1 p2 n2 -> isptr p1 /\ isptr p2.
Proof.
  intros.
  destruct H as [? [? [? [? ?]]]].
  destruct p1, p2; try solve [inversion H | inversion H0].
  simpl; auto.
Qed.