Definition injective[A B: Type](f: A -> B): Prop :=
  forall x1 x2, f x1 = f x2 -> x1 = x2.
Existing Class injective.

(* we don't really need the injectivity proofs, because we're not proving that our
   proof steps are safe, so we can skip proving injectivity if we want *)
Class fake_injective[A B: Type](f: A -> B): Prop := {}.

#[export] Instance discard_injectivity_proof[A B: Type](f: A -> B)(i: injective f):
  fake_injective f. Qed.

Lemma f_equal_vary_2ndlast[A B C: Type](f: A -> B -> C)(x1 x2: A)(y: B)(H: x1 = x2):
  f x1 y = f x2 y.
Proof. intros. subst. reflexivity. Qed.

Require Import Coq.Program.Basics.

Ltac safe_f_equal_step :=
  lazymatch goal with
  | |- ?f ?y1 = ?f ?y2 =>
      let _inj := constr:(_ : fake_injective f) in
      eapply (f_equal f)
  | |- ?f ?x1 ?y = ?f ?x2 ?y =>
      let _inj := constr:(_ : fake_injective (flip f y)) in
      eapply (f_equal_vary_2ndlast f x1 x2 y)
  end.

Ltac safe_f_equal := repeat safe_f_equal_step.

Require Import Coq.Lists.List.
Require Import Coq.Program.Basics.

(* Real instances with easy proofs: *)

#[export] Instance list_app_inj_r[A: Type](xs: list A): injective (List.app xs).
Proof. unfold injective. apply List.app_inv_head. Qed.

#[export] Instance list_app_inj_l[A: Type](xs: list A): injective (flip (@List.app A) xs).
Proof. unfold injective, flip. apply List.app_inv_tail. Qed.

(* Fake instances whose proofs would/might be harder, or even false: *)

Require Import Coq.ZArith.ZArith.
Require Import coqutil.Word.Bitwidth coqutil.Word.Interface coqutil.Map.Interface.
Require Import bedrock2.SepLib.

Section WithMem.
  Context {width: Z}{BW: Bitwidth width}{word: word.word width}
    {mem: map.map word Byte.byte}.

  (* Note: doesn't hold if elem doesn't fully determine its value *)
  #[export] Instance array_val_inj[E: Type]
    (elem: E -> word -> mem -> Prop)(sz: Z)(n: Z)(p: word):
    fake_injective (Basics.flip (array (elemSize := sz) elem n) p). Qed.

  (* Note: doesn't hold if vs is empty, or if elem is emp *)
  #[export] Instance array_addr_inj[E: Type]
    (elem: E -> word -> mem -> Prop)(sz: Z)(n: Z)(vs: list E):
    fake_injective (array (elemSize := sz) elem n vs). Qed.

  Section Tests.
    Goal forall (l1 l2 l3a l3b l4: list Z) n a,
        l3a = l3b ->
        array (uint 16) n (l1 ++ l2 ++ l3a ++ l4) a =
        array (uint 16) n (l1 ++ l2 ++ l3b ++ l4) a.
    Proof. intros. f_equal. safe_f_equal. assumption. Abort.

    Goal forall (a b: nat),
        a + b = b + a.
    Proof. intros. safe_f_equal. apply Nat.add_comm. Abort.
  End Tests.
End WithMem.


Require Import VST.msl.Extensionality.
Require Import VST.msl.sepalg.
Require Import VST.msl.ageable.
Require Import VST.msl.age_sepalg.
Require Import VST.msl.base.
Require Import VST.msl.predicates_hered.
Require Import VST.msl.predicates_sl.
Require Import VST.msl.subtypes.
Require Import VST.msl.subtypes_sl.
Require Import VST.msl.predicates_rec.

(* Given a separation algebra on type [A], we can make a separation logic
   with predicates of type  [pred A].  But the type   [B -> pred A] is also
   a natural separation logic.  These typeclasses automagically extend
   the separation-logic operators to the pointwise-function case.
   At present, this is just the beginnings of an experiment with this idea;
   don't expect it to work well enough to be useful.
   Andrew Appel, August 2012, following an approach suggested by Rob Dockins
*)

Class StarOp A := {  starOp : A -> A -> A }.

Instance baseStarOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{AgeA: Age_alg A}
 : StarOp (pred A) := {| starOp := sepcon |}.

Instance funStarOp (B: Type)(A: Type)(StarA: StarOp A) : StarOp (B -> A) :=
   {| starOp := fun (P Q : B -> A) (b : B) =>  starOp (P b) (Q b) |}.

Set Warnings "-notation-overridden".
Notation "P '*' Q" := (starOp P Q) : pred.
Set Warnings "notation-overridden".
(* Opaque baseStarOp *)

Class DerivesOp A := {  derivesOp : A -> A -> Prop }.

Instance baseDerivesOp {A}{agA: ageable A}
 : DerivesOp (pred A) := {| derivesOp := @derives A agA|}.

Instance funDerivesOp (B: Type)(A: Type)(DerivesA: DerivesOp A) : DerivesOp (B -> A)
 := {| derivesOp := fun (P Q : B -> A)  => forall b, derivesOp (P b) (Q b) |}.
Set Warnings "-notation-overridden".
Declare Scope logic_derives.
Notation "P '|--' Q" := (derivesOp P%pred Q%pred) : logic_derives.
Set Warnings "notation-overridden".
Open Scope logic_derives.
(* Opaque baseDerivesOp. *)

Class WandOp A := {  wandOp : A -> A -> A }.

Instance baseWandOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{AgeA: Age_alg A}
 : WandOp (pred A) := {| wandOp := wand |}.

Instance funWandOp (B: Type)(A: Type)(WandA: WandOp A) : WandOp (B -> A) :=
   {| wandOp := fun (P Q : B -> A) (b : B) =>  wandOp (P b) (Q b) |}.

Set Warnings "-notation-overridden".
Notation "P '-*' Q" := (wandOp P Q) : pred.
Set Warnings "notation-overridden".
(* Opaque baseWandOp *)

Class EmpOp A := { Emp: A}.

Instance baseEmpOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AgeA: Age_alg A}
  : EmpOp (pred A) := {| Emp := @emp A JA PA SA agA AgeA |}.

Instance funEmpOp  (B: Type)(A: Type)(EmpA: EmpOp A) : EmpOp (B -> A) :=
   {| Emp := fun (b : B) =>  Emp  |}.

Section Test.
Variable environ: Type.
Variables (rmap : Type)
      (Join_rmap: Join rmap) (Perm_rmap: @Perm_alg rmap Join_rmap)
      (Sep_rmap: @Sep_alg rmap Join_rmap)
      (Canc_rmap: @Canc_alg rmap Join_rmap)
      (Disj_rmap: @Disj_alg rmap Join_rmap)
      (ag_rmap: ageable rmap)
      (Age_rmap: @Age_alg rmap Join_rmap ag_rmap).
Existing Instance  Join_rmap.
Existing Instance  Perm_rmap.
Existing Instance  Sep_rmap.
Existing Instance  Canc_rmap.
Existing Instance  Disj_rmap.
Existing Instance  ag_rmap.
Existing Instance  Age_rmap.

Lemma test1: forall (P : environ -> pred rmap) (Q: pred rmap),
   P * Emp |-- P.
Proof.
 intros.
  intro. simpl; rewrite sepcon_emp.
auto.
Qed.

End Test.


Require Export SystemFR.ReducibilitySubtype.
Require Export SystemFR.TermListReducible.
Require Export SystemFR.SubstitutionErase.
Require Export SystemFR.ScalaDepSugar.

Opaque reducible_values.
Opaque T_singleton.

Lemma ncons: forall ρ T1 T2 T1' T2',
  valid_interpretation ρ ->
  is_erased_type T2 ->
  is_erased_type T2' ->
  wf T2 0 ->
  wf T2' 0 ->
  [ ρ ⊨ T1 = T1' ] ->
  [ ρ ⊨ T2 = T2' ] ->
  [ ρ ⊨ Cons T1 T2 = Cons T1' T2' ].
Proof.
  intros; unfold equivalent_types, Cons;
    repeat step || simp_red_top_level_goal || simp_red_top_level_hyp;
    t_closer.

  - exists a; repeat step || simp_red_top_level_goal; eauto using equivalent_types_reducible_values.
    exists a0; repeat step || open_none; eauto using equivalent_types_reducible_values.
  - exists a; repeat step || simp_red_top_level_goal; eauto using equivalent_types_reducible_values_back.
    exists a0; repeat step || open_none; eauto using equivalent_types_reducible_values_back.
Qed.

Lemma substitute_Cons:
  forall T1 T2 l tag,
    psubstitute (Cons T1 T2) l tag = Cons (psubstitute T1 l tag) (psubstitute T2 l tag).
Proof.
  unfold Cons; repeat step.
Qed.

Opaque Cons.

Lemma open_ncons_helper: forall Θ Γ T1 T2 T1' T2',
  is_erased_type T2 ->
  is_erased_type T2' ->
  wf T2 0 ->
  wf T2' 0 ->
  [ Θ; Γ ⊨ T1 = T1' ] ->
  [ Θ; Γ ⊨ T2 = T2' ] ->
  [ Θ; Γ ⊨ Cons T1 T2 = Cons T1' T2' ].
Proof.
  unfold open_equivalent_types; repeat step || rewrite substitute_Cons || apply ncons;
    t_closer.
Qed.

Lemma open_ncons: forall Γ T1 T2 T1' T2',
  is_erased_type T2 ->
  is_erased_type T2' ->
  wf T2 0 ->
  wf T2' 0 ->
  [ Γ ⊫ T1 = T1' ] ->
  [ Γ ⊫ T2 = T2' ] ->
  [ Γ ⊫ Cons T1 T2 = Cons T1' T2' ].
Proof.
  eauto using open_ncons_helper.
Qed.


(** Copyright (c) 2018 by Swirlds, Inc.
   Implemented by Karl Crary.
*)

Require Import Decide.

Require Import Tact.
Require Import Relation.
Require Import Majority.
Require Import HashgraphFacts.

(** y sees x *)
Definition sees (x y : event) : Prop :=
  x @= y
  /\ ~ exists z z', z @= y /\ z' @= y /\ fork z z' /\ creator z = creator x.

(** y strongly sees x *)
Definition stsees (x y : event) : Prop :=
  exists w,
    w @= y
    /\ supermajority
         stake
         (fun a => exists z, creator z = a /\ sees x z /\ sees z w)
         every.

Lemma sees_impl_ancestor :
  forall x y, sees x y -> x @= y.
Proof.
intros x y Hsee.
destruct Hsee; auto.
Qed.

(** Lemma 5.12 *)
Lemma strongly_seeing :
  forall W x y v w,
    member W v
    -> member W w
    -> fork x y
    -> stsees x v
    -> stsees y w
    -> False.
Proof.
intros W x y v w Wv Ww Hfork Hssx Hssy.
destruct Hssx as (v' & Hv & Hmajx).
destruct Hssy as (w' & Hw & Hmajy).
so (supermajority_intersect_3 _#6 eq_peer_decide supermajority_honest Hmajx Hmajy) as (a & Hhonest & Hseesx & Hseesy).
destruct Hseesx as (q & Hcrq & Hxq & Hqv').
destruct Hseesy as (r & Hcrr & Hyr & Hqw').
assert (q @= r \/ r @= q) as Hordered.
  {
  so (ancestor_decide q r) as [? | Hnqr]; auto.
  so (ancestor_decide r q) as [? | Hnrq]; auto.
  exfalso.
  so (world_forks W _ Hhonest) as H.
  destruct H.
  exists q, r.
  do2 3 split; auto.
    {
    apply (world_closed _ _ v); auto.
    eapply star_trans; eauto.
    apply sees_impl_ancestor; auto.
    }

    {
    apply (world_closed _ _ w); auto.
    eapply star_trans; eauto.
    apply sees_impl_ancestor; auto.
    }

    {
    do2 2 split.
      {
      subst a; auto.
      }

      {
      contradict Hnqr.
      apply self_ancestor_impl_ancestor; auto.
      }

      {
      contradict Hnrq.
      apply self_ancestor_impl_ancestor; auto.
      }
    }
  }
cut (forall x y q r,
       fork x y
       -> sees x q
       -> sees y r
       -> q @= r
       -> False).
  {
  intros H.
  destruct Hordered; [eapply (H x) | eapply (H y)]; eauto using fork_symm.
  }
repeat (match goal with H : _ |- _ => clear H end).
intros x y q r Hfork Hxq Hyr Hqr.
destruct Hyr as (Hyr & Hnofork).
destruct Hnofork.
exists x, y.
do2 3 split; auto using fork_creator.
destruct Hxq as (Hxq & _).
eapply star_trans; eauto.
Qed.

Lemma stsees_impl_strict_ancestor :
  forall x y, stsees x y -> x @ y.
Proof.
intros x y Hss.
destruct Hss as (w & Hwy & Hmaj).
so (distinct_peer _ (creator w) (supermajority_impl_majority _ _ _ _ Hmaj)) as (b & Hb & Hneq).
destruct Hb as (z & <- & Hxz & Hzw).
eapply plus_star_trans; eauto.
apply star_neq_plus.
  {
  eapply star_trans; apply sees_impl_ancestor; eauto.
  }
intro.
subst w.
apply (well_founded_impl_irrefl _ _ strict_ancestor_well_founded x).
apply (plus_trans _#3 z).
  {
  apply star_neq_plus.
    { apply sees_impl_ancestor; auto. }

    {
    contradict Hneq.
    f_equal; auto.
    }
  }

  {
  apply star_neq_plus.
    { apply sees_impl_ancestor; auto. }

    {
    contradict Hneq.
    f_equal; auto.
    }
  }
Qed.

Lemma stsees_impl_ancestor :
  forall x y, stsees x y -> x @= y.
Proof.
intros x y H.
apply plus_star.
apply stsees_impl_strict_ancestor; auto.
Qed.

Lemma sees_decide :
  forall x y,
    decidable (sees x y).
Proof.
intros x y.
apply dec_and.
  { apply ancestor_decide. }
apply dec_not.
apply (dec_exists_finite _ _ (fun z => z @= y)).
  2:{ apply ancestor_finite. }

  {
  intros z Hz.
  destruct_all Hz; auto.
  }
intro z.
apply (dec_exists_finite _ _ (fun z' => z' @= y)).
  2:{ apply ancestor_finite. }

  {
  intros z' Hz'.
  destruct_all Hz'; auto.
  }
intro z'.
apply dec_and.
  { apply ancestor_decide. }
apply dec_and.
  { apply ancestor_decide. }
apply dec_and.
  { apply fork_decide. }
apply eq_peer_decide.
Qed.

Lemma stsees_decide :
  forall x y,
    decidable (stsees x y).
Proof.
intros x y.
apply (dec_exists_finite _ _ (fun z => z @= y)).
  {
  intros z (H & _).
  auto.
  }

  { apply ancestor_finite. }
intro w.
apply dec_and.
  {
  apply ancestor_decide.
  }
eapply supermajority_decide.
  {
  intro a.
  apply (dec_exists_finite _ _ (fun z => z @= w)).
    {
    intros z (_ & _ & H).
    apply sees_impl_ancestor; auto.
    }

    { apply ancestor_finite. }
  intro z.
  apply dec_and.
    { apply eq_peer_decide. }
  apply dec_and; apply sees_decide.
  }

  { unfold incl, every; auto. }

  { exact the_total_stake. }
Qed.

Lemma self_ancestor_sees_trans :
  forall x y z,
    x $= y
    -> sees y z
    -> sees x z.
Proof.
intros x y z Hxy Hsees.
destruct Hsees as (Hyz & Hnofork).
split.
  {
  eapply star_trans; eauto.
  apply self_ancestor_impl_ancestor; auto.
  }
contradict Hnofork.
destruct Hnofork as (u & w & Huz & Hwz & Hfork & Heqcr).
exists u, w.
do2 3 split; auto.
transitivity (creator x); auto.
apply self_ancestor_creator; auto.
Qed.

Lemma self_ancestor_stsees_trans :
  forall x y z,
    x $= y
    -> stsees y z
    -> stsees x z.
Proof.
intros x y z Hxy Hss.
destruct Hss as (w & Hwz & Hmaj).
exists w.
split; auto.
eapply supermajority_enlarge; eauto.
  {
  intros a (u & Heqcr & Hyu & Huw).
  exists u.
  do2 2 split; auto.
  eapply self_ancestor_sees_trans; eauto.
  }

  {
  intros a _.
  apply (dec_exists_finite _ _ (fun u => u @= w)).
    {
    intros u (_ & _ & Hu).
    apply sees_impl_ancestor; auto.
    }

    {
    apply ancestor_finite.
    }

    {
    intros u.
    apply dec_and.
      { apply eq_peer_decide. }
    apply dec_and; apply sees_decide.
    }
  }
Qed.

Lemma stsees_ancestor_trans :
  forall x y z,
    stsees x y
    -> y @= z
    -> stsees x z.
Proof.
intros x y z Hss Hyz.
destruct Hss as (w & Hss & Hwy).
exists w.
split; auto.
eapply star_trans; eauto.
Qed.

Lemma ancestor_sees :
  forall x y,
    honest (creator x)
    -> x @= y
    -> sees x y.
Proof.
intros x y Hhonest Hxy.
split; auto.
intros (z & z' & Hzy & Hz'y & Hfork & Heqcr).
rewrite <- Heqcr in Hhonest.
so (event_world y) as (W & Wy).
destruct (world_forks W _ Hhonest).
exists z, z'.
do2 3 split; auto.
  {
  eapply world_closed; eauto.
  }

  {
  eapply world_closed; eauto.
  }
Qed.


(** * MiniQhasm+ for AMD64 *)

From Coq Require Import ZArith.
From mathcomp Require Import ssreflect ssrbool seq eqtype.
From CompCert Require Import Integers.
From Common Require Import ZAriths Env Var Store Integers.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Delimit Scope qhasm_scope with qhasm.

(** Syntax *)

Section Syntax.

  Variable E : SEnv.t.
  Notation pvar := (SEnv.pvar E).

  (* Constants *)
  Definition const : Set := int64.

  (* Atomics can be variables or constants. *)
  Inductive atomic : Set :=
  | QVar : pvar -> atomic
  | QConst : const -> atomic.

  (* Instructions.
   Below is the list of instructions:
   - QAssign r s: r = s
   - QAdd r s t: r = s + t
   - QAddC r s t: r = s + t + carry
   - QAdc r s t: carry? r = s + t
   - QAdcC r s t: carry? r = s + t + carry
   - QSub r s t: r = s - t
   - QSubC r s t: r = s - t - carry
   - QSbb r s t: carry? r = s - t
   - QSbbC r s t: carry? r = s - t - carry
   - QMul r s t: r = s * t
   - QMulf r s t u: r s = t * u
   - QShl r s n: r = s $<<$#<<# n
   - QShr r s n: r = s $>>$#>># n
   - QMod2n r s n: r = s $\%$#%# 2%\textasciicircum%#^#n
   *)
  Inductive instr : Set :=
  | QAssign : pvar -> atomic -> instr
  | QAdd : pvar -> atomic -> atomic -> instr
  | QAddC : pvar -> atomic -> atomic -> instr
  | QAdc : pvar -> atomic -> atomic -> instr
  | QAdcC : pvar -> atomic -> atomic -> instr
  | QSub : pvar -> atomic -> atomic -> instr
  | QSubC : pvar -> atomic -> atomic -> instr
  | QSbb : pvar -> atomic -> atomic -> instr
  | QSbbC : pvar -> atomic -> atomic -> instr
  | QMul : pvar -> atomic -> atomic -> instr
  | QMulf : pvar -> pvar -> atomic -> atomic -> instr
  | QShl : pvar -> atomic -> nat -> instr
  | QShr : pvar -> atomic -> nat -> instr
  | QMod2n : pvar -> atomic -> nat -> instr.

  Definition program : Set := seq instr.

End Syntax.

(** Values *)

Definition value : Set := int64.

Definition ctoZ c := if c then 1%Z else 0%Z.

Definition add_carry n m := Int64.add_carry n m Int64.zero == Int64.one.

(** States *)

Module State.

  Record t : Type :=
    mkState { store: VStore.t value;
              carry: option bool }.

  Definition empty : t :=
    {| store := VStore.empty value;
       carry := None |}.

  Definition acc (x : var) (s : t) : option value :=
    VStore.acc x (store s).

  Definition upd (x : var) (v : value) (s : t) : t :=
    {| store := VStore.upd x v (store s);
       carry := carry s |}.

  Definition set_carry c (s : t) : t :=
    {| store := store s;
       carry := Some c |}.

  Definition reset_carry (s : t) : t :=
    {| store := store s;
       carry := None |}.

  Lemma acc_upd_eq :
    forall x y v s,
      x == y ->
      acc x (upd y v s) = Some v.
  Proof.
    rewrite /acc /upd => x y v s Hxy.
    exact: VStore.acc_upd_eq.
  Qed.

  Lemma acc_upd_neq :
    forall x y v s,
      x != y ->
      acc x (upd y v s) = acc x s.
  Proof.
    rewrite /acc /upd => x y v s Hxy.
    exact: VStore.acc_upd_neq.
  Qed.

  Lemma acc_empty :
    forall x,
      acc x empty = None.
  Proof.
    rewrite /acc => x.
    exact: VStore.acc_empty.
  Qed.

  Definition Upd x v s1 s2 : Prop :=
    (forall y, acc y s2 = acc y (upd x v s1)) /\
    carry s1 = carry s2.

  Definition Carry c s1 s2 : Prop :=
    (forall x, acc x s2 = acc x s1) /\
    carry s2 = c.

  Lemma Upd_upd :
    forall x v s,
      Upd x v s (upd x v s).
  Proof.
    move=> x v s.
    split.
    - exact: VStore.Upd_upd.
    - reflexivity.
  Qed.

  Lemma acc_Upd_eq :
    forall x y v s1 s2,
      x == y ->
      Upd y v s1 s2 ->
      acc x s2 = Some v.
  Proof.
    move=> x y v s1 s2 Hxy [Hupd _].
    exact: (VStore.acc_Upd_eq Hxy Hupd).
  Qed.

  Lemma acc_Upd_neq :
    forall x y v s1 s2,
      x != y ->
      Upd y v s1 s2 ->
      acc x s2 = acc x s1.
  Proof.
    move=> x y v s1 s2 Hxy [Hupd _].
    exact: (VStore.acc_Upd_neq Hxy Hupd).
  Qed.

  Lemma acc_Carry :
    forall c x s1 s2,
      Carry c s1 s2 ->
      acc x s2 = acc x s1.
  Proof.
    move=> c x s1 s2 [Hv Hc].
    exact: Hv.
  Qed.

  Lemma Carry_carry :
    forall c s1 s2,
      Carry c s1 s2 ->
      carry s2 = c.
  Proof.
    move=> c s1 s2 [_ Hc].
    exact: Hc.
  Qed.

End State.

(** Semantics *)

Section Semantics.

  Variable E : SEnv.t.
  Notation pvar_var := SEnv.pvar_var.

  Inductive eval_atomic : atomic E -> value -> State.t -> Prop :=
  | EQVar :
      forall v n st,
        State.acc (pvar_var v) st = Some n ->
        eval_atomic (QVar v) n st
  | EQConst :
      forall n st,
        eval_atomic (QConst E n) n st.

  Inductive eval_instr : State.t -> instr E -> State.t -> Prop :=
  | EQAssign :
      forall r s vs s1 s2,
        eval_atomic s vs s1 ->
        State.Upd (pvar_var r) vs s1 s2 ->
        eval_instr s1 (QAssign r s) s2
  | EQAdd : (* tbd *)
      forall r s t st,
        eval_instr st (QAdd r s t) st
  | EQAddC : (* tbd *)
      forall r s t st,
        eval_instr st (QAddC r s t) st
  | EQAdc :
      forall r s t vs vt s1 s2 s3,
        let v := Int64.add vs vt in
        let c := add_carry vs vt in
        eval_atomic s vs s1 ->
        eval_atomic t vt s1 ->
        State.Upd (pvar_var r) v s1 s2 ->
        State.Carry (Some c) s2 s3 ->
        eval_instr s1 (QAdc r s t) s3
  | EQAdcC : (* tbd *)
      forall r s t st,
        eval_instr st (QAdcC r s t) st
  | EQSub : (* tbd *)
      forall r s t st,
        eval_instr st (QSub r s t) st
  | EQSubC : (* tbd *)
      forall r s t st,
        eval_instr st (QSubC r s t) st
  | EQSbb : (* tbd *)
      forall r s t st,
        eval_instr st (QSbb r s t) st
  | EQSbbC : (* tbd *)
      forall r s t st,
        eval_instr st (QSbbC r s t) st
  | EQMul : (* tbd *)
      forall r s t st,
        eval_instr st (QMul r s t) st
  | EQMulf : (* tbd *)
      forall r s t u st,
        eval_instr st (QMulf r s t u) st
  | EQShl : (* tbd *)
      forall r s n st,
        eval_instr st (QShl r s n) st
  | EQShr : (* tbd *)
      forall r s n st,
        eval_instr st (QShr r s n) st
  | EQMod2n : (* tbd *)
      forall r s n st,
        eval_instr st (QMod2n r s n) st.

  Inductive eval_program : State.t -> program E -> State.t -> Prop :=
  | EQEmpty : forall st, eval_program st nil st
  | EQCons :
      forall hd tl st1 st2 st3,
        eval_instr st1 hd st2 ->
        eval_program st2 tl st3 ->
        eval_program st1 (hd::tl) st3.

  Lemma eval_program_empty :
    forall (st1 st2 : State.t),
      eval_program st1 [::] st2 -> st1 = st2.
  Proof.
    move=> st1 st2 H; by inversion_clear H.
  Qed.

  Lemma eval_program_singleton :
    forall (i : instr E) (st1 st2 : State.t),
      eval_program st1 ([:: i]) st2 ->
      eval_instr st1 i st2.
  Proof.
    move=> i st1 st2 H; inversion_clear H.
    move: (eval_program_empty H1) => {H1} H1.
    rewrite -H1.
    exact: H0.
  Qed.

  Lemma eval_program_cons :
    forall (hd : instr E) (tl : program E) (st1 st2 : State.t),
      eval_program st1 (hd::tl) st2 ->
      exists st3 : State.t,
        eval_instr st1 hd st3 /\ eval_program st3 tl st2.
  Proof.
    move=> hd tl st1 st2 H.
    inversion_clear H.
    exists st3; split; assumption.
  Qed.

  Lemma eval_program_concat :
    forall (p1 p2 : program E) (st1 st2 st3 : State.t),
      eval_program st1 p1 st2 ->
      eval_program st2 p2 st3 ->
      eval_program st1 (p1 ++ p2) st3.
  Proof.
    move=> p1; elim: p1.
    - move=> p2 st1 st2 st3 H1 H2.
      move: (eval_program_empty H1) => {H1} H1.
      rewrite H1.
      exact: H2.
    - move=> hd tl H p2 st1 st2 st3 H1 H2.
      move: (eval_program_cons H1) => {H1} [st4 [H1 H4]].
      apply: (EQCons H1).
      apply: (H _ _ _ _ H4).
      exact: H2.
  Qed.

  Lemma eval_program_split :
    forall (p1 p2 : program E) (st1 st2 : State.t),
      eval_program st1 (p1 ++ p2) st2 ->
      exists st3 : State.t,
        eval_program st1 p1 st3 /\ eval_program st3 p2 st2.
  Proof.
    move=> p1; elim: p1.
    - move=> p2 st1 st2 H1.
      exists st1; split.
      + exact: EQEmpty.
      + exact: H1.
    - move=> hd tl H p2 st1 st2 H1.
      move: (eval_program_cons H1) => {H1} [st3 [H13 H32]].
      move: (H _ _ _ H32) => {H} [st4 [H34 H42]].
      exists st4; split.
      + exact: (EQCons H13 H34).
      + exact: H42.
  Qed.

End Semantics.

(** Uncaught carry *)

Section Safety.

  Variable E : SEnv.t.

  (* Detect if an instruction will cause uncaught carry. *)
  Inductive instr_safe : instr E -> State.t -> Prop :=
  | SQAssign : forall r s st, instr_safe (QAssign r s) st
  | SQAdd :
      forall r s t vs vt st,
        eval_atomic s vs st ->
        eval_atomic t vt st ->
        ~~ add_carry vs vt ->
        instr_safe (QAdd r s t) st.

  Inductive program_safe : program E -> State.t -> Prop :=
  | SQEmpty : forall st : State.t, program_safe [::] st
  | SQCons :
      forall hd tl st,
        instr_safe hd st ->
        (forall st' : State.t, eval_instr st hd st' -> program_safe tl st') ->
        program_safe (hd::tl) st.

  Lemma program_safe_hd :
    forall (hd : instr E) (tl : program E) (s : State.t),
      program_safe (hd::tl) s ->
      instr_safe hd s.
  Proof.
    move=> hd tl s H.
    inversion_clear H.
    exact: H0.
  Qed.

  Lemma program_safe_tl :
    forall (hd : instr E) (tl : program E) (st1 st2 : State.t),
      program_safe (hd::tl) st1 ->
      eval_instr st1 hd st2 ->
      program_safe tl st2.
  Proof.
    move=> hd tl st1 st2 H Hi.
    inversion_clear H.
    exact: (H1 _ Hi).
  Qed.

  Lemma program_safe_split :
    forall (p1 p2 : program E) (st1 : State.t),
      program_safe p1 st1 ->
      (forall st2 : State.t,
          eval_program st1 p1 st2 -> program_safe p2 st2) ->
      program_safe (p1 ++ p2) st1.
  Proof.
    move=> p1; elim: p1.
    - move=> p2 st1 Hs1 Hs2.
      apply: Hs2.
      exact: EQEmpty.
    - move=> hd tl H p2 st1 Hs1 Hs2.
      apply: SQCons.
      + exact: (program_safe_hd Hs1).
      + move=> st3 He1.
        move: (program_safe_tl Hs1 He1) => Hs3.
        apply: (H _ _ Hs3).
        move=> st4 He3.
        apply: Hs2.
        exact: (EQCons He1 He3).
  Qed.

End Safety.

(** Specification *)

Section Specification.

  Variable E : SEnv.t.
  Notation pvar := (SEnv.pvar E).
  Notation pvar_var := SEnv.pvar_var.
  Notation value := Z.

  Inductive unop : Set :=
  | ONeg.

  Inductive binop : Set :=
  | OAdd
  | OSub
  | OMul
  | ODiv
  | OMod.

  Inductive exp : Set :=
  | EVar : pvar -> exp
  | EConst : Z -> exp
  | ECarry : exp
  | EUnop : unop -> exp -> exp
  | EBinop : binop -> exp -> exp -> exp.

  Inductive cop : Set :=
  | CEq
  | CLt
  | CLe
  | CGt
  | CGe.

  Inductive bexp : Set :=
  | BComp : cop -> exp -> exp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp
  | BOr : bexp -> bexp -> bexp.

  Definition eval_unop (op : unop) (v : value) : value :=
    match op with
    | ENeg => (-v)%Z
    end.

  Definition eval_binop (op : binop) (v1 v2 : value) : value :=
    match op with
    | OAdd => (v1 + v2)%Z
    | OSub => 0 (* tbd *)
    | OMul => 0 (* tbd *)
    | ODiv => 0 (* tbd *)
    | OMod => 0 (* tbd *)
    end.

  Inductive eval_exp : exp -> value -> State.t -> Prop :=
  | EEVar :
      forall v n s,
        State.acc (pvar_var v) s = Some n ->
        eval_exp (EVar v) (Int64.unsigned n) s
  | EEConst : forall n s, eval_exp (EConst n) n s
  | EECarry :
      forall s c,
        State.carry s = Some c ->
        eval_exp ECarry (ctoZ c) s
  | EEUnop :
      forall op e n m s,
        eval_exp e n s ->
        eval_unop op n = m ->
        eval_exp (EUnop op e) m s
  | EEBinop :
      forall op e1 e2 v1 v2 n s,
        eval_exp e1 v1 s ->
        eval_exp e2 v2 s ->
        eval_binop op v1 v2 = n ->
        eval_exp (EBinop op e1 e2) n s.

  Definition eval_cop op (v1 v2 : value) : bool :=
    match op with
    | CEq => v1 == v2
    | CLt => Z.ltb v1 v2
    | CLe => Z.leb v1 v2
    | CGt => Z.gtb v1 v2
    | CGe => Z.geb v1 v2
    end.

  Inductive eval_bexp : bexp -> bool -> State.t -> Prop :=
  | EBComp :
      forall op e1 e2 n1 n2 s,
        eval_exp e1 n1 s ->
        eval_exp e2 n2 s ->
        eval_bexp (BComp op e1 e2) (eval_cop op n1 n2) s
  | EBNot :
      forall e b s,
        eval_bexp e b s ->
        eval_bexp (BNot e) (~~b) s
  | EBAnd :
      forall e1 e2 b1 b2 s,
        eval_bexp e1 b1 s ->
        eval_bexp e2 b2 s ->
        eval_bexp (BAnd e1 e2) (b1 && b2) s
  | EBOr :
      forall e1 e2 b1 b2 s,
        eval_bexp e1 b1 s ->
        eval_bexp e2 b2 s ->
        eval_bexp (BOr e1 e2) (b1 || b2) s.

  Definition valid (f : bexp) : Prop :=
    forall s : State.t, eval_bexp f true s.

  Definition entails (f g : bexp) : Prop :=
    forall s : State.t,
      eval_bexp f true s -> eval_bexp g true s.

  Definition spec (f : bexp) (p : program E) (g : bexp) : Prop :=
    forall s1 s2,
      eval_bexp f true s1 ->
      eval_program s1 p s2 ->
      eval_bexp g true s2.

  Definition counterexample (f : bexp) (p : program E) (g : bexp) (s : State.t) : Prop :=
    eval_bexp f true s /\
    exists s' : State.t, eval_program s p s' /\ eval_bexp g false s'.

  Lemma spec_strengthing :
    forall f g h p,
      entails f g -> spec g p h -> spec f p h.
  Proof.
    move=> f g h p Hfg Hgh s1 s2 Hf Hp.
    apply: (Hgh _ _ _ Hp).
    exact: (Hfg _ Hf).
  Qed.

  Lemma spec_weakening :
    forall f g h p,
      spec f p g -> entails g h -> spec f p h.
  Proof.
    move=> f g h p Hfg Hgh s1 s2 Hf Hp.
    apply: Hgh.
    exact: (Hfg _ _ Hf Hp).
  Qed.

  Lemma spec_empty_entails :
    forall f g,
      spec f [::] g -> entails f g.
  Proof.
    move=> f g He s Hf.
    apply: (He s _ Hf).
    apply: EQEmpty.
  Qed.

  Lemma spec_empty :
    forall f g,
      entails f g -> spec f [::] g.
  Proof.
    move=> f g Hfg s1 s2 Hf Hp.
    move: Hf.
    inversion_clear Hp => {s1} Hf.
    exact: (Hfg _ Hf).
  Qed.

  Lemma spec_cons :
    forall f g h hd tl,
      spec f [::hd] g -> spec g tl h ->
      spec f (hd::tl) h.
  Proof.
    move=> f g h hd tl Hhd Htl s1 s2 Hf Hp.
    inversion_clear Hp.
    apply: (Htl st2 _ _ H0).
    apply: (Hhd s1 _ Hf).
    apply: (EQCons H).
    exact: EQEmpty.
  Qed.

End Specification.

Notation "s |= f" := (eval_bexp f true s) (at level 74, no associativity) : qhasm_scope.
Notation "f ===> g" := (entails f g) (at level 82, no associativity) : qhasm_scope.
Notation "{{ f }} p {{ g }}" := (spec f p g) (at level 82, no associativity) : qhasm_scope.

(* A program is safe under a precondition. *)
Definition program_safe_under E (p : program E) (e : bexp E) : Prop :=
  forall s : State.t,
    eval_bexp e true s ->
    program_safe p s.


(* -*- coding: utf-8 -*- *)
(*      This file is distributed under the terms of the      *)
(*       GNU Lesser General Public License Version 2.1       *)
(* Author: Sosuke Moriguchi *)
(* Extended implementation from MSetWeakList *)

(** * Finite sets library *)

(** This file is extension of [MSetWeakList] to implement extensions in XSetInterface. *)

Require Import XSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.

(** * Functions over lists *)

(** ** The set operations. *)

Module Ops (X: DecidableType) <: WOps X.

  Definition elt := X.t.
  Definition t := list elt.

  Definition empty : t := nil.

  Definition is_empty (l : t) : bool := if l then true else false.

  Fixpoint mem (x : elt) (s : t) : bool :=
    match s with
    | nil => false
    | y :: l =>
           if X.eq_dec x y then true else mem x l
    end.

  Fixpoint add (x : elt) (s : t) : t :=
    match s with
    | nil => x :: nil
    | y :: l =>
        if X.eq_dec x y then s else y :: add x l
    end.

  Definition singleton (x : elt) : t := x :: nil.

  Fixpoint remove (x : elt) (s : t) : t :=
    match s with
    | nil => nil
    | y :: l =>
        if X.eq_dec x y then l else y :: remove x l
    end.

  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
    fold_left (flip f) s i.

  Definition union (s : t) : t -> t := fold add s.

  Definition diff (s s' : t) : t := fold remove s' s.

  Definition inter (s s': t) : t :=
    fold (fun x s => if mem x s' then add x s else s) s nil.

  Definition subset (s s' : t) : bool := is_empty (diff s s').

  Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s).

  Fixpoint filter (f : elt -> bool) (s : t) : t :=
    match s with
    | nil => nil
    | x :: l => if f x then x :: filter f l else filter f l
    end.

  Fixpoint for_all (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => true
    | x :: l => if f x then for_all f l else false
    end.

  Fixpoint exists_ (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => false
    | x :: l => if f x then true else exists_ f l
    end.

  Fixpoint partition (f : elt -> bool) (s : t) : t * t :=
    match s with
    | nil => (nil, nil)
    | x :: l =>
        let (s1, s2) := partition f l in
        if f x then (x :: s1, s2) else (s1, x :: s2)
    end.

  Definition cardinal (s : t) : nat := length s.

  Definition elements (s : t) : list elt := s.

  Definition choose (s : t) : option elt :=
     match s with
      | nil => None
      | x::_ => Some x
     end.

End Ops.

(** ** Proofs of set operation specifications. *)

Module MakeRaw (X:DecidableType) <: WRawSets X.
  Include Ops X.

  Section ForNotations.
  Notation NoDup := (NoDupA X.eq).
  Notation In := (InA X.eq).

  (* TODO: modify proofs in order to avoid these hints *)
  Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv).
  Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv).
  Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv).

  Definition IsOk := NoDup.

  Class Ok (s:t) : Prop := ok : NoDup s.

  Hint Unfold Ok.
  Hint Resolve @ok.

  Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }.

  Ltac inv_ok := match goal with
   | H:Ok (_ :: _) |- _ => inversion_clear H; inv_ok
   | H:Ok nil |- _ => clear H; inv_ok
   | H:NoDup ?l |- _ => change (Ok l) in H; inv_ok
   | _ => idtac
  end.

  Ltac inv := invlist InA; inv_ok.
  Ltac constructors := repeat constructor.

  Fixpoint isok l := match l with
   | nil => true
   | a::l => negb (mem a l) && isok l
  end.

  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.

  Lemma In_compat : Proper (X.eq==>eq==>iff) In.
  Proof.
  repeat red; intros. subst. rewrite H; auto.
  Qed.

  Lemma mem_spec : forall s x `{Ok s},
   mem x s = true <-> In x s.
  Proof.
  induction s; intros.
  split; intros; inv. discriminate.
  simpl; destruct (X.eq_dec x a); split; intros; inv; auto.
  right; rewrite <- IHs; auto.
  rewrite IHs; auto.
  Qed.

  Lemma isok_iff : forall l, Ok l <-> isok l = true.
  Proof.
  induction l.
  intuition.
  simpl.
  rewrite andb_true_iff.
  rewrite negb_true_iff.
  rewrite <- IHl.
  split; intros H. inv.
  split; auto.
  apply not_true_is_false. rewrite mem_spec; auto.
  destruct H; constructors; auto.
  rewrite <- mem_spec; auto; congruence.
  Qed.

  Global Instance isok_Ok l : isok l = true -> Ok l | 10.
  Proof.
  intros. apply <- isok_iff; auto.
  Qed.

  Lemma add_spec :
   forall (s : t) (x y : elt) {Hs : Ok s},
     In y (add x s) <-> X.eq y x \/ In y s.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition.
  left; eauto.
  inv; auto.
  Qed.

  Global Instance add_ok s x `(Ok s) : Ok (add x s).
  Proof.
  induction s.
  simpl; intuition.
  intros; inv. simpl.
  destruct X.eq_dec; auto.
  constructors; auto.
  intro; inv; auto.
  rewrite add_spec in *; intuition.
  Qed.

  Lemma remove_spec :
   forall (s : t) (x y : elt) {Hs : Ok s},
     In y (remove x s) <-> In y s /\ ~X.eq y x.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  destruct X.eq_dec; inv; rewrite !InA_cons, ?IHs; intuition.
  elim H. setoid_replace a with y; eauto.
  elim H3. setoid_replace x with y; eauto.
  elim n. eauto.
  Qed.

  Global Instance remove_ok s x `(Ok s) : Ok (remove x s).
  Proof.
  induction s; simpl; intros.
  auto.
  destruct X.eq_dec; inv; auto.
  constructors; auto.
  rewrite remove_spec; intuition.
  Qed.

  Lemma singleton_ok : forall x : elt, Ok (singleton x).
  Proof.
  unfold singleton; simpl; constructors; auto. intro; inv.
  Qed.

  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
  Proof.
  unfold singleton; simpl; split; intros. inv; auto. left; auto.
  Qed.

  Lemma empty_ok : Ok empty.
  Proof.
  unfold empty; constructors.
  Qed.

  Lemma empty_spec : Empty empty.
  Proof.
  unfold Empty, empty; red; intros; inv.
  Qed.

  Lemma is_empty_spec : forall (s : t) `{Ok s}, is_empty s = true <-> Empty s.
  Proof.
  unfold Empty; destruct s; simpl; intro Hs; split; intros; auto.
  intro; inv.
  discriminate.
  elim (H e); auto.
  Qed.

  Lemma elements_spec1 : forall (s : t) (x : elt) `{Ok s}, In x (elements s) <-> In x s.
  Proof.
  unfold elements; intuition.
  Qed.

  Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s).
  Proof.
  unfold elements; auto.
  Qed.

  Lemma fold_spec :
   forall (s : t) `{Ok s} (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (flip f) (elements s) i.
  Proof.
  reflexivity.
  Qed.

  Global Instance union_ok : forall s s' `(Ok s, Ok s'), Ok (union s s').
  Proof.
  induction s; simpl; auto; intros; inv; unfold flip; auto with *.
  Qed.

  Lemma union_spec :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (union s s') <-> In x s \/ In x s'.
  Proof.
  induction s; simpl in *; unfold flip; intros; auto; inv.
  intuition; inv.
  rewrite IHs, add_spec, InA_cons; intuition.
  Qed.

  Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
  Proof.
  unfold inter, fold, flip.
  set (acc := nil (A:=elt)).
  assert (Hacc : Ok acc) by constructors.
  clearbody acc; revert acc Hacc.
  induction s; simpl; auto; intros. inv.
  apply IHs; auto.
  destruct (mem a s'); auto with *.
  Qed.

  Lemma inter_spec  :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (inter s s') <-> In x s /\ In x s'.
  Proof.
  unfold inter, fold, flip; intros.
  set (acc := nil (A:=elt)) in *.
  assert (Hacc : Ok acc) by constructors.
  assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc).
   intuition; unfold acc in *; inv.
  rewrite IFF; clear IFF. clearbody acc.
  revert acc Hacc x s' Hs Hs'.
  induction s; simpl; intros.
  intuition; inv.
  inv.
  case_eq (mem a s'); intros Hm.
  rewrite IHs, add_spec, InA_cons; intuition.
  rewrite mem_spec in Hm; auto.
  left; split; auto. rewrite H1; auto.
  rewrite IHs, InA_cons; intuition.
  rewrite H2, <- mem_spec in H3; auto. congruence.
  Qed.

  Global Instance diff_ok : forall s s' `(Ok s, Ok s'), Ok (diff s s').
  Proof.
  unfold diff; intros s s'; revert s.
  induction s'; simpl; unfold flip; auto; intros. inv; auto with *.
  Qed.

  Lemma diff_spec  :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (diff s s') <-> In x s /\ ~In x s'.
  Proof.
  unfold diff; intros s s'; revert s.
  induction s'; simpl; unfold flip.
  intuition; inv.
  intros. inv.
  rewrite IHs', remove_spec, InA_cons; intuition.
  Qed.

  Lemma subset_spec :
   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
   subset s s' = true <-> Subset s s'.
  Proof.
  unfold subset, Subset; intros.
  rewrite is_empty_spec.
  unfold Empty; intros.
  intuition.
  specialize (H a). rewrite diff_spec in H; intuition.
  rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition.
  rewrite diff_spec in H0; intuition.
  Qed.

  Lemma equal_spec :
   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
   equal s s' = true <-> Equal s s'.
  Proof.
  unfold Equal, equal; intros.
  rewrite andb_true_iff, !subset_spec.
  unfold Subset; intuition. rewrite <- H; auto. rewrite H; auto.
  Qed.

  Definition choose_spec1 :
    forall (s : t) (x : elt) `{Ok s}, choose s = Some x -> In x s.
  Proof.
  intros s x _; destruct s; simpl; intros; inversion H; auto.
  Qed.

  Definition choose_spec2 : forall (s : t) `{Ok s}, choose s = None -> Empty s.
  Proof.
  destruct s; simpl; intros _ H.
  intros x H0; inversion H0.
  inversion H.
  Qed.

  Lemma cardinal_spec :
   forall (s : t) {Hs : Ok s}, cardinal s = length (elements s).
  Proof.
  auto.
  Qed.

  Lemma filter_spec' : forall s x f `{Ok s},
   In x (filter f s) -> In x s.
  Proof.
  induction s; simpl.
  intuition; inv.
  intros; destruct (f a); inv; intuition; right; eauto.
  Qed.

  Lemma filter_spec :
   forall (s : t) (x : elt) (f : elt -> bool) `{Ok s},
   Proper (X.eq==>eq) f ->
   (In x (filter f s) <-> In x s /\ f x = true).
  Proof.
  intros s x f _; induction s; simpl.
  intuition; inv.
  intros.
  destruct (f a) eqn:E; rewrite ?InA_cons, IHs; intuition.
  setoid_replace x with a; auto.
  setoid_replace a with x in E; auto. congruence.
  Qed.

  Global Instance filter_ok s f `(Ok s) : Ok (filter f s).
  Proof.
  induction s; simpl.
  auto.
  intros; inv.
  case (f a); auto.
  constructors; auto.
  contradict H0.
  eapply filter_spec'; eauto.
  Qed.

  Lemma for_all_spec :
   forall (s : t) (f : elt -> bool) `{Ok s},
   Proper (X.eq==>eq) f ->
   (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof.
  unfold For_all; intros s f _; induction s; simpl.
  intuition. inv.
  intros; inv.
  destruct (f a) eqn:F.
  rewrite IHs; intuition. inv; auto.
  setoid_replace x with a; auto.
  split; intros H'; try discriminate.
  intros.
  rewrite <- F, <- (H' a); auto.
  Qed.

  Lemma exists_spec :
   forall (s : t) (f : elt -> bool) `{Ok s},
   Proper (X.eq==>eq) f ->
   (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof.
  unfold Exists; intros s f _; induction s; simpl.
  split; [discriminate| intros (x & Hx & _); inv].
  intros.
  destruct (f a) eqn:F.
  split; auto.
  exists a; auto.
  rewrite IHs; firstorder.
  inv.
  setoid_replace a with x in F; auto; congruence.
  exists x; auto.
  Qed.

  Lemma partition_spec1_w :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (fst (partition f s)) (filter f s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  firstorder.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  case (partition f l); intros s1 s2; simpl; intros.
  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
  Qed.

  Lemma partition_spec1 :
   forall (s : t) (f : elt -> bool) `{Ok s},
   Proper (X.eq==>eq) f ->
   Equal (fst (partition f s)) (filter f s).
  Proof.
  intros s f _; exact (@partition_spec1_w _ _).
  Qed.

  Lemma partition_spec1' :
   forall (s : t) (x : elt) (f : elt -> bool) `{Ok s},
   In x (fst (partition f s)) -> In x s.
  Proof.
  intros s x f _; induction s; simpl; intro H.
  now auto.
  destruct (partition f s); simpl in *.
  destruct (f a); simpl in H.
  inversion_clear H; now auto.
  now auto.
  Qed.

  Lemma partition_spec2_w :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  firstorder.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  case (partition f l); intros s1 s2; simpl; intros.
  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
  Qed.

  Lemma partition_spec2 :
   forall (s : t) (f : elt -> bool) `{Ok s},
   Proper (X.eq==>eq) f ->
   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof.
  intros s f _; exact (@partition_spec2_w _ _).
  Qed.

  Lemma partition_spec2' :
   forall (s : t) (x : elt) (f : elt -> bool) `{Ok s},
   In x (snd (partition f s)) -> In x s.
  Proof.
  intros s x f _; induction s; simpl; intro H.
  now auto.
  destruct (partition f s); simpl in *.
  destruct (f a); simpl in H.
  auto.
  inversion_clear H; auto.
  Qed.

  Lemma partition_ok1' :
   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
    In x (fst (partition f s)) -> In x s.
  Proof.
  induction s; simpl; auto; intros. inv.
  generalize (IHs H1 f x).
  destruct (f a); destruct (partition f s); simpl in *; auto.
  inversion_clear H; auto.
  Qed.

  Lemma partition_ok2' :
   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
    In x (snd (partition f s)) -> In x s.
  Proof.
  induction s; simpl; auto; intros. inv.
  generalize (IHs H1 f x).
  destruct (f a); destruct (partition f s); simpl in *; auto.
  inversion_clear H; auto.
  Qed.

  Global Instance partition_ok1 : forall s f `(Ok s), Ok (fst (partition f s)).
  Proof.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (@partition_ok1' _ _ f x).
  generalize (Hrec f H0).
  case (f x); case (partition f l); simpl; constructors; auto.
  Qed.

  Global Instance partition_ok2 : forall s f `(Ok s), Ok (snd (partition f s)).
  Proof.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (@partition_ok2' _ _ f x).
  generalize (Hrec f H0).
  case (f x); case (partition f l); simpl; constructors; auto.
  Qed.

  End ForNotations.

  Definition In := InA X.eq.
  Definition eq := Equal.
  Instance eq_equiv : Equivalence eq := _.

End MakeRaw.

(** * Encapsulation

   Now, in order to really provide a functor implementing [S], we
   need to encapsulate everything into a type of lists without redundancy. *)

Module Make (X: DecidableType) <: WSets with Module E := X.
 Module Raw := MakeRaw X.
 Include WRaw2Sets X Raw.
End Make.


Require Import String.
Require Import List.
Require Import Nat.

Open Scope string_scope.
Open Scope list_scope.
Open Scope core_scope.

Import ListNotations.

Require Import AST.
Require Import Maps.

Fixpoint app_sub_to_type (s : substs) (t : t_type) : t_type :=
  match t with
    | TNum | TBool => t
    | TFun x e => TFun (app_sub_to_type s x) (app_sub_to_type s e)
    | TList l => TList (app_sub_to_type s l)
    | TVar i =>
      match s i with
        | Some T => T
        | None => t
      end
  end.

Fixpoint app_sub_to_expr (s : substs) (e : t_expr) : t_expr :=
  match e with
    | ENum _ | EBool _ | EVar _ => e
    | EIf c e1 e2 =>
      EIf (app_sub_to_expr s c) (app_sub_to_expr s e1) (app_sub_to_expr s e2)
    | EFun x T e =>
      EFun x (app_sub_to_type s T) (app_sub_to_expr s e)
    | ECall f e =>
      ECall (app_sub_to_expr s f) (app_sub_to_expr s e)
    | EBinop op e1 e2 =>
      EBinop op (app_sub_to_expr s e1) (app_sub_to_expr s e2)
    | ECons hd tl =>
      ECons (app_sub_to_expr s hd) (app_sub_to_expr s tl)
    | ENil T =>
      ENil (app_sub_to_type s T)
  end.

Definition app_sub_to_env (s : substs) (env : t_env) : substs :=
  (fun i =>
    match env i with
      | Some T => Some (app_sub_to_type s T)
      | None => None
    end).

Inductive satisfy : substs -> constr -> Prop :=
  | SAT_Empty: forall s, satisfy s []
  | SAT_NotEmpty:
    forall s t1 t2 tl,
    app_sub_to_type s t1 = app_sub_to_type s t2 ->
    satisfy s tl ->
    satisfy s ((t1, t2)::tl).

Fixpoint typevars (t : t_type) : list id :=
  match t with
    | TNum | TBool => []
    | TFun x e => typevars x ++ typevars e
    | TList l => typevars l
    | TVar i => [i]
  end.

Definition max_typevar (t : t_type) (fv : nat) : nat :=
  (fold_left
    (fun mx n => Nat.max mx n)
    (map (fun i => match i with | Id n => n end) (typevars t))
    fv).

Definition typevars_from_constr (con : constr) : list id :=
  fold_left
    (fun l (c : (t_type * t_type)) =>
      let (t1, t2) := c in l ++ typevars t1 ++ typevars t2) con [].

Inductive typeinf : t_env -> nat -> t_expr -> (nat * t_type * constr * list id) % type -> Prop :=
  (* ENum *)
  (* EBool *)
  (* EVar *)
  | TI_Num: forall env n fv,
    typeinf env fv (ENum n) (fv + 1, TNum, [], [])
  | TI_Bool: forall env b fv,
    typeinf env fv (EBool b) (fv + 1, TBool, [], [])
  | TI_Var: forall env x fv fv' T,
    env x = Some T ->
    max_typevar T fv + 1 = fv' ->
    typeinf env fv (EVar x) (fv', T, [], [])

  (* EIf *)
  | TI_If:
    forall env fv
      c c_fv c_C c_T c_X
      e1 e1_fv e1_C e1_T e1_X
      e2 e2_fv e2_C e2_T e2_X,
    typeinf env fv c (c_fv, c_T, c_C, c_X) ->
    typeinf env c_fv  e1 (e1_fv, e1_T, e1_C, e1_X) ->
    typeinf env e1_fv  e2 (e2_fv, e2_T, e2_C, e2_X) ->
    typeinf env fv (EIf c e1 e2) (e2_fv, e1_T, e2_C ++ e1_C ++ c_C ++ [(e1_T, e2_T); (c_T, TBool)], e2_X ++ e1_X ++ c_X)

  (* EFun *)
  | TI_Fun:
    forall env fv fv'
      x x_T e e_fv e_C e_T e_X,
    max_typevar x_T fv + 1 = fv' ->
    typeinf (update env x x_T) fv' e (e_fv, e_T, e_C, e_X) ->
    typeinf env fv (EFun x x_T e) (e_fv, (TFun x_T e_T), e_C, e_X)

  (* ECall *)
  | TI_Call:
    forall env fv
      f f_fv f_C f_T f_X
      e e_fv e_C e_T e_X,
    typeinf env fv f (f_fv, f_T, f_C, f_X) ->
    typeinf env f_fv e (e_fv, e_T, e_C, e_X) ->
    typeinf env fv (ECall f e) (e_fv + 1, TVar (Id e_fv), e_C ++ f_C ++ [(f_T, TFun e_T (TVar (Id e_fv)))], e_X ++ f_X ++ [Id e_fv])

  (* ECons *)
  | TI_Cons:
    forall env fv
      hd hd_fv hd_C hd_T hd_X
      tl tl_fv tl_C tl_T tl_X,
    typeinf env fv hd (hd_fv, hd_T, hd_C, hd_X) ->
    typeinf env hd_fv tl (tl_fv, tl_T, tl_C, tl_X) ->
    typeinf env fv (ECons hd tl) (tl_fv, TList hd_T, tl_C ++ hd_C ++ [(tl_T, TList hd_T)], tl_X ++ hd_X)

  (* ENil *)
  | TI_Nil:
    forall env T fv fv',
    max_typevar T fv + 1 = fv' ->
    typeinf env fv (ENil T) (fv', TList T, [], [])

  (* EBinop *)
  | TI_Binop_nnn:
    forall env fv op
      e1 e1_fv e1_C e1_T e1_X
      e2 e2_fv e2_C e2_T e2_X,
    typeinf env fv e1 (e1_fv, e1_T, e1_C, e1_X) ->
    typeinf env e1_fv e2 (e2_fv, e2_T, e2_C, e2_X) ->
    op = OpPlus \/
    op = OpMinus ->
    typeinf env fv (EBinop op e1 e2) (e2_fv, TNum, e2_C++ e1_C ++ [(e2_T, TNum); (e1_T, TNum)], e2_X ++ e1_X)

  | TI_Binop_nnb:
    forall env fv op
      e1 e1_fv e1_C e1_T e1_X
      e2 e2_fv e2_C e2_T e2_X,
    typeinf env fv e1 (e1_fv, e1_T, e1_C, e1_X) ->
    typeinf env e1_fv e2 (e2_fv, e2_T, e2_C, e2_X) ->
    op = OpEq \/
    op = OpNeq ->
    typeinf env fv (EBinop op e1 e2) (e2_fv, TBool, e2_C++ e1_C ++ [(e2_T, TNum); (e1_T, TNum)], e2_X ++ e1_X)

  | TI_Binop_bbb:
    forall env fv op
      e1 e1_fv e1_C e1_T e1_X
      e2 e2_fv e2_C e2_T e2_X,
    typeinf env fv e1 (e1_fv, e1_T, e1_C, e1_X) ->
    typeinf env e1_fv e2 (e2_fv, e2_T, e2_C, e2_X) ->
    op = OpAnd \/
    op = OpOr ->
    typeinf env fv (EBinop op e1 e2) (e2_fv, TBool, e2_C++ e1_C ++ [(e2_T, TBool); (e1_T, TBool)], e2_X ++ e1_X).


From coqutil Require Import sanity Macros.subst Macros.unique Map.Interface.
From Coq.Logic Require Import FunctionalExtensionality.

Module Import parameters.
  Class parameters := {
    key : Type;
    value : Type;
    eqb : key -> key -> bool
  }.

  Class ok (p : parameters): Prop := {
    eqb_ok : forall k1 k2, BoolSpec (k1 = k2) (k1 <> k2) (eqb k1 k2)
  }.
End parameters. Notation parameters := parameters.parameters.

Section SortedList. Local Set Default Proof Using "All".
  Context {p : unique! parameters} {ok : parameters.ok p}.
  Context (magic_fold: forall R : Type, (R -> key -> value -> R) -> R -> (key -> option value) -> R).
  (* We can't fold over the elements of a set defined using a function, so we just assume fold_spec: *)
  Hypothesis magic_fold_is_magic: forall R P r0 f,
      P (fun _ : key => None) r0 ->
      (forall k v m r, m k = None -> P m r -> P (fun q : key => if eqb q k then Some v else m q) (f r k v)) ->
      forall m, P m (magic_fold R f r0 m).
  Hypothesis magic_fold_respects_relations: forall {A B : Type} (R : A -> B -> Prop)
      (fa : A -> key -> value -> A) (fb : B -> key -> value -> B),
      (forall (a : A) (b : B) (k : key) (v : value), R a b -> R (fa a k v) (fb b k v)) ->
      forall a0 b0, R a0 b0 -> forall m, R (magic_fold A fa a0 m) (magic_fold B fb b0 m).

  Definition map : map.map key parameters.value :=
    {|
    map.rep := key -> option value;
    map.empty _ := None;
    map.get m := m;
    map.put m k v q := if eqb q k then Some v else m q;
    map.remove m k q := if eqb q k then None else m q;
    map.fold := magic_fold;
  |}.

  Global Instance map_ok : map.ok map.
  Proof.
    split; cbv [map.rep map.empty map.get map.put map.remove map.fold map]; intros;
      repeat match goal with
      | |- context[eqb ?a ?b] => destruct (eqb_ok a b)
      | |- context[match ?x with _ => _ end] => destruct x eqn:?
      end; try solve [ congruence | eauto | eauto using functional_extensionality ].
    - eapply magic_fold_is_magic; eassumption.
    - eapply magic_fold_respects_relations; eassumption.
  Qed.
End SortedList.
Arguments map : clear implicits.


(*|
#############################################################################
Can one prove an equivalent to ``Forall_inv`` for heterogeneous lists in Coq?
#############################################################################

:Link: https://stackoverflow.com/q/59178484
|*)

(*|
Question
********

Following Adam Chlipala's `definition
<http://adam.chlipala.net/cpdt/html/Cpdt.DataStruct.html#lab57>`__ of
heterogeneous lists, I wanted to define an equivalent of the
``Forall`` function on normal lists. This isn't too difficult, and you
end up with two constructors as usual. Now suppose that I know that a
fact is true about every element of a non-empty list. With normal
lists, I could use ``Forall_inv`` and ``Forall_inv_tail`` to assert
that it's true about the head and tail of the list.

I'd like to prove the equivalent for ``hForall`` as defined below,
starting with the head case. Looking at the source in `Lists/List.v
<https://github.com/coq/coq/blob/master/theories/Lists/List.v>`__, the
proof for normal lists is easy and runs by inversion on ``Forall (a ::
l)``. The equivalent for my ``hForall`` gives a mess of dependent
variables. Am I missing something obvious?
|*)

Require Import List.

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons {a : A} {ls : list A} : B a -> hlist ls -> hlist (a :: ls).

  Section hForall.
    Variable P : forall a : A, B a -> Prop.

    Inductive hForall : forall {As : list A}, hlist As -> Prop :=
    | hForall_nil : hForall HNil
    | hForall_cons {a : A} {ls : list A} (x : B a) (hl : hlist ls)
      : P a x -> hForall hl -> hForall (HCons x hl).

    Lemma hForall_inv (a : A) (ls : list A) (x : B a) (hl : hlist ls)
      : hForall (HCons x hl) -> P a x.
    Proof.
      (* Help! *)
    Abort.
  End hForall.
End hlist.

(*|
Answer
******

Inductives indexed by indexed types lead to that kind of difficulty.

Alternatively, consider defining ``hForall`` as a ``Fixpoint``. Then
the inversion lemma follows by just unfolding the definition.
|*)

Reset hlist. (* .none *)
Section hForall'.

  Variable P : forall a, B a -> Prop.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons {a : A} {ls : list A} : B a -> hlist ls -> hlist (a :: ls).

  Fixpoint hForall' {As : list A} (hs : hlist As) : Prop :=
    match hs with
    | HNil => True
    | HCons x js => P _ x /\ hForall' js
    end.

  Lemma hForall'_inv (a : A) (ls : list A) (x : B a) (hl : hlist ls)
    : hForall' (HCons x hl) -> P a x.
  Proof.
    intros []; auto.
  Qed.

End hForall'.

(*|
----

Appendix
========

Mostly for educational purposes, here's a few ways to prove that
inversion lemma for the original inductive definition of ``hForall``
(starting from the simpler to use).

One solution is the ``dependent destruction`` tactic, which also
automatically handles heterogeneous equalities, as opposed to
``destruct``. It is imported from the ``Program`` module:

.. coq:: none
|*)

Variable P : forall a, B a -> Prop.

Inductive hForall : forall {As : list A}, hlist As -> Prop :=
| hForall_nil : hForall HNil
| hForall_cons {a : A} {ls : list A} (x : B a) (hl : hlist ls)
  : P a x -> hForall hl -> hForall (HCons x hl).

(*||*)

Require Import Program.

Lemma hForall_inv (a : A) (ls : list A) (x : B a) (hl : hlist ls)
  : hForall (HCons x hl) -> P a x.
Proof.
  intros H. dependent destruction H. auto.
Qed.

(*|
The (minor) catch is that it uses some axioms about heterogeneous
equality:
|*)

Print Assumptions hForall_inv. (* .unfold *)

(*|
----

With a little more knowledge of how ``destruct`` works/dependent
pattern-matching, here's a proof without axioms.

There are some detailed explanations of dependent pattern-matching in
CPDT, but briefly the issue is that when we do
``destruct``/``inversion`` on ``hForall (HCons x hl)``, the index
``HCons x hl`` gets generalized before the case-split, so you get a
nonsensical case where it is replaced with ``HNil``, and a second case
with a *different* index ``HCons x0 hl0``, and a good way of
remembering the (heterogeneous) equality across that generalization is
a research-grade problem. You wouldn't need to mess with heterogeneous
equalities if the goal just got rewritten with those variables, and
indeed you can refactor the goal so that it explicitly depends on
``HCons x hl``, instead of ``x`` and ``hl`` separately, which will
then be generalized by ``destruct``:
|*)

Lemma hForall_inv' (a : A) (ls : list A) (x : B a) (hl : hlist ls) :
  hForall (HCons x hl) -> P a x.
Proof.
  intros H.
  change (match HCons x hl return Prop with
          (* for some reason you have to explicitly annotate the
             return type as Prop right here *)
          | HNil => True
          | HCons x _ => P _ x
          end).
      destruct H.
  - exact I.
  (* Replace [HCons x hl] with [HNil], the goal reduces to [True].
     (This is an unreachable case.) *)
  - assumption.

  (* Or, directly writing down the proof term. *)
  Restart.
  intros H.
  refine (match H in @hForall As hs return
                match hs return Prop with
                | HNil => True
                | HCons x _ => P _ x
                end
          with
          | hForall_nil => I
          | hForall_cons _ _ _ _ => _
          end).
  assumption.
Qed.

(*|
The Equations plugin probably automates that properly, but I haven't
tried.
|*)


Require Export List. Export ListNotations.
Require Export ZArith.
Local Open Scope Z_scope.
Require Export compcert.lib.Integers.
Require Export VST.zlist.sublist.

Definition Nk := 8. (* number of words in key *)
Definition Nr := 14. (* number of cipher rounds *)
Definition Nb := 4. (* number of words in a block (state) *)

(* arr: list of 4 bytes *)
Definition get_uint32_le (arr: list Z) (i: Z) : int :=
 (Int.or (Int.or (Int.or
            (Int.repr (Znth  i    arr))
   (Int.shl (Int.repr (Znth (i+1) arr)) (Int.repr  8)))
   (Int.shl (Int.repr (Znth (i+2) arr)) (Int.repr 16)))
   (Int.shl (Int.repr (Znth (i+3) arr)) (Int.repr 24))).

(* outputs a list of 4 bytes *)
Definition put_uint32_le (x : int) : list int :=
  [ (Int.and           x                (Int.repr 255));
    (Int.and (Int.shru x (Int.repr  8)) (Int.repr 255));
    (Int.and (Int.shru x (Int.repr 16)) (Int.repr 255));
    (Int.and (Int.shru x (Int.repr 24)) (Int.repr 255)) ].

Definition byte0 (x : int) : Z :=
  (Z.land (Int.unsigned x) (Int.unsigned (Int.repr 255))).
Definition byte1 (x : int) : Z :=
  (Z.land (Int.unsigned (Int.shru x (Int.repr 8))) (Int.unsigned (Int.repr 255))).
Definition byte2 (x : int) : Z :=
  (Z.land (Int.unsigned (Int.shru x (Int.repr 16))) (Int.unsigned (Int.repr 255))).
Definition byte3 (x : int) : Z :=
  (Z.land (Int.unsigned (Int.shru x (Int.repr 24))) (Int.unsigned (Int.repr 255))).


(** * Introduction

    Programming is a hard task, and writing correct programs is even harder, as
    any person having tried to write one can attest. A few factors contribute to
    this state of affairs.

    First, in order to write a correct program, we must first understand what
    "correct" means -- that is, what a particular program is supposed to
    do. Unfortunately, interesting programs have complex specifications, which
    are almost never stated completely. If we don't have a clear idea of what
    the purpose of a program is, it is less likely that we will be able to write
    a correct implementation.

    Second, even with a complete, precise specification in hand, it is not easy
    to see whether an implementation conforms to it. Programmers convince
    themselves of this by using the program in controlled trials, by running
    extensive testing, or with tool support. These techniques can lead to a
    dramatic increase in software quality, but often fail to detect subtle
    mistakes that end up appearing after the program is deployed.

    Many tools and methodologies have been introduced to try to solve these two
    problems. Among those, we can mention a particularly interesting class:
    _proof assistants_. Proof assistants allow programmers to write spefications
    and connect them to programs via _machine-checked proofs_. If a programmer
    can formulate a logically sound argument for why their program is correct,
    the proof assistant will agree and tell them so. Otherwise, if the argument
    contains any flaws, the proof assistant will notice it and report to the
    programmer.

    This document is an introduction to Coq, a powerful proof assistant. Coq
    comes with a rich language for writing programs, specifications, and
    mathematical concepts, and connecting them with formal proofs. Coq has been
    successfully applied to the verification of complex programs, including
    compilers and operating systems, and also used to formalize important
    mathematical results, such as the four-color theorem or the odd-order
    theorem.

    Coq is a complex system that includes many features, and the Coq community
    has developed many styles for using it. In this introduction, we will focus
    on _ssreflect_, a Coq library that has its own set of best practices.

    * First Steps

    Users write Coq code interactively within specialized programming
    environments. Among those, the most widely used are _CoqIDE_, a stand-alone
    editor that is part of the official Coq distribution, and _Proof General_,
    an Emacs plugin. We will assume that you have access to such an environment
    for running examples and doing exercises. To test whether your environment
    is working, try opening this file and hitting the "Next Step" button on the
    menu bar; your environment should change, telling you that it started Coq
    and highlight a region of the file.

    This highlighted region indicates what part of the file has been processed
    and accepted by Coq so far. We can use the "Next Step" command to tell Coq
    to try to advance to the next code fragment; in Proof General, this is done
    with the [C-c C-n] key combination, or by pressing the corresponding button
    on the top bar. We can also tell Coq to go back on the file, allowing us to
    edit parts of the file that are currently highlighted. In Proof General,
    this is done with the [C-n C-p] key combination. It is also possible to try
    to jump to an arbitrary point in the file (in Proof General, by placing the
    cursor at that point and hitting [C-n C-RET]), and to ask Coq to check the
    entire file ([C-n C-b] in Proof General). Try to play with these commands a
    little bit to familiarize yourself with the environment.

    The next line imports ssreflect libraries that we use in this file. *)

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype.

(** (If you encounter warning messages when importing these files, don't worry:
    they are probably harmless. Ssreflect redefines some of the basic Coq
    definitions, which sometimes causes Coq to print warnings.)

    * Defining a Data Type

    In this chapter, we introduce the most basic features of Coq with a simple
    case study: using _binary search trees_ to represent sets of numbers.
    First, we define a Coq data type of binary search trees: *)

Inductive tree : Type :=
| Leaf
| Node of tree & nat & tree.

(** This command declares a new type [tree] with two kinds of values: a value
    can be either [Leaf], which represents an empty tree, or of the form [Node
    t1 n t2], which represents a nonempty tree that stores a natural number [n]
    at its root and has two subtrees, [t1] and [t2].

    If you are familiar with functional programming languages, such as Haskell,
    OCaml, or Scala, it might help to know that the [Inductive] command is very
    similar to how we define data types in those languages.  In any case, it is
    worth analyzing this definition in some more detail.  In Coq, we call [Leaf]
    and [Node] the _constructors_ of the [tree] type.  A type declaration such
    as the one above can have as many constructors as we want, each listed after
    a vertical bar ([|]).  We see that there are two kinds of constructors:
    those that take arguments and those that don't.  The [Leaf] constructor does
    not take any arguments; we can use it directly to create a [tree] value.
    For instance: *)

Definition empty_tree : tree :=
  Leaf.

(** This command declares a new constant [empty_tree] of type [tree] that is
    defined as [Leaf].  (Note that Coq commands usually begin with an uppercase
    letter and are terminated by a period ([.]).)

    If we want to define a nonempty tree, we must apply the [Node] constructor
    to some arguments: *)

Definition nonempty_tree : tree :=
  Node Leaf 0 Leaf.

(** When Coq sees a list of expressions separated by white space, it understands
    that the first one is a function, and that the others are arguments to that
    function.  Note that the second argument, [0], is a value of the predefined
    [nat] representing natural numbers (non-negative integers). Thus, this
    definition represents a nonempty tree that stores [0] at its root and has
    empty children.

    Coq is a _typed_ language, and it always checks expressions to ensure that
    everything make sense.  For instance, the definition of [tree] says the
    second argument of [Node] must be an element of [nat].  When Coq sees
    anything that does not match what it expects, it complains: *)

Fail Definition nonempty_tree_wrong : tree :=
  Node Leaf Leaf Leaf.

(** (The [Fail] keyword allows us to enter commands that cause errors; Coq
    simply ignores them.)

    We can also combine previous definitions to write new ones: *)

Definition nonempty_tree' : tree :=
  Node nonempty_tree 0 empty_tree.

(** * Functions

    Like in other programming languages, we can define functions in Coq.  The
    following function checks whether a tree is empty. *)

Definition is_empty (t : tree) : bool :=
  match t with
  | Leaf         => true
  | Node t1 n t2 => false
  end.

(** This code says that [is_empty] takes one argument [t] of type [tree] and
    returns a Boolean. (The type [bool] of Booleans is already defined for us in
    Coq.) The body of the function analyzes the possible shapes that [t] can
    have using the [match] expression. Each clause after a [|] sign is called a
    _branch_, and describes the value of the expression when [t] has the
    corresponding shape; [t] is known as the _scrutinee_. Paraphrasing this
    definition, if [t] is a [Leaf], the function returns [true]; otherwise, if
    it is a [Node], it returns [false].  In Coq, every function that we write
    must be _total_; that is, defined for all inputs.  This means that the
    branches of a [match] must cover every possible shape that [t] may have.
    Since [tree] was defined with two constructors, these two branches already
    cover all cases.  Had we omitted one of them, Coq would complain. *)

Fail Definition is_empty_wrong (t : tree) : bool :=
  match t with
  | Leaf => true
  end.

(** Note that in the [Node] branch of [is_empty] we were able to give names to
    the of the constructor.  These names can be used in the return value, as in
    the next function, which returns the left child of a nonempty tree, or
    [Leaf] if the tree is empty: *)

Definition left_child (t : tree) : tree :=
  match t with
  | Leaf       => Leaf
  | Node t _ _ => t
  end.

(** As this example shows, when an argument to a function or to a [match] branch
    is not used, we can name it [_] instead. *)

(** ** Exercises

    Based on [left_child], write a [right_child] that extracts the right child
    of a tree. *)

(** We can test the behavior of Coq functions using the [Compute] command.  It
    simply takes a Coq expression as input and prints the result of fully
    evaluating it. *)

Compute is_empty empty_tree.
Compute is_empty nonempty_tree.
Compute left_child nonempty_tree.
Compute left_child nonempty_tree'.

(** We can also write functions of multiple arguments, and analyze multiple
    scrutinees in a single [match]: *)

Definition are_both_empty (t1 : tree) (t2 : tree) : bool :=
  match t1, t2 with
  | Leaf, Leaf => true
  | _   , _    => false
  end.

(** This last example shows that a branch can cover multiple constructors. When
    we give [_] instead of a constructor name, Coq understands that that branch
    corresponds to any cases that are not covered by the previous ones; here,
    those would be the ones where at least one of the trees is a [Node].  We can
    check that this function has the expected behavior: *)

Compute are_both_empty Leaf Leaf.
Compute are_both_empty Leaf nonempty_tree.

(** As a shorthand, when consecutive arguments of a function have the same type,
    we can group them together, like this: *)

Definition are_both_empty' (t1 t2 : tree) : bool :=
  match t1, t2 with
  | Leaf, Leaf => true
  | _   , _    => false
  end.

(** We saw earlier that Coq is a typed language, and that it rejects definitions
    that do not follow its typing rules.  Functions, like anything else, also
    have types.  We can query their types with the [Check] command, like this: *)

Check is_empty.
Check are_both_empty.

(** (It is usually preferable to avoid including [Check] commands in Coq files,
    since they only make sense interactively; we add them here for explanation
    purposes. You can avoid writing [Check] when using Coq interactively by
    issuing the appropriate command in your Coq environment. In Proof General,
    for instance, you can hit [C-c C-a C-c].)

    Types to the left of an arrow ([->]) specify the types of the arguments that
    a function expects; the right-most type is the return type.  The type of
    [is_empty], [tree -> bool], shows that that function expects one argument of
    type [tree] and produces a result of type [bool].  The type of
    [are_both_empty], [tree -> tree -> bool], shows that that function expects
    two arguments of type [tree] and produces a result of type [bool].

    Note that data-type constructors that take arguments are just another
    instance of functions, and are treated as such by Coq.  For instance, the
    type of [Node] is [tree -> nat -> tree -> tree], reflecting the arguments it
    takes and the result it produces; try checking it yourself!

    * Preexisting Definitions

    Before moving on to more interesting definitions, it is worth spending some
    time overviewing basic ones that are already provided by Coq.  Besides types
    such as [nat] and [bool], there are also many predefined functions on those
    types.  The [addn] function, as its name says, adds two natural numbers: *)

Check addn.
Compute addn 3 4.

(** Coq provides convenient infix syntax for such operators; the expression [n +
    m] is just a shorthand for [addn n m].  It is also possible to define our
    own custom notations in Coq, although we will defer this discussion for
    later. *)

Check 3 + 4.
Compute 3 + 4.

(** Other operations include subtraction ([subn]), and multiplication ([muln]),
    each with its own infix notation.  Note that subtraction on natural numbers
    is _truncated_: [n - m] equals [0] whenever [m] is greater than [n]. *)

Compute 4 - 3.
Compute 3 - 4.
Compute 3 * 4.

(** The [leq] function tests if its first argument is smaller than or equal to
    its second argument; the corresponding infix notation is [<=].  To test
    numbers for equality, we use [eq_op] (infix [==]). *)

Compute 3 <= 4.
Compute 4 <= 3.
Compute 4 == 4.
Compute 3 == 4.

(** If we ask Coq for the types of these operators, the answers we get are
    mostly unsurprising.  For instance, [addn] has type [nat -> nat -> nat]. *)

Check addn.

(** The exception to the rule is [eq_op]: Coq tells us that it has type [rel
    ?T], where [?T : eqType].  Although puzzling, this simply means that [eq_op]
    is a _polymorphic_ operator that can be used with any type that is provided
    with an equality test.  Basic types such as [nat] or [bool] already have
    predefined equality tests, so we don't have to worry about this; later, we
    will discuss how polymorphism works in Coq and how to define equality
    operators for our own types.

    For Booleans, besides equality testing, we also have the basic logic
    operations: [andb] ([&&]), [orb] ([||]), and [negb] ([~~], used in prefix
    form).  We can combine these operations to express complex conditions. *)

Compute (3 <= 4) && ~~ (4 == 5).
Compute (4 != 5). (* An abbreviation for [~~ (4 == 5)]. *)
Compute false || (3 + 4 <= 8).

(** For instance, here is an alternative definition of the [are_both_empty]
    function we saw previously. *)

Definition are_both_empty'' (t1 t2 : tree) : bool :=
  is_empty t1 && is_empty t2.

(** We can perform case analysis on a Boolean with the familiar if-then-else
    syntax: *)

Compute if true then 1 else 2.

(** This form is just a shorthand to an explicit [match]: *)

Compute match true with true => 1 | false => 2 end.

(** * Recursive Functions

    To write interesting programs, we often need to perform some form of
    iteration; in Coq, this is done using _recursion_, as in most functional
    programming languages.  We define recursive functions using the [Fixpoint]
    command.  It is similar to [Definition], except that we are allowed to make
    recursive calls inside the function we define.  Here is a first example: a
    recursive function that computes the size of a tree. *)

Fixpoint tsize (t : tree) : nat :=
  match t with
  | Leaf         => 0
  | Node t1 _ t2 => tsize t1 + 1 + tsize t2
  end.

(** We can test that our function works as expected: *)

Compute tsize empty_tree.
Compute tsize nonempty_tree.
Compute tsize (Node Leaf 0 nonempty_tree).

(** Here is another example: a function that mirrors a binary tree, swapping its
    left and right children. *)

Fixpoint tmirror (t : tree) : tree :=
  match t with
  | Leaf         => Leaf
  | Node t1 n t2 => Node (tmirror t2) n (tmirror t1)
  end.

(** Recursive functions in Coq work almost the same as in other languages, with
    one important caveat: since every function needs to be total, Coq only
    accepts recursive functions that terminate on all inputs.  Of course,
    computability theory tells us that no computer program can determine without
    error whether an arbitrary function terminates or not, so Coq must
    approximate that somehow.  What it does is that it checks that functions are
    only called recursively on _subterms_ of one of its arguments -- arguments
    that appear in the branch of a [match] that have the same type.  For
    instance, in the recursive functions above, the only recursive calls are
    those performed on the [t1] and [t2] children of [t].  This criterion is
    enough to guarantee that functions terminate, but it is far from complete:
    there are many terminating functions that Coq fails to recognize as such
    because they don't fit this criterion.  For instance, consider the following
    alternative implementation of [tsize]: *)

Fail Fixpoint tsize' (t : tree) : nat :=
  match t with
  | Leaf         => 0
  | Node t1 _ t2 => tsize' (tmirror t1) + 1 + tsize' (tmirror t2)
  end.

(** Intuitively, the definition of [tsize'] is safe because it is only called
    recursively on arguments with a strictly smaller height.  Unfortunately,
    Coq's termination checker is not powerful enough to realize this, and
    rejects it because [tmirror t1] is not a subterm of [t].  This is an
    admittedly artificial example, since nobody would implement [tsize] in this
    way, but it's good for understanding the limitations of the programs we can
    write in Coq.

    ** Exercises

    Write a [theight] function that computes the height of a binary tree.  You
    may want to use the [maxn] function, which computes the maximum of two
    numbers. *)


Set Implicit Arguments.

Require Import Bedrock.Platform.Cito.Syntax.

Require Import Bedrock.Platform.Cito.FreeVarsExpr.

Require Import Bedrock.Platform.Cito.Option.
Require Import Coq.Strings.String.
Local Open Scope string_scope.

Require Import Coq.Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import Bedrock.StringSet.
Import StringSet.
Require Import Bedrock.Platform.Cito.StringSetFacts.
Import FSetNotations.
Import FSetNotationsTrial.
Local Open Scope fset_scope.

Coercion string2elt (x : string) : elt := x.
Coercion singleton : elt >-> t.

Fixpoint inits stmt : StringSet.t :=
  match stmt with
    | Assign x _ => x
    | Label x _ => x
    | Seq a b => inits a + inits b
    | Skip => []
    | Syntax.If _ t f => inits t * inits f
    | While _ _ => []
    | Syntax.Call x _ _ => default empty (option_map singleton x)
  end.

Fixpoint uninited_reads inited stmt :=
  match stmt with
    | Assign _ e => free_vars e - inited
    | Label _ _ => []
    | Seq a b => uninited_reads inited a + uninited_reads (inited + inits a) b
    | Skip => []
    | Syntax.If e t f => (free_vars e - inited) + uninited_reads inited t + uninited_reads inited f
    | While e s => (free_vars e - inited) + uninited_reads inited s
    | Syntax.Call _ f args => List.fold_left (fun acc e => free_vars e - inited + acc) args (free_vars f - inited)
  end.

Require Import Bedrock.Platform.Cito.FuncCore.

Local Open Scope bool_scope.

Definition is_no_uninited_reads (f : FuncCore) := is_empty (uninited_reads (of_list (ArgVars f)) (Body f)).

Definition is_no_uninited (f : FuncCore) := is_no_uninited_reads f && mem (RetVar f) (inits (Body f)).


From logrel_heaplang_sessions Require Export lty ltyping.
From iris.heap_lang Require Export lifting metatheory.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import notation proofmode.

Section types.
  Context `{heapG Σ}.

  Definition lty_forall (C : lty Σ → lty Σ) : lty Σ := Lty (λ w,
    ∀ A : lty Σ, WP w #() {{ w, C A w }})%I.
End types.

Notation "∀ A1 .. An , C" :=
  (lty_forall (λ A1, .. (lty_forall (λ An, C%lty)) ..)) : lty_scope.

Section properties.
  Context `{heapG Σ}.

  Global Instance lty_forall_ne n : Proper (pointwise_relation _ (dist n) ==> dist n) (@lty_forall Σ _).
  Proof. solve_proper. Qed.

  Global Instance lty_forall_contractive n : Proper (pointwise_relation _ (dist_later n) ==> dist n) (@lty_forall Σ _).
  Proof.
    intros F F' A.
    apply lty_ne.
    intros w.
    f_equiv.
    intros B.
    apply wp_contractive.
    { done. }
    intros u.
    specialize (A B).
    destruct n as [|n].
    + done.
    + by simpl.
  Qed.

  Lemma ltyped_tlam Γ e C :
    (∀ A, Γ ⊨ e : C A) → Γ ⊨ (λ: <>, e) : ∀ A, C A.
  Proof.
    intros He. iIntros (vs) "HΓ /=". wp_pures.
    iIntros (A) "/=". wp_pures.
    iPoseProof He as "He".
    iSpecialize ("He" $! vs with "HΓ").
    wp_apply (wp_wand with "He").
    iIntros (v) "H". eauto.
  Qed.

  Lemma ltyped_tapp Γ e C A :
    (Γ ⊨ e : ∀ A, C A) → Γ ⊨ e #() : C A.
  Proof.
    intros He. iIntros (vs) "HΓ /=".
    iPoseProof He as "He".
    wp_apply (wp_wand with "(He [HΓ //])"); iIntros (w) "HB". by iApply ("HB" $! A).
  Qed.

End properties.