Require Import Omega.
Require Import Bool.

Require Import mxx.
Require Import typesystem.

Definition obj_dec : forall (o1 o2 : obj), {o1 = o2} + {o1 <> o2}.
Proof.
decide equality.
apply eq_nat_dec.
Defined.

Definition class_dec : forall (c1 c2 : class), {c1 = c2} + {c1 <> c2}.
Proof.
decide equality.
Defined.

Definition cobj_dec : obj -> option class := fix f o :=
  match o with
  | KStar | KOne => Some CKind
  | KProd k1 k2 =>
      match f k1, f k2 with
        | Some CKind, Some CKind => Some CKind
        | _, _ => None
      end
  | KRes k p =>
      match f k, f p with
        | Some CKind, Some CProp => Some CKind
        | _, _ => None
      end
  | TVar _ | TOne | TVoid | TBot | TTop | TUnit => Some CType
  | TMu t | TFst t | TSnd t =>
      match f t with
        | Some CType => Some CType
        | _ => None
      end
  | TArr t s | TProd t s | TSum t s | TPair t s =>
      match f t, f s with
        | Some CType, Some CType => Some CType
        | _, _ => None
      end
  | TFor k t | TPi k t =>
      match f k, f t with
        | Some CKind, Some CType => Some CType
        | _, _ => None
      end
  | PTrue => Some CProp
  | PAnd p1 p2 =>
      match f p1, f p2 with
        | Some CProp, Some CProp => Some CProp
        | _, _ => None
      end
  | PCoer H t s =>
      match f H, f t, f s with
        | Some CTEnv, Some CType, Some CType => Some CProp
        | _, _, _ => None
      end
  | PExi k =>
      match f k with
        | Some CKind => Some CProp
        | _ => None
      end
  | PFor k p =>
      match f k, f p with
        | Some CKind, Some CProp => Some CProp
        | _, _ => None
      end
  | HNil => Some CTEnv
  | HCons H k =>
      match f H, f k with
        | Some CTEnv, Some CKind => Some CTEnv
        | _, _ => None
      end
  | YNil => Some CPEnv
  | YCons Y p =>
      match f Y, f p with
        | Some CPEnv, Some CProp => Some CPEnv
        | _, _ => None
      end
  | GNil => Some CAEnv
  | GCons G t =>
      match f G, f t with
        | Some CAEnv, Some CType => Some CAEnv
        | _, _ => None
      end
  end.

Lemma cobj_dec_cobj : forall o c, cobj_dec o = Some c <-> cobj o c.
Proof.
intros; split; intros H.
(* -> *)
  generalize c H; clear c H.
  induction o; simpl; intros c H; repeat
  match goal with
    | H : Some _ = Some _ |- _ => inversion H; clear H; subst
    | H : match ?x with _ => _ end = _ |- _ =>
        destruct x; try solve [inversion H]
  end; auto using cobj.
(* <- *)
  induction H; simpl; repeat
  match goal with
    | H : ?x = ?y |- match ?x with _ => _ end = _ =>
        rewrite H
  end; auto.
Qed.

Definition get_cobj : forall o, option (sigT (cobj o)).
Proof.
intros o.
remember (cobj_dec o) as e.
destruct e as [c|]; [apply Some|exact None].
apply (existT _ c).
apply cobj_dec_cobj.
apply eq_sym; assumption.
Defined.

Definition Hnth_dec : tenv -> nat -> option kind := fix f H a :=
  match a with
    | O =>
      match H with
        | HCons _ k => Some k
        | HNil => Some KOne
        | _ => None
      end
    | S a =>
      match H with
        | HCons H _ => f H a
        | HNil => Some KOne
        | _ => None
      end
  end.

Lemma Hnth_dec_Hnth : forall H a k, Hnth_dec H a = Some k <-> Hnth H a k.
Proof.
intros; split; intros Ha.
(* -> *)
  generalize H k Ha; clear H k Ha.
  induction a; simpl; intros H k Ha;
  destruct H; simpl in Ha; repeat
  match goal with
    | H : Some _ = Some _ |- _ => inversion H; clear H; subst
    | H : None = Some _ |- _ => solve [inversion H]
  end; auto using Hnth.
(* <- *)
  induction Ha; simpl; auto.
  destruct n; reflexivity.
Qed.

Definition get_Hnth : forall H a, option (sigT (Hnth H a)).
Proof.
intros H a.
remember (Hnth_dec H a) as e.
destruct e as [k|]; [apply Some|exact None].
apply (existT _ k).
apply Hnth_dec_Hnth.
apply eq_sym; assumption.
Defined.

Definition Gnth_dec : aenv -> nat -> option type := fix f G x :=
  match x with
    | O =>
      match G with
        | GCons _ t => Some t
        | GNil => Some TTop
        | _ => None
      end
    | S x =>
      match G with
        | GCons G _ => f G x
        | GNil => Some TTop
        | _ => None
      end
  end.

Lemma Gnth_dec_Gnth : forall G x t, Gnth_dec G x = Some t <-> Gnth G x t.
Proof.
intros; split; intros Hx.
(* -> *)
  generalize G t Hx; clear G t Hx.
  induction x; simpl; intros G t Hx;
  destruct G; simpl in Hx; repeat
  match goal with
    | H : Some _ = Some _ |- _ => inversion H; clear H; subst
    | H : None = Some _ |- _ => solve [inversion H]
  end; auto using Gnth.
(* <- *)
  induction Hx; simpl; auto.
  destruct n; reflexivity.
Qed.

Definition get_Gnth : forall G x, option (sigT (Gnth G x)).
Proof.
intros G x.
remember (Gnth_dec G x) as e.
destruct e as [t|]; [apply Some|exact None].
apply (existT _ t).
apply Gnth_dec_Gnth.
apply eq_sym; assumption.
Defined.

Definition is_free := fix f a o :=
  (match o with
  | KStar | KOne => true
  | KProd k1 k2 => f a k1 && f a k2
  | KRes k p => f a k && f (1 + a) p
  | TVar b => negb (beq_nat a b)
  | TOne | TVoid | TBot | TTop | TUnit => true
  | TMu t => f (1 + a) t
  | TFst t | TSnd t => f a t
  | TArr t s | TProd t s | TSum t s | TPair t s => f a t && f a s
  | TFor k t | TPi k t => f a k && f (1 + a) t
  | PTrue => true
  | PAnd p1 p2 => f a p1 && f a p2
  | PCoer H t s => f a H && f (Hlength H + a) t && f a s
  | PExi k => f a k
  | PFor k p => f a k && f (1 + a) p
  | HNil => true
  | HCons H k => f a H && f (Hlength H + a) k
  | YNil => true
  | YCons Y p => f a Y && f a p
  | GNil => true
  | GCons G t => f a G && f a t
  end)%bool.

Lemma is_free_sound : forall a o, is_free a o = true -> exists o', o = shift a o'.
Proof.
intros a o.
generalize a; clear a.
induction o; intros a Heq; inversion Heq; clear Heq; subst;
repeat match goal with
  | H : ?x && ?y = true |- _ => destruct (proj1 (andb_true_iff x y) H); clear H
  | IH : forall a, is_free a ?o = true -> _ , H : is_free ?a ?o = true |- _ =>
    destruct (IH a H); clear IH; subst o
end.
exists KStar; reflexivity.
exists KOne; reflexivity.
exists (KProd x0 x); reflexivity.
exists (KRes x0 x); reflexivity.
{ apply eq_sym, negb_sym, beq_nat_false_iff in H0.
  destruct (lt_eq_lt_dec a x) as [[?|?]|?]; [|exfalso; omega|].
  - destruct x; [inversion l|].
    exists (TVar x); simpl; subst_lift_var.
  - exists (TVar x); simpl; subst_lift_var. }
exists (TArr x0 x); reflexivity.
exists TOne; reflexivity.
exists (TProd x0 x); reflexivity.
exists TVoid; reflexivity.
exists (TSum x0 x); reflexivity.
exists (TFor x0 x); reflexivity.
exists (TPi x0 x); reflexivity.
exists (TMu x); reflexivity.
exists TBot; reflexivity.
exists TTop; reflexivity.
exists TUnit; reflexivity.
exists (TPair x0 x); reflexivity.
exists (TFst x); reflexivity.
exists (TSnd x); reflexivity.
exists PTrue; reflexivity.
exists (PAnd x0 x); reflexivity.
exists (PCoer x0 x x1); simpl; unfold shift; rewrite Hlength_lift; reflexivity.
exists (PExi x); reflexivity.
exists (PFor x0 x); reflexivity.
exists HNil; reflexivity.
exists (HCons x0 x); simpl; unfold shift; rewrite Hlength_lift; reflexivity.
exists YNil; reflexivity.
exists (YCons x0 x); reflexivity.
exists GNil; reflexivity.
exists (GCons x0 x); reflexivity.
Qed.

Definition jrec_dec : nat -> type -> recsort -> bool := fix f a t rec :=
  (match t with
  | TVar b => is_free a t ||
      match rec with
        | NE => true
        | WF => false
      end
  | TBot | TTop => true
  | TArr t s | TProd t s | TSum t s => f a t NE && f a s NE
  | TMu t => f (1 + a) t rec && f 0 t WF
  | TFor k t => is_free a k && f (1 + a) t rec
  | TPi k t => is_free a k && f (1 + a) t NE
  | _ => false
  end)%bool.

Lemma jrec_dec_jrec : forall a t rec, jrec_dec a t rec = true -> jrec a t rec.
Proof.
intros a t.
generalize a; clear a.
induction t; intros a rec Heq; inversion Heq; clear Heq; subst;
repeat match goal with
  | H : ?x && ?y = true |- _ => destruct (proj1 (andb_true_iff x y) H); clear H
end.
{ remember (negb (beq_nat a x)) as e; apply eq_sym in Heqe.
  destruct e.
  { destruct (is_free_sound a (TVar x) Heqe) as [w ?].
    destruct rec; [|apply RECne]; apply RECwf with w; auto. }
  destruct rec; inversion H0; clear H0.
  apply eq_sym, negb_sym, beq_nat_true_iff in Heqe; subst.
  apply RECVar. }
destruct rec; [|apply RECne]; apply RECArr; auto.
destruct rec; [|apply RECne]; apply RECProd; auto.
destruct rec; [|apply RECne]; apply RECSum; auto.
destruct (is_free_sound _ _ H) as [w ?]; apply RECFor with w; auto.
destruct rec; [|apply RECne]; destruct (is_free_sound _ _ H) as [w ?]; apply RECPi with w; auto.
apply RECMu; auto.
destruct rec; [|apply RECne]; apply RECwf with TBot; auto.
destruct rec; [|apply RECne]; apply RECwf with TTop; auto.
Qed.

Definition get_jrec a t rec : option (jrec a t rec) :=
  match jrec_dec a t rec return _ with
    | true => fun Heq => Some (jrec_dec_jrec a t rec Heq)
    | false => fun _ => None
  end eq_refl.

(* Definition rmin r1 r2 := *)
(*   match r1, r2 with *)
(*     | NE, _ | _, NE => NE *)
(*     | _, _ => WF *)
(*   end. *)

(* Definition rinc (r : recsort) := WF. *)

(* Definition jrec_dec : nat -> type -> option recsort := fix f a t := *)
(*   match t with *)
(*     | TVar b => if beq_nat a b then Some NE else Some CST *)
(*     | TArr t s | TProd t s | TSum t s => *)
(*         match f a t, f a s with *)
(*           | Some r1, Some r2 => Some (rinc (rmin r1 r2)) *)
(*           | _, _ => None *)
(*         end *)
(*     | TFor k t => *)
(*         match f a k, f (1 + a) t with *)
(*           | Some CST, Some rec => Some rec *)
(*           | _, _ => None *)
(*         end *)
(*     | TPi k t => *)
(*         match f a k, f (1 + a) t with *)
(*           | Some CST, Some r => Some (rinc r) *)
(*           | _, _ => None *)
(*         end *)
(*     | TMu t => *)
(*         match f 0 t, f (1 + a) t with *)
(*           | Some WF, Some rec => Some rec *)
(*           | _, _ => None *)
(*         end *)
(*     | _ => None *)
(*   end. *)

(* Definition le_recsort r1 r2 := *)
(*   match r1, r2 with *)
(*     | CST, _ => True *)
(*     | WF, CST => False *)
(*     | WF, _ => True *)
(*     | NE, NE => True *)
(*     | NE, _ => False *)
(*   end. *)
(* Hint Unfold le_recsort. *)

(* Lemma jrec_le : forall a t r1 r2, le_recsort r1 r2 -> jrec a t r1 -> jrec a t r2. *)
(* Proof. *)
(* intros; destruct r1; destruct r2; auto using RECne, RECwf; inversion H. *)
(* Qed. *)

(* Lemma jrec_NE : forall a t r, jrec a t r -> jrec a t NE. *)
(* Proof. *)
(* intros; apply (jrec_le a t r NE); auto. *)
(* destruct r; auto. *)
(* Qed. *)

(* Lemma jrec_dec_dir : forall t a rec, jrec_dec a t = Some rec -> jrec a t rec. *)
(* Proof. *)
(* induction t; simpl; intros a rec H; repeat *)
(* match goal with *)
(*   | |- jrec _ (TVar _) _ => fail 1 *)
(*   | |- jrec _ (TMu _) _ => fail 1 *)
(*   | H : None = Some _ |- _ => inversion H *)
(*   | H : Some _ = Some _ |- _ => inversion H; clear H; subst *)
(*   | H1 : match jrec_dec ?a ?t with _ => _ end = _ *)
(*   , H2 : forall _ _, jrec_dec _ ?t = _ -> _ |- _ => *)
(*       pose proof (H2 a); clear H2; *)
(*       destruct (jrec_dec a t); try solve [inversion H] *)
(*   | H : forall rec, Some ?r = Some rec -> _ |- _ => *)
(*       pose proof (H r eq_refl); clear H *)
(*   | H : match ?x with _ => _ end = _ |- _ => *)
(*       destruct x; try solve [inversion H] *)
(* end. *)
(* (* 7: TVar *) *)
(*   remember (beq_nat a x) as y. *)
(*   destruct y; inversion H; clear H; subst. *)
(*   (* +1: a = x *) *)
(*     pose proof (beq_nat_true a x (eq_sym Heqy)); subst. *)
(*     apply RECVar. *)
(*   (* +0: a <> x *) *)
(*     pose proof (beq_nat_false a x (eq_sym Heqy)). *)
(*     destruct (le_gt_dec a x). *)
(*     (* +1: a < x *) *)
(*       destruct x as [|x]; [exfalso; omega|]. *)
(*       apply RECcst with (TVar x); simpl. *)
(*       subst_lift_var. *)
(*     (* +0: a > x *) *)
(*       apply RECcst with (TVar x); simpl. *)
(*       subst_lift_var. *)
(* (* 6: TArr *) apply RECArr; eapply jrec_NE; eassumption. *)
(* (* 5: TProd *) apply RECProd; eapply jrec_NE; eassumption. *)
(* (* 4: TSum *) apply RECSum; eapply jrec_NE; eassumption. *)
(* (* 3: TFor *) apply RECFor; auto. *)
(* (* 2: TPi *) apply RECPi; [|eapply jrec_NE]; eassumption. *)
(* (* 1: TMu *) *)
(*   pose proof (IHt 0). *)
(*   pose proof (IHt (1 + a) rec); clear IHt. *)
(*   simpl in H1. *)
(*   destruct (jrec_dec 0 t); try solve [inversion H]. *)
(*   destruct r; try solve [inversion H]. *)
(*   destruct (jrec_dec (S a) t); try solve [inversion H]. *)
(*   apply RECMu; auto. *)
(* Qed. *)

(* Lemma jrec_dec_rev : forall t a r2, jrec a t r2 -> *)
(*   exists r1, (forall r, jrec a t r -> le_recsort r1 r) /\ jrec_dec a t = Some r1. *)
(* Proof. *)
(* intros. *)
(* induction H; simpl in *; repeat *)
(* match goal with *)
(*   | H : exists _, _ /\ _ |- _ => destruct H as [? [? ?]] *)
(*   | H : ?x = ?y |- _ => rewrite H *)
(* end. *)
(* (* 10: RECVar *) *)
(*   rewrite <- beq_nat_refl. *)
(*   exists NE; split; auto. *)
(*   intros. *)
(*   destruct r; simpl in H; auto. *)
(*   (* +1: *) *)
(*     inversion H; clear H; subst. *)
(*     destruct s; inversion H0; clear H0. *)
(*     exfalso; destruct (le_gt_dec a x); omega. *)
(*   (* +0: *) *)
(*     inversion H; clear H; subst. *)
(*     inversion H0; clear H0; subst. *)
(*     destruct s; inversion H; clear H. *)
(*     exfalso; destruct (le_gt_dec a x); omega. *)
(* (* 9: RECArr *) *)
(*   exists WF; split; auto. *)
(*   intros. *)
(*   destruct r *)
(* (* 8: RECProd *) exists WF; auto. *)
(* (* 7: RECSum *) exists WF; auto. *)
(* (* 6: RECFor *) *)
(*   exists x. *)
(*   split; auto. *)
(*   destruct x0; auto; inversion H3. *)
(* (* 5: RECPi *) *)
(*   exists WF. *)
(*   split; auto. *)
(*   destruct x0; auto; inversion H3. *)
(* (* 4: RECMu *) *)
(*   destruct x0; inversion H3. *)
(*   exists x. *)
(*   split; auto. *)
(* Qed. *)

(* Definition jeq_norm := fix f o := *)
(*   match o with *)
(*   | KStar => KStar *)
(*   | KOne => KOne *)
(*   | KProd k1 k2 => KProd (f k1) (f k2) *)
(*   | KRes k p => KRes (f k) (f p) *)
(*   | TVar a => TVar a *)
(*   | TArr t s => TArr (f t) (f s) *)
(*   | TProd t s => TProd (f t) (f s) *)
(*   | TSum t s => TSum (f t) (f s) *)
(*   | TFor k t => TFor (f k) (f t) *)
(*   | TPi k t => TPi (f k) (f t) *)
(*   | TMu t => TMu (f t) *)
(*   | TBot => TBot *)
(*   | TTop => TTop *)
(*   | TUnit => TUnit *)
(*   | TPair t s => TPair (f t) (f s) *)
(*   | TFst t => *)
(*       match f t with *)
(*         | TPair t s => t *)
(*         | t => TFst t *)
(*       end *)
(*   | TSnd t => *)
(*       match f t with *)
(*         | TPair t s => s *)
(*         | t => TSnd t *)
(*       end *)
(*   | TPack t => TPack (f t) *)
(*   | TUnpack t => *)
(*       match f t with *)
(*         | TPack t => t *)
(*         | t => TUnpack t *)
(*       end *)
(*   | PTrue => PTrue *)
(*   | PAnd p1 p2 => PAnd (f p1) (f p2) *)
(*   | PCoer H t s => PCoer (f H) (f t) (f s) *)
(*   | PExi k => PExi (f k) *)
(*   | PFor k p => PFor (f k) (f p) *)
(*   | HNil => HNil *)
(*   | HCons H k => HCons (f H) (f k) *)
(*   | YNil => YNil *)
(*   | YCons Y p => YCons (f Y) (f p) *)
(*   | GNil => GNil *)
(*   | GCons G t => GCons (f G) (f t) *)
(*   end. *)


(** * HoareAsLogic: Hoare Logic as a Logic *)

(** The presentation of Hoare logic in chapter [Hoare] could be
    described as "model-theoretic": the proof rules for each of the
    constructors were presented as _theorems_ about the evaluation
    behavior of programs, and proofs of program correctness (validity
    of Hoare triples) were constructed by combining these theorems
    directly in Coq.

    Another way of presenting Hoare logic is to define a completely
    separate proof system -- a set of axioms and inference rules that
    talk about commands, Hoare triples, etc. -- and then say that a
    proof of a Hoare triple is a valid derivation in _that_ logic.  We
    can do this by giving an inductive definition of _valid
    derivations_ in this new logic.

    This chapter is optional.  Before reading it, you'll want to read
    the [ProofObjects] chapter in _Logical
    Foundations_ (_Software Foundations_, volume 1). *)

From PLF Require Import Maps.
From PLF Require Import Imp.
Hint Constructors ceval : core.
From PLF Require Import Hoare.

(* ################################################################# *)
(** * Hoare Logic and Model Theory *)

(** In [Hoare] we introduced Hoare triples, which contain a
    precondition, command, and postcondition.  For example (and for
    the moment deliberately avoiding the notation we previously
    introduced),

      Pre:  X = 0
      Com:  X ::= X + 1
      Post: X = 1

    is a Hoare triple, as is

      Pre:  X = 0
      Com:  skip
      Post: X = 1

    But there's an important difference between those two triples: the
    former expresses a truth about how Imp programs execute, whereas
    the latter does not.

    To capture that difference, we introduced a definition
    [hoare_triple] that described when a triple expresses such a
    truth.  Let's repeat that definition, but this time we'll call it
    [valid]: *)

Definition valid (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st',
     st =[ c ]=> st'  ->
     P st  ->
     Q st'.

(** This notion of _validity_ is based on the underlying model of how
    Imp programs execute.  That model itself is based on states.  So,

      Pre:  X = 0
      Com:  X ::= X + 1
      Post: X = 1

    is _valid_, because starting from any state in which [X] is [0],
    and executing [X ::= X + 1], we are guaranteed to reach a state in
    which [X] is [1]. But,

      Pre:  X = 0
      Com:  skip
      Post: X = 1

    is _invalid_, because starting from any state in which [X] is [0],
    we are guaranteed not to change the state, so [X] cannot be [1].
*)

(** So far, we have punned between the syntax of a Hoare triple,
    written [{{P}} c {{Q}}], and its validity, as expressed by
    [valid].  In essence, we have said that the semantic meaning of
    that syntax is the proposition returned by [valid].  This way of
    giving semantic meaning to something syntactic is part of the
    branch of mathematical logic known as _model theory_.  *)

(** Our approach to Hoare logic through model theory led us to
    state proof rules in terms of that same state-based model, and to
    prove program correctness in it, too.  But there is another
    approach, which is arguably more common in Hoare logic. We turn to
    it, next.  *)

(* ################################################################# *)
(** * Hoare Logic and Proof Theory *)

(** Instead of using states and evaluation as the basis for reasoning,
    let's take the proof rules from [Hoare] as the basis.  Those
    proof rules give us a set of axioms and inference rules that
    constitute a logic in their own right.  We repeat them here: *)

(**

             ----------------  (hoare_skip)
             {{P}} skip {{P}}

             ----------------------------- (hoare_asgn)
             {{Q [X |-> a]}} X ::= a {{Q}}

               {{P}} c1 {{Q}}
               {{Q}} c2 {{R}}
              ------------------  (hoare_seq)
              {{P}} c1;; c2 {{R}}

              {{P /\   b}} c1 {{Q}}
              {{P /\ ~ b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} if b then c1 else c2 end {{Q}}

            {{P /\ b}} c {{P}}
      ----------------------------- (hoare_while)
      {{P} while b do c end {{P /\ ~b}}

                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

(** Read the Hoare triples in those rules as devoid of any
    meaning other than what the rules give them.  Forget about states
    and evaluations.  They are just syntax that the rules tell us how
    to manipulate in legal ways.

    Through this new lens, triple [{{X = 0}} X ::= X + 1 {{X = 1}}]
    is _derivable_, because we can derive a proof tree using the rules:
*)

(**

                 ---------------------------  (hoare_asgn)
X=0 ->> X+1=1    {{X+1=1}} X ::= X+1 {{X=1}}
----------------------------------------------------------  (hoare_consequence)
                  {{X=0}} X ::= X+1 {{X=1}}
*)

(** At each step we have either used one of the rules, or we
    have appealed to reasoning about assertions, which do not involve
    Hoare triples.  (Note that we have left off the trivial part of
    [hoare_consequence] above, namely X=1 ->> X=1, only because of
    horizontal space contraints: it's hard to fit that many characters
    on a line and have the page still be readable.  If you prefer,
    think of it as using [hoare_consequence_pre] instead.)

    On the other hand, [{{X = 0}} skip {{X = 1}}] is _not_ derivable,
    because there is no way to apply the rules to construct a proof
    tree with this triple at its root. *)

(** This approach gives meaning to triples not in terms of a model,
    but in terms of how they can be used to construct proof trees.
    It's a different way of giving semantic meaning to something
    syntactic, and it's part of the branch of mathematical logic known
    as _proof theory_.

    Our goal for the rest of this chapter is to formalize Hoare logic
    using proof theory, and then to prove that the model-theoretic and
    proof-theoretic formalizations are consistent with one another.
*)

(* ################################################################# *)
(** * Derivability *)

(** To formalize derivability of Hoare triples, we introduce inductive type
    [derivable], which describes legal proof trees using the Hoare rules. *)

Inductive derivable : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      derivable P <{skip}> P
  | H_Asgn : forall Q V a,
      derivable (Q [V |-> a]) <{V := a}> Q
  | H_Seq  : forall P c Q d R,
      derivable P c Q -> derivable Q d R -> derivable P <{c;d}> R
  | H_If : forall P Q b c1 c2,
    derivable (fun st => P st /\ bassn b st) c1 Q ->
    derivable (fun st => P st /\ ~(bassn b st)) c2 Q ->
    derivable P <{if b then c1 else c2 end}> Q
  | H_While : forall P b c,
    derivable (fun st => P st /\ bassn b st) c P ->
    derivable P <{while b do c end}> (fun st => P st /\ ~ (bassn b st))
  | H_Consequence  : forall (P Q P' Q' : Assertion) c,
    derivable P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    derivable P c Q.

(** We don't need to include axioms corresponding to
    [hoare_consequence_pre] or [hoare_consequence_post], because these
    can be proven easily from [H_Consequence]. *)

Lemma H_Consequence_pre : forall (P Q P': Assertion) c,
    derivable P' c Q ->
    (forall st, P st -> P' st) ->
    derivable P c Q.
Proof. eauto using H_Consequence. Qed.

Lemma H_Consequence_post  : forall (P Q Q' : Assertion) c,
    derivable P c Q' ->
    (forall st, Q' st -> Q st) ->
    derivable P c Q.
Proof. eauto using H_Consequence. Qed.

(** As an example, let's construct a proof tree for

        {{(X=3) [X |-> X + 2] [X |-> X + 1]}}
      X ::= X + 1;;
      X ::= X + 2
        {{X=3}}
*)

Example sample_proof :
  derivable
    ((fun st:state => st X = 3) [X |-> X + 2] [X |-> X + 1])
    <{ X := X + 1; X := X + 2}>
    (fun st:state => st X = 3).
Proof.
  eapply H_Seq.
  - apply H_Asgn.
  - apply H_Asgn.
Qed.

(** You can see how the structure of the proof script mirrors the structure
    of the proof tree: at the root there is a use of the sequence rule; and
    at the leaves, the assignment rule. *)

(** **** Exercise: 3 stars, standard (provable_true_post)  *)

(** Show that any Hoare triple whose postcondition is [True] is derivable. Proceed
    by induction on [c]. *)

Theorem provable_true_post : forall c P,
    derivable P c True.
Proof.
  intros.
  generalize dependent P.
  induction c; intros.
  - (* skip *)
    eapply H_Consequence_post; constructor; auto.
  - (* ass *)
    eapply H_Consequence_pre; constructor; auto.
  - (* seq *)
    econstructor. apply IHc1. apply IHc2.
  - (* if *)
    eapply H_Consequence_post; constructor; auto.
  - (* while *)
    eapply H_Consequence.
    econstructor. apply IHc.
    auto. auto.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (provable_false_pre)  *)

(** Show that any Hoare triple whose precondition is [False] is derivable. Again,
    proceed by induction on [c]. *)

Theorem provable_false_pre : forall c Q,
    derivable False c Q.
Proof.
  intros.
  generalize dependent Q.
  induction c; intros.
  - (* skip *)
    eapply H_Consequence_pre; try contradiction.
    constructor; auto.
  - (* ass *)
    eapply H_Consequence_pre; try contradiction.
    constructor.
  - (* seq *)
    eapply H_Consequence_pre; try contradiction.
    econstructor. apply IHc1. apply IHc2.
  - (* if *)
    eapply H_Consequence_post; try contradiction.
    constructor.
    + eapply H_Consequence_pre. apply IHc1. intros. destruct H. contradiction.
    + eapply H_Consequence_pre. apply IHc2. intros. destruct H. contradiction.
    + intros. apply H.
  - (* while *)
    eapply H_Consequence_post; try contradiction.
    + constructor. eapply H_Consequence_pre. apply IHc.
      intros. destruct H. contradiction.
    + intros. simpl in H. destruct H. contradiction.
Qed.

(** [] *)

(* ################################################################# *)
(** * Soundness and Completeness *)

(** We now have two approaches to formulating Hoare logic:

    - The model-theoretic approach uses [valid] to characterize when a Hoare
      triple holds in a model, which is based on states.

    - The proof-theoretic approach uses [derivable] to characterize when a Hoare
      triple is derivable as the end of a proof tree.

    Do these two approaches agree?  That is, are the valid Hoare triples exactly
    the derivable ones?  This is a standard question investigated in
    mathematical logic.  There are two pieces to answering it:

    - A logic is _sound_ if everything that is derivable is valid.

    - A logic is _complete_ if everything that is valid is derivable.

    We can prove that Hoare logic is sound and complete.

*)

(** **** Exercise: 3 stars, standard (hoare_sound)  *)

(** Prove that if a Hoare triple is derivable, then it is valid.
    Nearly all the work for this was already done in [Hoare] as
    theorems [hoare_skip], [hoare_asgn], etc.; leverage those
    proofs. Proceed by induction on the derivation of the triple. *)

Theorem hoare_sound : forall P c Q,
  derivable P c Q -> valid P c Q.
Proof.
  intros.
  induction X.
  - apply hoare_skip.
  - apply hoare_asgn.
  - eapply hoare_seq; eassumption.
  - eapply hoare_if; eassumption.
  - eapply hoare_while; eassumption.
  - eapply hoare_consequence; eassumption.
Qed.
(** [] *)

(** The proof of completeness is more challenging.  To carry out the
    proof, we need to invent some intermediate assertions using a
    technical device known as _weakest preconditions_ (which are also
    discussed in [Hoare2]).  Given a command [c] and a desired
    postcondition assertion [Q], the weakest precondition [wp c Q] is
    an assertion [P] such that [{{P}} c {{Q}}] holds, and moreover,
    for any other assertion [P'], if [{{P'}} c {{Q}}] holds then [P'
    ->> P].

    Another way of stating that idea is that [wp c Q] is the following
    assertion: *)

Definition wp (c:com) (Q:Assertion) : Assertion :=
  fun s => forall s', s =[ c ]=> s' -> Q s'.

Hint Unfold wp : core.

(** The following two theorems show that the two ways of thinking
    about [wp] are the same. *)

Theorem wp_is_precondition : forall c Q,
  {{wp c Q}} c {{Q}}.
Proof. auto. Qed.

Theorem wp_is_weakest : forall c Q P',
    {{P'}} c {{Q}} ->
    P' ->> (wp c Q).
Proof. eauto. Qed.

(** Weakest preconditions are useful because they enable us to
    identify assertions that otherwise would require clever thinking.
    The next two lemmas show that in action. *)

(** **** Exercise: 1 star, standard (wp_seq)  *)

(** What if we have a sequence [c1;; c2], but not an intermediate assertion for
    what should hold in between [c1] and [c2]?  No problem.  Prove that [wp c2 Q]
    suffices as such an assertion. *)

Lemma wp_seq : forall P Q c1 c2,
    derivable P c1 (wp c2 Q) ->
    derivable (wp c2 Q) c2 Q ->
    derivable P <{c1; c2}> Q.
Proof.
  intros.
  econstructor.
  apply X.
  assumption.
Qed.

(** [] *)

(** **** Exercise: 2 stars, standard (wp_invariant)  *)

(** What if we have a while loop, but not an invariant for it?  No
    problem.  Prove that for any [Q], assertion [wp (while b do c end)
    Q] is a loop invariant of [while b do c end]. *)

Lemma wp_invariant : forall b c Q,
    valid (wp <{while b do c end}> Q /\ b) c (wp <{while b do c end}> Q).
Proof.
  unfold valid.
  intros.
  destruct H0.
  unfold wp.
  info_eauto.
Qed.

(** [] *)

(** **** Exercise: 4 stars, standard (hoare_complete)  *)

(** Now we are ready to prove the completeness of Hoare logic.  Finish
    the proof of the theorem below.

    Hint: for the [while] case, use the invariant suggested by
    [wp_invariant].

    Acknowledgment: Our approach to this proof is inspired by:

      https://www.ps.uni-saarland.de/courses/sem-ws11/script/Hoare.html
*)

Hint Constructors derivable : core.
Hint Resolve H_Consequence_pre : core.
Hint Resolve H_Consequence_post : core.

Theorem hoare_complete: forall P c Q,
  valid P c Q -> derivable P c Q.
Proof.
  unfold valid. intros P c. generalize dependent P.
  induction c; intros P Q HT.
  - (* skip *)
    eauto.
  - (* ass *)
    eauto.
  - (* seq *)
    apply wp_seq; eauto.
  - (* if *)
    constructor.
    + (* if true *)
      apply IHc1. intros. eapply HT.
      apply E_IfTrue.
      apply H0. apply H. apply H0.
    + (* if false *)
      apply IHc2. intros. eapply HT.
      apply E_IfFalse. simpl in H0. rewrite Bool.not_true_iff_false in H0.
      apply H0. apply H. apply H0.
  - (* while *)
    eapply H_Consequence.
    + apply H_While. apply IHc. apply wp_invariant.
    + (* precondition *)
      intros. unfold wp. intros st' HH. eapply HT. apply HH. apply H.
    + (* postcondition *)
      simpl. intros.
      rewrite Bool.not_true_iff_false in H.
      destruct H.
      unfold wp in H.
      apply H. apply E_WhileFalse. apply H0.
Qed.
(** [] *)

(* ################################################################# *)
(** * Postscript: Decidability *)

(** We might hope that Hoare logic would be _decidable_; that is, that
    there is an (terminating) algorithm (a _decision procedure_) that
    can determine whether or not a given Hoare triple is valid or
    derivable.  But such a decision procedure cannot exist.

    Consider the triple [{{True}} c {{False}}]. This triple is valid if and
    only if [c] is non-terminating.  So any algorithm that could
    determine validity of arbitrary triples could solve the Halting
    Problem.

    Similarly, the triple [{{True}} skip {{P}}] is valid if and only if
    [forall s, P s] is valid, where [P] is an arbitrary assertion of Coq's
    logic. But it is known that there can be no decision procedure for
    this logic. *)

(* 2020-09-09 21:08 *)


Definition plus_comm := forall n m : nat, n + m = m + n.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Solvers for dataflow inequations. *)

Require Import Coqlib.
Require Import Iteration.
Require Import Maps.
Require Import Lattice.

(* To avoid useless definitions of inductors in extracted code. *)
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

(** A forward dataflow problem is a set of inequations of the form
- [X(s) >= transf n X(n)]
  if program point [s] is a successor of program point [n]
- [X(n) >= a]
  if [n] is an entry point and [a] its minimal approximation.

The unknowns are the [X(n)], indexed by program points (e.g. nodes in the
CFG graph of a RTL function).  They range over a given ordered set that
represents static approximations of the program state at each point.
The [transf] function is the abstract transfer function: it computes an
approximation [transf n X(n)] of the program state after executing instruction
at point [n], as a function of the approximation [X(n)] of the program state
before executing that instruction.

Symmetrically, a backward dataflow problem is a set of inequations of the form
- [X(n) >= transf s X(s)]
  if program point [s] is a successor of program point [n]
- [X(n) >= a]
  if [n] is an entry point and [a] its minimal approximation.

The only difference with a forward dataflow problem is that the transfer
function [transf] now computes the approximation before a program point [s]
from the approximation [X(s)] after point [s].

This file defines three solvers for dataflow problems.  The first two
solve (optimally) forward and backward problems using Kildall's worklist
algorithm.  They assume that the unknowns range over a semi-lattice, that is,
an ordered type equipped with a least upper bound operation.

The last solver corresponds to propagation over extended basic blocks:
it returns approximate solutions of forward problems where the unknowns
range over any ordered type having a greatest element [top].  It simply
sets [X(n) = top] for all merge points [n], that is, program points having
several predecessors.  This solver is useful when least upper bounds of
approximations do not exist or are too expensive to compute. *)

(** * Solving forward dataflow problems using Kildall's algorithm *)

(** A forward dataflow solver has the following generic interface.
  Unknowns range over the type [L.t], which is equipped with
  semi-lattice operations (see file [Lattice]).  *)

Module Type DATAFLOW_SOLVER.

  Declare Module L: SEMILATTICE.

  (** [fixpoint successors transf ep ev] is the solver.
    It returns either an error or a mapping from program points to
    values of type [L.t] representing the solution.  [successors]
    is a finite map returning the list of successors of the given program
    point. [transf] is the transfer function, [ep] the entry point,
    and [ev] the minimal abstract value for [ep]. *)

  Variable fixpoint:
    forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
           (transf: positive -> L.t -> L.t)
           (ep: positive) (ev: L.t),
    option (PMap.t L.t).

  (** The [fixpoint_solution] theorem shows that the returned solution,
    if any, satisfies the dataflow inequations. *)

  Hypothesis fixpoint_solution:
    forall A (code: PTree.t A) successors transf ep ev res n instr s,
    fixpoint code successors transf ep ev = Some res ->
    code!n = Some instr -> In s (successors instr) ->
    (forall n, L.eq (transf n L.bot) L.bot) ->
    L.ge res!!s (transf n res!!n).

  (** The [fixpoint_entry] theorem shows that the returned solution,
    if any, satisfies the additional constraint over the entry point. *)

  Hypothesis fixpoint_entry:
    forall A (code: PTree.t A) successors transf ep ev res,
    fixpoint code successors transf ep ev = Some res ->
    L.ge res!!ep ev.

  (** Finally, any property that is preserved by [L.lub] and [transf]
      and that holds for [L.bot] also holds for the results of
      the analysis. *)

  Hypothesis fixpoint_invariant:
    forall A (code: PTree.t A) successors transf ep ev
           (P: L.t -> Prop),
    P L.bot ->
    (forall x y, P x -> P y -> P (L.lub x y)) ->
    (forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x)) ->
    P ev ->
    forall res pc,
    fixpoint code successors transf ep ev = Some res ->
    P res!!pc.

End DATAFLOW_SOLVER.

(** Kildall's algorithm manipulates worklists, which are sets of CFG nodes
  equipped with a ``pick next node to examine'' operation.
  The algorithm converges faster if the nodes are chosen in an order
  consistent with a reverse postorder traversal of the CFG.
  For now, we parameterize the dataflow solver over a module
  that implements sets of CFG nodes. *)

Module Type NODE_SET.

  Variable t: Type.
  Variable empty: t.
  Variable add: positive -> t -> t.
  Variable pick: t -> option (positive * t).
  Variable all_nodes: forall {A: Type}, PTree.t A -> t.

  Variable In: positive -> t -> Prop.
  Hypothesis empty_spec:
    forall n, ~In n empty.
  Hypothesis add_spec:
    forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
  Hypothesis pick_none:
    forall s n, pick s = None -> ~In n s.
  Hypothesis pick_some:
    forall s n s', pick s = Some(n, s') ->
    forall n', In n' s <-> n = n' \/ In n' s'.
  Hypothesis all_nodes_spec:
    forall A (code: PTree.t A) n instr,
    code!n = Some instr -> In n (all_nodes code).

End NODE_SET.

(** Reachability in a control-flow graph. *)

Section REACHABLE.

Context {A: Type} (code: PTree.t A) (successors: A -> list positive).

Inductive reachable: positive -> positive -> Prop :=
  | reachable_refl: forall n, reachable n n
  | reachable_left: forall n1 n2 n3 i,
      code!n1 = Some i -> In n2 (successors i) -> reachable n2 n3 ->
      reachable n1 n3.

Scheme reachable_ind := Induction for reachable Sort Prop.

Lemma reachable_trans:
  forall n1 n2, reachable n1 n2 -> forall n3, reachable n2 n3 -> reachable n1 n3.
Proof.
  induction 1; intros.
- auto.
- econstructor; eauto.
Qed.

Lemma reachable_right:
  forall n1 n2 n3 i,
  reachable n1 n2 -> code!n2 = Some i -> In n3 (successors i) ->
  reachable n1 n3.
Proof.
  intros. apply reachable_trans with n2; auto. econstructor; eauto. constructor.
Qed.

End REACHABLE.

(** We now define a generic solver for forward dataflow inequations
  that works over any semi-lattice structure. *)

Module Dataflow_Solver (LAT: SEMILATTICE) (NS: NODE_SET) <:
                          DATAFLOW_SOLVER with Module L := LAT.

Module L := LAT.

Section Kildall.

Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.
Variable transf: positive -> L.t -> L.t.

(** The state of the iteration has three components:
- [aval]: A mapping from program points to values of type [L.t] representing
  the candidate solution found so far.
- [worklist]: A worklist of program points that remain to be considered.
- [visited]: A set of program points that were visited already
  (i.e. put on the worklist at some point in the past).

Only the first two components are computationally relevant.  The third
is a ghost variable used only for stating and proving invariants.
For this reason, [visited] is defined at sort [Prop] so that it is
erased during program extraction.
*)

Record state : Type :=
  mkstate { aval: PTree.t L.t; worklist: NS.t; visited: positive -> Prop }.

Definition abstr_value (n: positive) (s: state) : L.t :=
  match s.(aval)!n with
  | None => L.bot
  | Some v => v
  end.

(** Kildall's algorithm, in pseudo-code, is as follows:
<<
    while worklist is not empty, do
        extract a node n from worklist
        compute out = transf n aval[n]
        for each successor s of n:
            compute in = lub aval[s] out
            if in <> aval[s]:
                aval[s] := in
                worklist := worklist union {s}
                visited := visited union {s}
            end if
        end for
    end while
    return aval
>>
*)

(** [propagate_succ] corresponds, in the pseudocode,
  to the body of the [for] loop iterating over all successors. *)

Definition propagate_succ (s: state) (out: L.t) (n: positive) :=
  match s.(aval)!n with
  | None =>
      {| aval := PTree.set n out s.(aval);
         worklist := NS.add n s.(worklist);
         visited := fun p => p = n \/ s.(visited) p |}
  | Some oldl =>
      let newl := L.lub oldl out in
      if L.beq oldl newl
      then s
      else {| aval := PTree.set n newl s.(aval);
              worklist := NS.add n s.(worklist);
              visited := fun p => p = n \/ s.(visited) p |}
  end.

(** [propagate_succ_list] corresponds, in the pseudocode,
  to the [for] loop iterating over all successors. *)

Fixpoint propagate_succ_list (s: state) (out: L.t) (succs: list positive)
                             {struct succs} : state :=
  match succs with
  | nil => s
  | n :: rem => propagate_succ_list (propagate_succ s out n) out rem
  end.

(** [step] corresponds to the body of the outer [while] loop in the
  pseudocode. *)

Definition step (s: state) : PMap.t L.t + state :=
  match NS.pick s.(worklist) with
  | None =>
      inl _ (L.bot, s.(aval))
  | Some(n, rem) =>
      match code!n with
      | None =>
          inr _ {| aval := s.(aval); worklist := rem; visited := s.(visited) |}
      | Some instr =>
          inr _ (propagate_succ_list
                  {| aval := s.(aval); worklist := rem; visited := s.(visited) |}
                  (transf n (abstr_value n s))
                  (successors instr))
      end
  end.

(** The whole fixpoint computation is the iteration of [step] from
  an initial state. *)

Definition fixpoint_from (start: state) : option (PMap.t L.t) :=
  PrimIter.iterate _ _ step start.

(** There are several ways to build the initial state.  For forward
  dataflow analyses, the initial worklist is the function entry point,
  and the initial mapping sets the function entry point to the given
  abstract value, and leaves unset all other program points, which
  corresponds to [L.bot] initial abstract values. *)

Definition start_state (enode: positive) (eval: L.t) :=
  {| aval := PTree.set enode eval (PTree.empty L.t);
     worklist := NS.add enode NS.empty;
     visited := fun n => n = enode |}.

Definition fixpoint (enode: positive) (eval: L.t) :=
  fixpoint_from (start_state enode eval).

(** For backward analyses (viewed as forward analyses on the reversed CFG),
  the following two variants are more useful.  Both start with an
  empty initial mapping, where all program points start at [L.bot].
  The first initializes the worklist with a given set of entry points
  in the reversed CFG.  (See the backward dataflow solver below for
  how this list is computed.)  The second start state construction
  initializes the worklist with all program points of the given CFG. *)

Definition start_state_nodeset (enodes: NS.t) :=
  {| aval := PTree.empty L.t;
     worklist := enodes;
     visited := fun n => NS.In n enodes |}.

Definition fixpoint_nodeset (enodes: NS.t) :=
  fixpoint_from (start_state_nodeset enodes).

Definition start_state_allnodes :=
  {| aval := PTree.empty L.t;
     worklist := NS.all_nodes code;
     visited := fun n => exists instr, code!n = Some instr |}.

Definition fixpoint_allnodes :=
  fixpoint_from start_state_allnodes.

(** ** Characterization of the propagation functions *)

Inductive optge: option L.t -> option L.t -> Prop :=
  | optge_some: forall l l',
      L.ge l l' -> optge (Some l) (Some l')
  | optge_none: forall ol,
      optge ol None.

Remark optge_refl: forall ol, optge ol ol.
Proof. destruct ol; constructor. apply L.ge_refl; apply L.eq_refl. Qed.

Remark optge_trans: forall ol1 ol2 ol3, optge ol1 ol2 -> optge ol2 ol3 -> optge ol1 ol3.
Proof.
  intros. inv H0.
  inv H. constructor. eapply L.ge_trans; eauto.
  constructor.
Qed.

Remark optge_abstr_value:
  forall st st' n,
  optge st.(aval)!n st'.(aval)!n ->
  L.ge (abstr_value n st) (abstr_value n st').
Proof.
  intros. unfold abstr_value. inv H. auto. apply L.ge_bot.
Qed.

Lemma propagate_succ_charact:
  forall st out n,
  let st' := propagate_succ st out n in
     optge st'.(aval)!n (Some out)
  /\ (forall s, n <> s -> st'.(aval)!s = st.(aval)!s)
  /\ (forall s, optge st'.(aval)!s st.(aval)!s)
  /\ (NS.In n st'.(worklist) \/ st'.(aval)!n = st.(aval)!n)
  /\ (forall n', NS.In n' st.(worklist) -> NS.In n' st'.(worklist))
  /\ (forall n', NS.In n' st'.(worklist) -> n' = n \/ NS.In n' st.(worklist))
  /\ (forall n', st.(visited) n' -> st'.(visited) n')
  /\ (forall n', st'.(visited) n' -> NS.In n' st'.(worklist) \/ st.(visited) n')
  /\ (forall n', st.(aval)!n' = None -> st'.(aval)!n' <> None -> st'.(visited) n').
Proof.
  unfold propagate_succ; intros; simpl.
  destruct st.(aval)!n as [v|] eqn:E;
  [predSpec L.beq L.beq_correct v (L.lub v out) | idtac].
- (* already there, unchanged *)
  repeat split; intros.
  + rewrite E. constructor. eapply L.ge_trans. apply L.ge_refl. apply H; auto. apply L.ge_lub_right.
  + apply optge_refl.
  + right; auto.
  + auto.
  + auto.
  + auto.
  + auto.
  + congruence.
- (* already there, updated *)
  simpl; repeat split; intros.
  + rewrite PTree.gss. constructor. apply L.ge_lub_right.
  + rewrite PTree.gso by auto. auto.
  + rewrite PTree.gsspec. destruct (peq s n).
    subst s. rewrite E. constructor. apply L.ge_lub_left.
    apply optge_refl.
  + rewrite NS.add_spec. auto.
  + rewrite NS.add_spec. auto.
  + rewrite NS.add_spec in H0. intuition.
  + auto.
  + destruct H0; auto. subst n'. rewrite NS.add_spec; auto.
  + rewrite PTree.gsspec in H1. destruct (peq n' n). auto. congruence.
- (* not previously there, updated *)
  simpl; repeat split; intros.
  + rewrite PTree.gss. apply optge_refl.
  + rewrite PTree.gso by auto. auto.
  + rewrite PTree.gsspec. destruct (peq s n).
    subst s. rewrite E. constructor.
    apply optge_refl.
  + rewrite NS.add_spec. auto.
  + rewrite NS.add_spec. auto.
  + rewrite NS.add_spec in H. intuition.
  + auto.
  + destruct H; auto. subst n'. rewrite NS.add_spec. auto.
  + rewrite PTree.gsspec in H0. destruct (peq n' n). auto. congruence.
Qed.

Lemma propagate_succ_list_charact:
  forall out l st,
  let st' := propagate_succ_list st out l in
     (forall n, In n l -> optge st'.(aval)!n (Some out))
  /\ (forall n, ~In n l -> st'.(aval)!n = st.(aval)!n)
  /\ (forall n, optge st'.(aval)!n st.(aval)!n)
  /\ (forall n, NS.In n st'.(worklist) \/ st'.(aval)!n = st.(aval)!n)
  /\ (forall n', NS.In n' st.(worklist) -> NS.In n' st'.(worklist))
  /\ (forall n', NS.In n' st'.(worklist) -> In n' l \/ NS.In n' st.(worklist))
  /\ (forall n', st.(visited) n' -> st'.(visited) n')
  /\ (forall n', st'.(visited) n' -> NS.In n' st'.(worklist) \/ st.(visited) n')
  /\ (forall n', st.(aval)!n' = None -> st'.(aval)!n' <> None -> st'.(visited) n').
Proof.
  induction l; simpl; intros.
- repeat split; intros.
  + contradiction.
  + apply optge_refl.
  + auto.
  + auto.
  + auto.
  + auto.
  + auto.
  + congruence.
- generalize (propagate_succ_charact st out a).
  set (st1 := propagate_succ st out a).
  intros (A1 & A2 & A3 & A4 & A5 & A6 & A7 & A8 & A9).
  generalize (IHl st1).
  set (st2 := propagate_succ_list st1 out l).
  intros (B1 & B2 & B3 & B4 & B5 & B6 & B7 & B8 & B9). clear IHl.
  repeat split; intros.
  + destruct H.
    * subst n. eapply optge_trans; eauto.
    * auto.
  + rewrite B2 by tauto. apply A2; tauto.
  + eapply optge_trans; eauto.
  + destruct (B4 n). auto.
    destruct (peq n a).
    * subst n. destruct A4. left; auto. right; congruence.
    * right. rewrite H. auto.
  + eauto.
  + exploit B6; eauto. intros [P|P]. auto.
    exploit A6; eauto. intuition.
  + eauto.
  + specialize (B8 n'); specialize (A8 n'). intuition.
  + destruct st1.(aval)!n' eqn:ST1.
    apply B7. apply A9; auto. congruence.
    apply B9; auto.
Qed.

(** Characterization of [fixpoint_from]. *)

Inductive steps: state -> state -> Prop :=
  | steps_base: forall s, steps s s
  | steps_right: forall s1 s2 s3, steps s1 s2 -> step s2 = inr s3 -> steps s1 s3.

Scheme steps_ind := Induction for steps Sort Prop.

Lemma fixpoint_from_charact:
  forall start res,
  fixpoint_from start = Some res ->
  exists st, steps start st /\ NS.pick st.(worklist) = None /\ res = (L.bot, st.(aval)).
Proof.
  unfold fixpoint; intros.
  eapply (PrimIter.iterate_prop _ _ step
              (fun st => steps start st)
              (fun res => exists st, steps start st /\ NS.pick (worklist st) = None /\ res = (L.bot, aval st))); eauto.
  intros. destruct (step a) eqn:E.
  exists a; split; auto.
  unfold step in E. destruct (NS.pick (worklist a)) as [[n rem]|].
  destruct (code!n); discriminate.
  inv E. auto.
  eapply steps_right; eauto.
  constructor.
Qed.

(** ** Monotonicity properties *)

(** We first show that the [aval] and [visited] parts of the state
evolve monotonically:
- at each step, the values of the [aval[n]] either remain the same or
  increase with respect to the [optge] ordering;
- every node visited in the past remains visited in the future.
*)

Lemma step_incr:
  forall n s1 s2, step s1 = inr s2 ->
  optge s2.(aval)!n s1.(aval)!n /\ (s1.(visited) n -> s2.(visited) n).
Proof.
  unfold step; intros.
  destruct (NS.pick (worklist s1)) as [[p rem] | ]; try discriminate.
  destruct (code!p) as [instr|]; inv H.
  + generalize (propagate_succ_list_charact
                     (transf p (abstr_value p s1))
                     (successors instr)
                     {| aval := aval s1; worklist := rem; visited := visited s1 |}).
      simpl.
      set (s' := propagate_succ_list {| aval := aval s1; worklist := rem; visited := visited s1 |}
                    (transf p (abstr_value p s1)) (successors instr)).
      intros (A1 & A2 & A3 & A4 & A5 & A6 & A7 & A8 & A9).
      auto.
  + split. apply optge_refl. auto.
Qed.

Lemma steps_incr:
  forall n s1 s2, steps s1 s2 ->
  optge s2.(aval)!n s1.(aval)!n /\ (s1.(visited) n -> s2.(visited) n).
Proof.
  induction 1.
- split. apply optge_refl. auto.
- destruct IHsteps. exploit (step_incr n); eauto. intros [P Q].
  split. eapply optge_trans; eauto. eauto.
Qed.

(** ** Correctness invariant *)

(** The following invariant is preserved at each iteration of Kildall's
  algorithm: for all visited program point [n], either
  [n] is in the worklist, or the inequations associated with [n]
  ([aval[s] >= transf n aval[n]] for all successors [s] of [n])
  hold.  In other terms, the worklist contains all nodes that were
  visited but do not yet satisfy their inequations.

  The second part of the invariant shows that nodes that already have
  an abstract value associated with them have been visited. *)

Record good_state (st: state) : Prop := {
  gs_stable: forall n,
    st.(visited) n ->
    NS.In n st.(worklist) \/
    (forall i s,
     code!n = Some i -> In s (successors i) ->
     optge st.(aval)!s (Some (transf n (abstr_value n st))));
  gs_defined: forall n v,
    st.(aval)!n = Some v -> st.(visited) n
}.

(** We show that the [step] function preserves this invariant. *)

Lemma step_state_good:
  forall st pc rem instr,
  NS.pick st.(worklist) = Some (pc, rem) ->
  code!pc = Some instr ->
  good_state st ->
  good_state (propagate_succ_list (mkstate st.(aval) rem st.(visited))
                                  (transf pc (abstr_value pc st))
                                  (successors instr)).
Proof.
  intros until instr; intros PICK CODEAT [GOOD1 GOOD2].
  generalize (NS.pick_some _ _ _ PICK); intro PICK2.
  set (out := transf pc (abstr_value pc st)).
  generalize (propagate_succ_list_charact out (successors instr) {| aval := aval st; worklist := rem; visited := visited st |}).
  set (st' := propagate_succ_list {| aval := aval st; worklist := rem; visited := visited st |} out
                                  (successors instr)).
  simpl; intros (A1 & A2 & A3 & A4 & A5 & A6 & A7 & A8 & A9).
  constructor; intros.
- (* stable *)
  destruct (A8 n H); auto. destruct (A4 n); auto.
  replace (abstr_value n st') with (abstr_value n st)
  by (unfold abstr_value; rewrite H1; auto).
  exploit GOOD1; eauto. intros [P|P].
+ (* n was on the worklist *)
  rewrite PICK2 in P; destruct P.
  * (* node n is our node pc *)
    subst n. fold out. right; intros.
    assert (i = instr) by congruence. subst i.
    apply A1; auto.
  * (* n was already on the worklist *)
    left. apply A5; auto.
+ (* n was stable before, still is *)
  right; intros. apply optge_trans with st.(aval)!s; eauto.
- (* defined *)
  destruct st.(aval)!n as [v'|] eqn:ST.
  + apply A7. eapply GOOD2; eauto.
  + apply A9; auto. congruence.
Qed.

Lemma step_state_good_2:
  forall st pc rem,
  good_state st ->
  NS.pick (worklist st) = Some (pc, rem) ->
  code!pc = None ->
  good_state (mkstate st.(aval) rem st.(visited)).
Proof.
  intros until rem; intros [GOOD1 GOOD2] PICK CODE.
  generalize (NS.pick_some _ _ _ PICK); intro PICK2.
  constructor; simpl; intros.
- (* stable *)
  exploit GOOD1; eauto. intros [P | P].
  + rewrite PICK2 in P. destruct P; auto.
    subst n. right; intros. congruence.
  + right; exact P.
- (* defined *)
  eapply GOOD2; eauto.
Qed.

Lemma steps_state_good:
  forall st1 st2, steps st1 st2 -> good_state st1 -> good_state st2.
Proof.
  induction 1; intros.
- auto.
- unfold step in e.
  destruct (NS.pick (worklist s2)) as [[n rem] | ] eqn:PICK; try discriminate.
  destruct (code!n) as [instr|] eqn:CODE; inv e.
  eapply step_state_good; eauto.
  eapply step_state_good_2; eauto.
Qed.

(** We show that initial states satisfy the invariant. *)

Lemma start_state_good:
  forall enode eval, good_state (start_state enode eval).
Proof.
  intros. unfold start_state; constructor; simpl; intros.
- subst n. rewrite NS.add_spec; auto.
- rewrite PTree.gsspec in H. rewrite PTree.gempty in H.
  destruct (peq n enode). auto. discriminate.
Qed.

Lemma start_state_nodeset_good:
  forall enodes, good_state (start_state_nodeset enodes).
Proof.
  intros. unfold start_state_nodeset; constructor; simpl; intros.
- left. auto.
- rewrite PTree.gempty in H. congruence.
Qed.

Lemma start_state_allnodes_good:
  good_state start_state_allnodes.
Proof.
  unfold start_state_allnodes; constructor; simpl; intros.
- destruct H as [instr CODE]. left. eapply NS.all_nodes_spec; eauto.
- rewrite PTree.gempty in H. congruence.
Qed.

(** Reachability in final states. *)

Lemma reachable_visited:
  forall st, good_state st -> NS.pick st.(worklist) = None ->
  forall p q, reachable code successors p q -> st.(visited) p -> st.(visited) q.
Proof.
  intros st [GOOD1 GOOD2] PICK. induction 1; intros.
- auto.
- eapply IHreachable; eauto.
  exploit GOOD1; eauto. intros [P | P].
  eelim NS.pick_none; eauto.
  exploit P; eauto. intros OGE; inv OGE. eapply GOOD2; eauto.
Qed.

(** ** Correctness of the solution returned by [fixpoint]. *)

(** As a consequence of the [good_state] invariant, the result of
  [fixpoint], if defined, is a solution of the dataflow inequations.
  This assumes that the transfer function maps [L.bot] to [L.bot]. *)

Theorem fixpoint_solution:
  forall ep ev res n instr s,
  fixpoint ep ev = Some res ->
  code!n = Some instr ->
  In s (successors instr) ->
  (forall n, L.eq (transf n L.bot) L.bot) ->
  L.ge res!!s (transf n res!!n).
Proof.
  unfold fixpoint; intros.
  exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
  exploit steps_state_good; eauto. apply start_state_good. intros [GOOD1 GOOD2].
  rewrite RES; unfold PMap.get; simpl.
  destruct st.(aval)!n as [v|] eqn:STN.
- destruct (GOOD1 n) as [P|P]; eauto.
  eelim NS.pick_none; eauto.
  exploit P; eauto. unfold abstr_value; rewrite STN. intros OGE; inv OGE. auto.
- apply L.ge_trans with L.bot. apply L.ge_bot. apply L.ge_refl. apply L.eq_sym. eauto.
Qed.

(** Moreover, the result of [fixpoint], if defined, satisfies the additional
  constraint given on the entry point. *)

Theorem fixpoint_entry:
  forall ep ev res,
  fixpoint ep ev = Some res ->
  L.ge res!!ep ev.
Proof.
  unfold fixpoint; intros.
  exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
  exploit (steps_incr ep); eauto. simpl. rewrite PTree.gss. intros [P Q].
  rewrite RES; unfold PMap.get; simpl. inv P; auto.
Qed.

(** For [fixpoint_allnodes], we show that the result is a solution
  without assuming [transf n L.bot = L.bot]. *)

Theorem fixpoint_allnodes_solution:
  forall res n instr s,
  fixpoint_allnodes = Some res ->
  code!n = Some instr ->
  In s (successors instr) ->
  L.ge res!!s (transf n res!!n).
Proof.
  unfold fixpoint_allnodes; intros.
  exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
  exploit steps_state_good; eauto. apply start_state_allnodes_good. intros [GOOD1 GOOD2].
  exploit (steps_incr n); eauto. simpl. intros [U V].
  exploit (GOOD1 n). apply V. exists instr; auto. intros [P|P].
  eelim NS.pick_none; eauto.
  exploit P; eauto. intros OGE. rewrite RES; unfold PMap.get; simpl.
  inv OGE. assumption.
Qed.

(** For [fixpoint_nodeset], we show that the result is a solution
  at all program points that are reachable from the given entry points. *)

Theorem fixpoint_nodeset_solution:
  forall enodes res e n instr s,
  fixpoint_nodeset enodes = Some res ->
  NS.In e enodes ->
  reachable code successors e n ->
  code!n = Some instr ->
  In s (successors instr) ->
  L.ge res!!s (transf n res!!n).
Proof.
  unfold fixpoint_nodeset; intros.
  exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
  exploit steps_state_good; eauto. apply start_state_nodeset_good. intros GOOD.
  exploit (steps_incr e); eauto. simpl. intros [U V].
  assert (st.(visited) n).
  { eapply reachable_visited; eauto. }
  destruct GOOD as [GOOD1 GOOD2].
  exploit (GOOD1 n); eauto. intros [P|P].
  eelim NS.pick_none; eauto.
  exploit P; eauto. intros OGE. rewrite RES; unfold PMap.get; simpl.
  inv OGE. assumption.
Qed.

(** ** Preservation of a property over solutions *)

Theorem fixpoint_invariant:
  forall ep ev
    (P: L.t -> Prop)
    (P_bot: P L.bot)
    (P_lub: forall x y, P x -> P y -> P (L.lub x y))
    (P_transf: forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x))
    (P_entrypoint: P ev)
    res pc,
  fixpoint ep ev = Some res ->
  P res!!pc.
Proof.
  intros.
  set (inv := fun st => forall x, P (abstr_value x st)).
  assert (inv (start_state ep ev)).
  {
    red; simpl; intros. unfold abstr_value, start_state; simpl.
    rewrite PTree.gsspec. rewrite PTree.gempty.
    destruct (peq x ep). auto. auto.
  }
  assert (forall st v n, inv st -> P v -> inv (propagate_succ st v n)).
  {
    unfold inv, propagate_succ. intros.
    destruct (aval st)!n as [oldl|] eqn:E.
    destruct (L.beq oldl (L.lub oldl v)).
    auto.
    unfold abstr_value. simpl. rewrite PTree.gsspec. destruct (peq x n).
    apply P_lub; auto. replace oldl with (abstr_value n st). auto.
    unfold abstr_value; rewrite E; auto.
    apply H1.
    unfold abstr_value. simpl. rewrite PTree.gsspec. destruct (peq x n).
    auto.
    apply H1.
  }
  assert (forall l st v, inv st -> P v -> inv (propagate_succ_list st v l)).
  {
    induction l; intros; simpl. auto.
    apply IHl; auto.
  }
  assert (forall st1 st2, steps st1 st2 -> inv st1 -> inv st2).
  {
    induction 1; intros.
    auto.
    unfold step in e. destruct (NS.pick (worklist s2)) as [[n rem]|]; try discriminate.
    destruct (code!n) as [instr|] eqn:INSTR; inv e.
    apply H2. apply IHsteps; auto. eapply P_transf; eauto. apply IHsteps; auto.
    apply IHsteps; auto.
  }
  unfold fixpoint in H. exploit fixpoint_from_charact; eauto.
  intros (st & STEPS & PICK & RES).
  replace (res!!pc) with (abstr_value pc st). eapply H3; eauto.
  rewrite RES; auto.
Qed.

End Kildall.

End Dataflow_Solver.

(** * Solving backward dataflow problems using Kildall's algorithm *)

(** A backward dataflow problem on a given flow graph is a forward
  dataflow program on the reversed flow graph, where predecessors replace
  successors.  We exploit this observation to cheaply derive a backward
  solver from the forward solver. *)

(** ** Construction of the reversed flow graph (the predecessor relation) *)

Definition successors_list (successors: PTree.t (list positive)) (pc: positive) : list positive :=
  match successors!pc with None => nil | Some l => l end.

Notation "a !!! b" := (successors_list a b) (at level 1).

Section Predecessor.

Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.

Fixpoint add_successors (pred: PTree.t (list positive))
                        (from: positive) (tolist: list positive)
                        {struct tolist} : PTree.t (list positive) :=
  match tolist with
  | nil => pred
  | to :: rem => add_successors (PTree.set to (from :: pred!!!to) pred) from rem
  end.

Lemma add_successors_correct:
  forall tolist from pred n s,
  In n pred!!!s \/ (n = from /\ In s tolist) ->
  In n (add_successors pred from tolist)!!!s.
Proof.
  induction tolist; simpl; intros.
  tauto.
  apply IHtolist.
  unfold successors_list at 1. rewrite PTree.gsspec. destruct (peq s a).
  subst a. destruct H. auto with coqlib.
  destruct H. subst n. auto with coqlib.
  fold (successors_list pred s). intuition congruence.
Qed.

Definition make_predecessors : PTree.t (list positive) :=
  PTree.fold (fun pred pc instr => add_successors pred pc (successors instr))
             code (PTree.empty (list positive)).

Lemma make_predecessors_correct_1:
  forall n instr s,
  code!n = Some instr -> In s (successors instr) ->
  In n make_predecessors!!!s.
Proof.
  intros until s.
  set (P := fun m p => m!n = Some instr -> In s (successors instr) ->
                       In n p!!!s).
  unfold make_predecessors.
  apply PTree_Properties.fold_rec with (P := P); unfold P; intros.
(* extensionality *)
  apply H0; auto. rewrite H; auto.
(* base case *)
  rewrite PTree.gempty in H; congruence.
(* inductive case *)
  apply add_successors_correct.
  rewrite PTree.gsspec in H2. destruct (peq n k).
  inv H2. auto.
  auto.
Qed.

Lemma make_predecessors_correct_2:
  forall n instr s,
  code!n = Some instr -> In s (successors instr) ->
  exists l, make_predecessors!s = Some l /\ In n l.
Proof.
  intros. exploit make_predecessors_correct_1; eauto.
  unfold successors_list. destruct (make_predecessors!s); simpl; intros.
  exists l; auto.
  contradiction.
Qed.

Lemma reachable_predecessors:
  forall p q,
  reachable code successors p q ->
  reachable make_predecessors (fun l => l) q p.
Proof.
  induction 1.
- constructor.
- exploit make_predecessors_correct_2; eauto. intros [l [P Q]].
  eapply reachable_right; eauto.
Qed.

End Predecessor.

(** ** Solving backward dataflow problems *)

(** The interface to a backward dataflow solver is as follows. *)

Module Type BACKWARD_DATAFLOW_SOLVER.

  Declare Module L: SEMILATTICE.

  (** [fixpoint successors transf] is the solver.
    It returns either an error or a mapping from program points to
    values of type [L.t] representing the solution.  [successors]
    is a finite map returning the list of successors of the given program
    point. [transf] is the transfer function. *)

  Variable fixpoint:
    forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
           (transf: positive -> L.t -> L.t),
    option (PMap.t L.t).

  (** The [fixpoint_solution] theorem shows that the returned solution,
    if any, satisfies the backward dataflow inequations. *)

  Hypothesis fixpoint_solution:
    forall A (code: PTree.t A) successors transf res n instr s,
    fixpoint code successors transf = Some res ->
    code!n = Some instr -> In s (successors instr) ->
    (forall n a, code!n = None -> L.eq (transf n a) L.bot) ->
    L.ge res!!n (transf s res!!s).

  (** [fixpoint_allnodes] is a variant of [fixpoint], less algorithmically
    efficient, but correct without any hypothesis on the transfer function. *)

  Variable fixpoint_allnodes:
    forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
           (transf: positive -> L.t -> L.t),
    option (PMap.t L.t).

  Hypothesis fixpoint_allnodes_solution:
    forall A (code: PTree.t A) successors transf res n instr s,
    fixpoint_allnodes code successors transf = Some res ->
    code!n = Some instr -> In s (successors instr) ->
    L.ge res!!n (transf s res!!s).

End BACKWARD_DATAFLOW_SOLVER.

(** We construct a generic backward dataflow solver, working over any
  semi-lattice structure, by applying the forward dataflow solver
  with the predecessor relation instead of the successor relation. *)

Module Backward_Dataflow_Solver (LAT: SEMILATTICE) (NS: NODE_SET):
                   BACKWARD_DATAFLOW_SOLVER with Module L := LAT.

Module L := LAT.

Module DS := Dataflow_Solver L NS.

Section Kildall.

Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.
Variable transf: positive -> L.t -> L.t.

(** Finding entry points for the reverse control-flow graph. *)

Section Exit_points.

(** Assuming that the nodes of the CFG [code] are numbered in reverse
  postorder (cf. pass [Renumber]), an edge from [n] to [s] is a
  normal edge if [s < n] and a back-edge otherwise.
  [sequential_node] returns [true] if the given node has at least one
  normal outgoing edge.  It returns [false] if the given node is an exit
  node (no outgoing edges) or the final node of a loop body
  (all outgoing edges are back-edges).  As we prove later, the set
  of all non-sequential node is an appropriate set of entry points
  for exploring the reverse CFG. *)

Definition sequential_node (pc: positive) (instr: A): bool :=
  existsb (fun s => match code!s with None => false | Some _ => plt s pc end)
          (successors instr).

Definition exit_points : NS.t :=
  PTree.fold
    (fun ep pc instr =>
       if sequential_node pc instr
       then ep
       else NS.add pc ep)
    code NS.empty.

Lemma exit_points_charact:
  forall n,
  NS.In n exit_points <-> exists i, code!n = Some i /\ sequential_node n i = false.
Proof.
  intros n. unfold exit_points. eapply PTree_Properties.fold_rec.
- (* extensionality *)
  intros. rewrite <- H. auto.
- (* base case *)
  simpl. split; intros.
  eelim NS.empty_spec; eauto.
  destruct H as [i [P Q]]. rewrite PTree.gempty in P. congruence.
- (* inductive case *)
  intros. destruct (sequential_node k v) eqn:SN.
  + rewrite H1. rewrite PTree.gsspec. destruct (peq n k).
    subst. split; intros [i [P Q]]. congruence. inv P. congruence.
    tauto.
  + rewrite NS.add_spec. rewrite H1. rewrite PTree.gsspec. destruct (peq n k).
    subst. split. intros. exists v; auto. auto.
    split. intros [P | [i [P Q]]]. congruence. exists i; auto.
    intros [i [P Q]]. right; exists i; auto.
Qed.

Lemma reachable_exit_points:
  forall pc i,
  code!pc = Some i -> exists x, NS.In x exit_points /\ reachable code successors pc x.
Proof.
  intros pc0. pattern pc0. apply (well_founded_ind Plt_wf).
  intros pc HR i CODE.
  destruct (sequential_node pc i) eqn:SN.
- (* at least one successor that decreases the pc *)
  unfold sequential_node in SN. rewrite existsb_exists in SN.
  destruct SN as [s [P Q]]. destruct (code!s) as [i'|] eqn:CS; try discriminate. InvBooleans.
  exploit (HR s); eauto. intros [x [U V]].
  exists x; split; auto. eapply reachable_left; eauto.
- (* otherwise we are an exit point *)
  exists pc; split.
  rewrite exit_points_charact. exists i; auto. constructor.
Qed.

(** The crucial property of exit points is that any nonempty node in the
  CFG is reverse-reachable from an exit point. *)

Lemma reachable_exit_points_predecessor:
  forall pc i,
  code!pc = Some i ->
  exists x, NS.In x exit_points /\ reachable (make_predecessors code successors) (fun l => l) x pc.
Proof.
  intros. exploit reachable_exit_points; eauto. intros [x [P Q]].
  exists x; split; auto. apply reachable_predecessors. auto.
Qed.

End Exit_points.

(** The efficient backward solver.  *)

Definition fixpoint :=
  DS.fixpoint_nodeset
    (make_predecessors code successors) (fun l => l)
    transf exit_points.

Theorem fixpoint_solution:
  forall res n instr s,
  fixpoint = Some res ->
  code!n = Some instr -> In s (successors instr) ->
  (forall n a, code!n = None -> L.eq (transf n a) L.bot) ->
  L.ge res!!n (transf s res!!s).
Proof.
  intros.
  exploit (make_predecessors_correct_2 code); eauto. intros [l [P Q]].
  destruct code!s as [instr'|] eqn:CS.
- exploit reachable_exit_points_predecessor. eexact CS. intros (ep & U & V).
  unfold fixpoint in H. eapply DS.fixpoint_nodeset_solution; eauto.
- apply L.ge_trans with L.bot. apply L.ge_bot.
  apply L.ge_refl. apply L.eq_sym. auto.
Qed.

(** The alternate solver that starts with all nodes of the CFG instead
  of just the exit points. *)

Definition fixpoint_allnodes :=
  DS.fixpoint_allnodes
    (make_predecessors code successors) (fun l => l)
    transf.

Theorem fixpoint_allnodes_solution:
  forall res n instr s,
  fixpoint_allnodes = Some res ->
  code!n = Some instr -> In s (successors instr) ->
  L.ge res!!n (transf s res!!s).
Proof.
  intros.
  exploit (make_predecessors_correct_2 code); eauto. intros [l [P Q]].
  unfold fixpoint_allnodes in H.
  eapply DS.fixpoint_allnodes_solution; eauto.
Qed.

End Kildall.

End Backward_Dataflow_Solver.

(** * Analysis on extended basic blocks *)

(** We now define an approximate solver for forward dataflow problems
  that proceeds by forward propagation over extended basic blocks.
  In other terms, program points with multiple predecessors are mapped
  to [L.top] (the greatest, or coarsest, approximation) and the other
  program points are mapped to [transf p X[p]] where [p] is their unique
  predecessor.

  This analysis applies to any type of approximations equipped with
  an ordering and a greatest element. *)

Module Type ORDERED_TYPE_WITH_TOP.

  Variable t: Type.
  Variable ge: t -> t -> Prop.
  Variable top: t.
  Hypothesis top_ge: forall x, ge top x.
  Hypothesis refl_ge: forall x, ge x x.

End ORDERED_TYPE_WITH_TOP.

(** The interface of the solver is similar to that of Kildall's forward
  solver, with a slightly different statement of the invariant
  preservation property [fixpoint_invariant]. *)

Module Type BBLOCK_SOLVER.

  Declare Module L: ORDERED_TYPE_WITH_TOP.

  Variable fixpoint:
    forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
           (transf: positive -> L.t -> L.t)
           (entrypoint: positive),
    option (PMap.t L.t).

  Hypothesis fixpoint_solution:
    forall A (code: PTree.t A) successors transf entrypoint res n instr s,
    fixpoint code successors transf entrypoint = Some res ->
    code!n = Some instr -> In s (successors instr) ->
    L.ge res!!s (transf n res!!n).

  Hypothesis fixpoint_entry:
    forall A (code: PTree.t A) successors transf entrypoint res,
    fixpoint code successors transf entrypoint = Some res ->
    res!!entrypoint = L.top.

  Hypothesis fixpoint_invariant:
    forall A (code: PTree.t A) successors transf entrypoint
           (P: L.t -> Prop),
    P L.top ->
    (forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x)) ->
    forall res pc,
    fixpoint code successors transf entrypoint = Some res ->
    P res!!pc.

End BBLOCK_SOLVER.

(** The implementation of the ``extended basic block'' solver is a
  functor parameterized by any ordered type with a top element. *)

Module BBlock_solver(LAT: ORDERED_TYPE_WITH_TOP):
                        BBLOCK_SOLVER with Module L := LAT.

Module L := LAT.

Section Solver.

Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.
Variable transf: positive -> L.t -> L.t.
Variable entrypoint: positive.
Variable P: L.t -> Prop.
Hypothesis Ptop: P L.top.
Hypothesis Ptransf: forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x).

Definition bbmap := positive -> bool.
Definition result := PMap.t L.t.

(** As in Kildall's solver, the state of the iteration has two components:
- A mapping from program points to values of type [L.t] representing
  the candidate solution found so far.
- A worklist of program points that remain to be considered.
*)

Record state : Type := mkstate
  { aval: result; worklist: list positive }.

(** The ``extended basic block'' algorithm, in pseudo-code, is as follows:
<<
    worklist := the set of all points n having multiple predecessors
    aval  := the mapping n -> L.top

    while worklist is not empty, do
        extract a node n from worklist
        compute out = transf n aval[n]
        for each successor s of n:
            if s has only one predecessor (namely, n):
                aval[s] := out
                worklist := worklist union {s}
            end if
        end for
    end while
    return aval
>>
**)

Fixpoint propagate_successors
    (bb: bbmap) (succs: list positive) (l: L.t) (st: state)
    {struct succs} : state :=
  match succs with
  | nil => st
  | s1 :: sl =>
      if bb s1 then
        propagate_successors bb sl l st
      else
        propagate_successors bb sl l
          (mkstate (PMap.set s1 l st.(aval))
                   (s1 :: st.(worklist)))
  end.

Definition step (bb: bbmap) (st: state) : result + state :=
  match st.(worklist) with
  | nil => inl _ st.(aval)
  | pc :: rem =>
      match code!pc with
      | None =>
          inr _ (mkstate st.(aval) rem)
      | Some instr =>
          inr _ (propagate_successors
                   bb (successors instr)
                   (transf pc st.(aval)!!pc)
                   (mkstate st.(aval) rem))
      end
  end.

(** Recognition of program points that have more than one predecessor. *)

Definition is_basic_block_head
    (preds: PTree.t (list positive)) (pc: positive) : bool :=
  if peq pc entrypoint then true else
    match preds!!!pc with
    | nil => false
    | s :: nil => peq s pc
    | _ :: _ :: _ => true
    end.

Definition basic_block_map : bbmap :=
  is_basic_block_head (make_predecessors code successors).

Definition basic_block_list (bb: bbmap) : list positive :=
  PTree.fold (fun l pc instr => if bb pc then pc :: l else l)
             code nil.

(** The computation of the approximate solution. *)

Definition fixpoint : option result :=
  let bb := basic_block_map in
  PrimIter.iterate _ _ (step bb) (mkstate (PMap.init L.top) (basic_block_list bb)).

(** ** Properties of predecessors and multiple-predecessors nodes *)

Definition predecessors := make_predecessors code successors.

Lemma predecessors_correct:
  forall n instr s,
  code!n = Some instr -> In s (successors instr) -> In n predecessors!!!s.
Proof.
  intros. unfold predecessors. eapply make_predecessors_correct_1; eauto.
Qed.

Lemma multiple_predecessors:
  forall s n1 instr1 n2 instr2,
  code!n1 = Some instr1 -> In s (successors instr1) ->
  code!n2 = Some instr2 -> In s (successors instr2) ->
  n1 <> n2 ->
  basic_block_map s = true.
Proof.
  intros.
  assert (In n1 predecessors!!!s). eapply predecessors_correct; eauto.
  assert (In n2 predecessors!!!s). eapply predecessors_correct; eauto.
  unfold basic_block_map, is_basic_block_head.
  destruct (peq s entrypoint). auto.
  fold predecessors.
  destruct (predecessors!!!s).
  auto.
  destruct l.
  apply proj_sumbool_is_true. simpl in *. intuition congruence.
  auto.
Qed.

Lemma no_self_loop:
  forall n instr,
  code!n = Some instr -> In n (successors instr) -> basic_block_map n = true.
Proof.
  intros. unfold basic_block_map, is_basic_block_head.
  destruct (peq n entrypoint). auto.
  fold predecessors.
  exploit predecessors_correct; eauto. intros.
  destruct (predecessors!!!n).
  contradiction.
  destruct l. apply proj_sumbool_is_true. simpl in H1. tauto.
  auto.
Qed.

(** ** Correctness invariant *)

(** The invariant over the state is as follows:
- Points with several predecessors are mapped to [L.top]
- Points not in the worklist satisfy their inequations
  (as in Kildall's algorithm).
*)

Definition state_invariant (st: state) : Prop :=
  (forall n, basic_block_map n = true -> st.(aval)!!n = L.top)
/\
  (forall n,
   In n st.(worklist) \/
   (forall instr s, code!n = Some instr -> In s (successors instr) ->
               L.ge st.(aval)!!s (transf n st.(aval)!!n))).

Lemma propagate_successors_charact1:
  forall bb succs l st,
  incl st.(worklist)
       (propagate_successors bb succs l st).(worklist).
Proof.
  induction succs; simpl; intros.
  apply incl_refl.
  case (bb a).
  auto.
  apply incl_tran with (a :: worklist st).
  apply incl_tl. apply incl_refl.
  set (st1 := (mkstate (PMap.set a l (aval st)) (a :: worklist st))).
  change (a :: worklist st) with (worklist st1).
  auto.
Qed.

Lemma propagate_successors_charact2:
  forall bb succs l st n,
  let st' := propagate_successors bb succs l st in
  (In n succs -> bb n = false -> In n st'.(worklist) /\ st'.(aval)!!n = l)
/\ (~In n succs \/ bb n = true -> st'.(aval)!!n = st.(aval)!!n).
Proof.
  induction succs; simpl; intros.
  (* Base case *)
  split. tauto. auto.
  (* Inductive case *)
  caseEq (bb a); intro.
  elim (IHsuccs l st n); intros U V.
  split; intros. apply U; auto.
  elim H0; intro. subst a. congruence. auto.
  apply V. tauto.
  set (st1 := mkstate (PMap.set a l (aval st)) (a :: worklist st)).
  elim (IHsuccs l st1 n); intros U V.
  split; intros.
  elim H0; intros.
  subst n. split.
  apply propagate_successors_charact1. simpl. tauto.
  case (In_dec peq a succs); intro.
  elim (U i H1); auto.
  rewrite V. unfold st1; simpl. apply PMap.gss. tauto.
  apply U; auto.
  rewrite V. unfold st1; simpl. apply PMap.gso.
  red; intro; subst n. elim H0; intro. tauto. congruence.
  tauto.
Qed.

Lemma propagate_successors_invariant:
  forall pc instr res rem,
  code!pc = Some instr ->
  state_invariant (mkstate res (pc :: rem)) ->
  state_invariant
    (propagate_successors basic_block_map (successors instr)
                          (transf pc res!!pc)
                          (mkstate res rem)).
Proof.
  intros until rem. intros CODE [INV1 INV2]. simpl in INV1. simpl in INV2.
  set (l := transf pc res!!pc).
  generalize (propagate_successors_charact1 basic_block_map
                (successors instr) l (mkstate res rem)).
  generalize (propagate_successors_charact2 basic_block_map
                (successors instr) l (mkstate res rem)).
  set (st1 := propagate_successors basic_block_map
                 (successors instr) l (mkstate res rem)).
  intros U V. simpl in U.
  (* First part: BB entries remain at top *)
  split; intros.
  elim (U n); intros C D. rewrite D. simpl. apply INV1. auto. tauto.
  (* Second part: monotonicity *)
  (* Case 1: n = pc *)
  destruct (peq pc n). subst n.
  right; intros.
  assert (instr0 = instr) by congruence. subst instr0.
  elim (U s); intros C D.
  replace (st1.(aval)!!pc) with res!!pc. fold l.
  destruct (basic_block_map s) eqn:BB.
  rewrite D. simpl. rewrite INV1. apply L.top_ge. auto. tauto.
  elim (C H0 (refl_equal _)). intros X Y. rewrite Y. apply L.refl_ge.
  elim (U pc); intros E F. rewrite F. reflexivity.
  destruct (In_dec peq pc (successors instr)).
  right. eapply no_self_loop; eauto.
  left; auto.
  (* Case 2: n <> pc *)
  elim (INV2 n); intro.
  (* Case 2.1: n was already in worklist, still is *)
  left. apply V. simpl. tauto.
  (* Case 2.2: n was not in worklist *)
  assert (INV3: forall s instr', code!n = Some instr' -> In s (successors instr') -> st1.(aval)!!s = res!!s).
    (* Amazingly, successors of n do not change.  The only way
       they could change is if they were successors of pc as well,
       but that gives them two different predecessors, so
       they are basic block heads, and thus do not change! *)
    intros. elim (U s); intros C D. rewrite D. reflexivity.
    destruct (In_dec peq s (successors instr)).
    right. eapply multiple_predecessors with (n1 := pc) (n2 := n); eauto.
    left; auto.
  destruct (In_dec peq n (successors instr)).
  (* Case 2.2.1: n is a successor of pc. Either it is in the
     worklist or it did not change *)
  destruct (basic_block_map n) eqn:BB.
  right; intros.
  elim (U n); intros C D. rewrite D. erewrite INV3; eauto.
  tauto.
  left. elim (U n); intros C D. elim (C i BB); intros. auto.
  (* Case 2.2.2: n is not a successor of pc. It did not change. *)
  right; intros.
  elim (U n); intros C D. rewrite D.
  erewrite INV3; eauto.
  tauto.
Qed.

Lemma propagate_successors_invariant_2:
  forall pc res rem,
  code!pc = None ->
  state_invariant (mkstate res (pc :: rem)) ->
  state_invariant (mkstate res rem).
Proof.
  intros until rem. intros CODE [INV1 INV2]. simpl in INV1. simpl in INV2.
  split; simpl; intros.
  apply INV1; auto.
  destruct (INV2 n) as [[U | U] | U].
  subst n. right; intros; congruence.
  auto.
  auto.
Qed.

Lemma initial_state_invariant:
  state_invariant (mkstate (PMap.init L.top) (basic_block_list basic_block_map)).
Proof.
  split; simpl; intros.
  apply PMap.gi.
  right. intros. repeat rewrite PMap.gi. apply L.top_ge.
Qed.

Lemma analyze_invariant:
  forall res,
  fixpoint = Some res ->
  state_invariant (mkstate res nil).
Proof.
  unfold fixpoint; intros. pattern res.
  eapply (PrimIter.iterate_prop _ _ (step basic_block_map)
           state_invariant).

  intros st INV. destruct st as [stin stwrk].
  unfold step. simpl. destruct stwrk as [ | pc rem ] eqn:WRK.
  auto.
  destruct (code!pc) as [instr|] eqn:CODE.
  eapply propagate_successors_invariant; eauto.
  eapply propagate_successors_invariant_2; eauto.

  eauto. apply initial_state_invariant.
Qed.

(** ** Correctness of the returned solution *)

Theorem fixpoint_solution:
  forall res n instr s,
  fixpoint = Some res ->
  code!n = Some instr -> In s (successors instr) ->
  L.ge res!!s (transf n res!!n).
Proof.
  intros.
  assert (state_invariant (mkstate res nil)).
  eapply analyze_invariant; eauto.
  elim H2; simpl; intros.
  elim (H4 n); intros.
  contradiction.
  eauto.
Qed.

Theorem fixpoint_entry:
  forall res,
  fixpoint = Some res ->
  res!!entrypoint = L.top.
Proof.
  intros.
  assert (state_invariant (mkstate res nil)).
  eapply analyze_invariant; eauto.
  elim H0; simpl; intros.
  apply H1. unfold basic_block_map, is_basic_block_head.
  fold predecessors. apply peq_true.
Qed.

(** ** Preservation of a property over solutions *)

Definition Pstate (st: state) : Prop :=
  forall pc, P st.(aval)!!pc.

Lemma propagate_successors_P:
  forall bb l,
  P l ->
  forall succs st,
  Pstate st ->
  Pstate (propagate_successors bb succs l st).
Proof.
  induction succs; simpl; intros.
  auto.
  case (bb a). auto.
  apply IHsuccs. red; simpl; intros.
  rewrite PMap.gsspec. case (peq pc a); intro.
  auto. apply H0.
Qed.

Theorem fixpoint_invariant:
  forall res pc, fixpoint = Some res -> P res!!pc.
Proof.
  unfold fixpoint; intros. pattern res.
  eapply (PrimIter.iterate_prop _ _ (step basic_block_map) Pstate).

  intros st PS. unfold step. destruct (st.(worklist)).
  apply PS.
  assert (PS2: Pstate (mkstate st.(aval) l)).
    red; intro; simpl. apply PS.
  destruct (code!p) as [instr|] eqn:CODE.
  apply propagate_successors_P. eauto. auto.
  auto.

  eauto.
  red; intro; simpl. rewrite PMap.gi. apply Ptop.
Qed.

End Solver.

End BBlock_solver.

(** ** Node sets *)

(** We now define implementations of the [NODE_SET] interface
  appropriate for forward and backward dataflow analysis.
  As mentioned earlier, we aim for a traversal of the CFG nodes
  in reverse postorder (for forward analysis) or postorder
  (for backward analysis).  We take advantage of the following
  fact, valid for all CFG generated by translation from Cminor:
  the enumeration [n-1], [n-2], ..., 3, 2, 1 where [n] is the
  top CFG node is a reverse postorder traversal.
  Therefore, for forward analysis, we will use an implementation
  of [NODE_SET] where the [pick] operation selects the
  greatest node in the working list.  For backward analysis,
  we will similarly pick the smallest node in the working list. *)

Require Import Heaps.

Module NodeSetForward <: NODE_SET.
  Definition t := PHeap.t.
  Definition empty := PHeap.empty.
  Definition add (n: positive) (s: t) : t := PHeap.insert n s.
  Definition pick (s: t) :=
    match PHeap.findMax s with
    | Some n => Some(n, PHeap.deleteMax s)
    | None => None
    end.
  Definition all_nodes {A: Type} (code: PTree.t A) :=
    PTree.fold (fun s pc instr => PHeap.insert pc s) code PHeap.empty.
  Definition In := PHeap.In.

  Lemma empty_spec:
    forall n, ~In n empty.
  Proof.
    intros. apply PHeap.In_empty.
  Qed.

  Lemma add_spec:
    forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
  Proof.
    intros. rewrite PHeap.In_insert. unfold In. intuition.
  Qed.

  Lemma pick_none:
    forall s n, pick s = None -> ~In n s.
  Proof.
    intros until n; unfold pick. caseEq (PHeap.findMax s); intros.
    congruence.
    apply PHeap.findMax_empty. auto.
  Qed.

  Lemma pick_some:
    forall s n s', pick s = Some(n, s') ->
    forall n', In n' s <-> n = n' \/ In n' s'.
  Proof.
    intros until s'; unfold pick. caseEq (PHeap.findMax s); intros.
    inv H0.
    generalize (PHeap.In_deleteMax s n n' H). unfold In. intuition.
    congruence.
  Qed.

  Lemma all_nodes_spec:
    forall A (code: PTree.t A) n instr,
    code!n = Some instr -> In n (all_nodes code).
  Proof.
    intros A code n instr.
    apply PTree_Properties.fold_rec with
      (P := fun m set => m!n = Some instr -> In n set).
    (* extensionality *)
    intros. apply H0. rewrite H. auto.
    (* base case *)
    rewrite PTree.gempty. congruence.
    (* inductive case *)
    intros. rewrite PTree.gsspec in H2. rewrite add_spec.
    destruct (peq n k). auto. eauto.
  Qed.
End NodeSetForward.

Module NodeSetBackward <: NODE_SET.
  Definition t := PHeap.t.
  Definition empty := PHeap.empty.
  Definition add (n: positive) (s: t) : t := PHeap.insert n s.
  Definition pick (s: t) :=
    match PHeap.findMin s with
    | Some n => Some(n, PHeap.deleteMin s)
    | None => None
    end.
  Definition all_nodes {A: Type} (code: PTree.t A) :=
    PTree.fold (fun s pc instr => PHeap.insert pc s) code PHeap.empty.
  Definition In := PHeap.In.

  Lemma empty_spec:
    forall n, ~In n empty.
  Proof NodeSetForward.empty_spec.

  Lemma add_spec:
    forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
  Proof NodeSetForward.add_spec.

  Lemma pick_none:
    forall s n, pick s = None -> ~In n s.
  Proof.
    intros until n; unfold pick. caseEq (PHeap.findMin s); intros.
    congruence.
    apply PHeap.findMin_empty. auto.
  Qed.

  Lemma pick_some:
    forall s n s', pick s = Some(n, s') ->
    forall n', In n' s <-> n = n' \/ In n' s'.
  Proof.
    intros until s'; unfold pick. caseEq (PHeap.findMin s); intros.
    inv H0.
    generalize (PHeap.In_deleteMin s n n' H). unfold In. intuition.
    congruence.
  Qed.

  Lemma all_nodes_spec:
    forall A (code: PTree.t A) n instr,
    code!n = Some instr -> In n (all_nodes code).
  Proof NodeSetForward.all_nodes_spec.
End NodeSetBackward.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Relations.

From Undecidability.MinskyMachines
  Require Import MMA mma_defs ndMM2.

From Undecidability.Shared.Libs.DLW
  Require Import utils Vec.pos Vec.vec Code.subcode Code.sss.

From Undecidability.Synthetic
  Require Import Definitions ReducibilityFacts.

Set Implicit Arguments.

Local Tactic Notation "vec2" hyp(v) "into" ident(x) ident(y) :=
    vec split v with x; vec split v with y; vec nil v; clear v.

Section MMA2_ndMM2.

  Notation STOPₙ := (@ndmm2_stop _).
  Notation INCₙ  := (@ndmm2_inc _).
  Notation DECₙ  := (@ndmm2_dec _).
  Notation ZEROₙ := (@ndmm2_zero _).

  Notation α := true.
  Notation β := false.

  Infix "∊" := In (at level 70).
  Infix "⊆" := incl (at level 70).

  Notation ø := vec_nil.

  Definition pos2_to_bool (p : pos 2) :=
    match p with pos0 => α | _ => β end.

  Notation "⌈ p ⌉" := (pos2_to_bool p) (at level 1, format "⌈ p ⌉").

  Definition mma2_instr_enc i (ρ : mm_instr (pos 2)) :=
    match ρ with
      | INCₐ x   => INCₙ ⌈x⌉ i (1+i) :: nil
      | DECₐ x j => DECₙ ⌈x⌉ i j :: ZEROₙ ⌈x⌉ i (1+i) :: nil
    end.

  Notation "'⟨' i , ρ '⟩₁'" := (mma2_instr_enc i  ρ) (format "⟨ i , ρ ⟩₁").

  Reserved Notation "'⟪' i , l '⟫ₗ'" (at level 1, format "⟪ i , l ⟫ₗ").

  Fixpoint mma2_linstr_enc i l :=
    match l with
      | nil  => nil
      | ρ::l => ⟨i,ρ⟩₁ ++ ⟪1+i,l⟫ₗ
    end
  where "⟪ i , l ⟫ₗ" := (mma2_linstr_enc i l).

  Fact mma2_linstr_enc_app i l m : ⟪i,l++m⟫ₗ = ⟪i,l⟫ₗ ++ ⟪length l+i,m⟫ₗ.
  Proof.
    revert i; induction l as [ | ? l IHl ]; intros ?; simpl; auto.
    rewrite app_ass, IHl; do 3 f_equal; auto.
  Qed.

  Fact mma2_linstr_enc_In i P c :
          c ∊ ⟪i,P⟫ₗ -> exists L ρ R, P = L++ρ::R /\ c ∊ ⟨length L+i,ρ⟩₁.
  Proof.
    revert i; induction P as [ | ρ P IH ]; intros i.
    + intros [].
    + simpl; rewrite in_app_iff; intros [ H | H ].
      * exists nil, ρ, P; split; auto.
      * destruct (IH (1+i)) as (l & ρ' & r & H1 & H2); auto.
        exists (ρ::l), ρ', r; split; auto.
        - simpl; f_equal; auto.
        - eq goal H2; do 2 f_equal; simpl; lia.
  Qed.

  Notation "Σ //ₙ a ⊕ b ⊦ u" := (ndmm2_accept Σ a b u) (at level 70, no associativity).

  Notation "ρ //ₐ s -1> t" := (mma_sss ρ s t) (at level 70, no associativity).
  Notation "P //ₐ r :1> s" := (sss_step (@mma_sss _) P r s)  (at level 70, no associativity).
  Notation "P //ₐ s ->> t" := (sss_compute (@mma_sss _) P s t) (at level 70, no associativity).
  Notation "P //ₐ s ~~> t" := (sss_output (@mma_sss _) P s t) (at level 70, no associativity).

  Tactic Notation "state" "rebuild" ident(s) hyp(i) hyp(a) hyp(b) :=
    set (s := (i,a##b##ø));
    change a with (vec_pos (snd s) pos0);
    change b with (vec_pos (snd s) pos1);
    change i with (fst s).

  Hint Resolve in_eq in_cons : core.

  Local Fact mma2_instr_enc_sound Σ ρ i a b j a' b' :
          ρ //ₐ (i,a##b##ø) -1> (j,a'##b'##ø)
       -> ⟨i,ρ⟩₁ ⊆ Σ
       -> Σ //ₙ a' ⊕ b' ⊦ j
       -> Σ //ₙ a  ⊕ b  ⊦ i.
  Proof.
    state rebuild s1 i a b.
    state rebuild s2 j a' b'.
    generalize s1 s2; clear s1 s2 i a b j a' b'.
    destruct 1 as [ i x v | i x k v Hv | i x k v u Hv ]; try revert Hv;
      vec2 v into a b; repeat invert pos x; simpl.
    + constructor 2 with (1+i); auto.
    + constructor 3 with (1+i); auto.
    + intros -> ?; constructor 6 with (1+i); auto.
    + intros -> ?; constructor 7 with (1+i); auto.
    + intros -> ?; constructor 4 with k; auto.
    + intros -> ?; constructor 5 with k; auto.
  Qed.

  Local Fact mma2_step_linstr_sound Σ P i a b j a' b' :
          (1,P) //ₐ (i,a##b##ø) :1> (j,a'##b'##ø)
       -> ⟪1,P⟫ₗ ⊆  Σ
       -> Σ //ₙ a' ⊕ b' ⊦ j
       -> Σ //ₙ a  ⊕ b  ⊦ i.
  Proof.
    intros (n & L & ρ & R & v & H1 & H2 & H3).
    inversion H1; subst n P; clear H1.
    inversion H2; subst v i; clear H2.
    intros H.
    apply mma2_instr_enc_sound with (1 := H3).
    apply incl_tran with (2 := H).
    rewrite mma2_linstr_enc_app; simpl.
    rewrite Nat.add_comm.
    apply incl_appr, incl_appl, incl_refl.
  Qed.

  Variable P : list (mm_instr (pos 2)).

  Definition mma2_prog_enc := STOPₙ 0 :: ⟪1,P⟫ₗ.
  Notation ΣP := mma2_prog_enc.

  Local Lemma mma2_compute_linstr_sound i a b j a' b'  :
          (1,P) //ₐ (i,a##b##ø) ->> (j,a'##b'##ø)
       -> ΣP //ₙ a' ⊕ b' ⊦ j
       -> ΣP //ₙ a  ⊕ b  ⊦ i.
  Proof.
    intros (n & Hn); revert Hn.
    state rebuild s1 i a b.
    state rebuild s2 j a' b'.
    generalize s1 s2; clear s1 s2 i a b j a' b'.
    induction 1 as [ (i,v) | n (i,u) (j,v) (k,w) H1 H2 IH2 ]; simpl; auto.
    revert H1 H2 IH2; vec2 u into au bu; vec2 v into av bv; vec2 w into aw bw.
    simpl; intros H1 H2 IH3 H; generalize (IH3 H).
    apply mma2_step_linstr_sound with (1 := H1), incl_tl, incl_refl.
  Qed.

  Local Lemma mma2_prog_enc_stop : ΣP //ₙ 0 ⊕ 0 ⊦ 0.
  Proof. constructor 1; simpl; auto. Qed.

  Hint Resolve mma2_prog_enc_stop : core.

  Local Lemma mma2_prog_enc_sound i a b  :
          (1,P) //ₐ (i,a##b##ø) ->> (0,0##0##ø) -> ΣP //ₙ a  ⊕ b  ⊦ i.
  Proof. intros H; apply mma2_compute_linstr_sound in H; auto. Qed.

  Local Lemma mma2_prog_enc_complete a b i :
             ΣP //ₙ a ⊕ b ⊦ i -> (1,P) //ₐ (i,a##b##ø) ->> (0,0##0##ø).
  Proof.
    induction 1 as [ u H
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | b p u H H1 IH1
                   | a p u H H1 IH1 ].
    + destruct H as [ H | H ].
      * inversion H; subst u.
        exists 0; constructor 1.
      * apply mma2_linstr_enc_In in H
          as (l & [ x | x ] & r & H1 & H2); repeat invert pos x; simpl in H2.
        1-2: now destruct H2.
        1-2: now destruct H2 as [ | [] ].
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      2: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss INC with pos0.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss INC with pos1.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC S with pos0 v a.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC S with pos1 v b.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x j ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC zero with pos0 j.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x j ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC zero with pos1 j.
      mma sss stop.
  Qed.

  Theorem MMA2_ndMM2_equiv a b : (1,P) //ₐ (1,a##b##ø) ~~> (0,0##0##ø)
                             <-> ΣP //ₙ a ⊕ b ⊦ 1.
  Proof.
    split.
    + intros []; apply mma2_prog_enc_sound; auto.
    + split.
      * now apply mma2_prog_enc_complete.
      * simpl; lia.
  Qed.

End MMA2_ndMM2.

Theorem reduction : MMA2_HALTS_ON_ZERO ⪯ @ndMM2_ACCEPT nat.
Proof.
  apply reduces_dependent; exists.
  intros (P & v); vec2 v into a b.
  exists (existT _ (mma2_prog_enc P) (1,(a,b))).
  apply MMA2_ndMM2_equiv.
Qed.