From Coq Require Import String Ensembles List Lia.
From RelationAlgebra Require Import prop monoid kat relalg kat_tac.
From Catincoq.lib Require Import defs Cat proprel tactics oneofeach relalglaws.

(** This file uses fun and prop extensionalities in many places, it's
not sure yet whether we will get rid of them or just add them as
axioms and simplify the proofs everywhere *)

Axiom functional_extensionality : forall {A B} (f g : A -> B), (forall x, f x = g x) -> f = g.
Axiom propositional_extensionality : forall (P Q : Prop), P <-> Q -> P = Q.

Lemma rel_ext : forall {A} (R S : relation A), R ≡ S -> R = S.
Proof.
  intros A R S e.
  apply functional_extensionality; intros x.
  apply functional_extensionality; intros y.
  apply propositional_extensionality, e.
Qed.

Lemma sig_ext : forall {A} (P : A -> Prop) (x y : sig P), proj1_sig x = proj1_sig y -> x = y.
Proof.
  intros A P [x px] [y py]. simpl. intros <-. f_equal.
  apply Coq.Logic.ClassicalFacts.ext_prop_dep_proof_irrel_cic.
  hnf.
  apply propositional_extensionality.
Qed.

Lemma set_ext {A} (E E' : set A) : E ≡ E' <-> E = E'.
Proof.
  split. 2:intros ->; auto.
  intros e.
  apply functional_extensionality; intros x.
  apply propositional_extensionality, e.
Qed.

Lemma to_set_cap {A} E F : Intersection A E F ≡ E ⊓ F.
Proof.
  intros x; split; intros []; split; auto.
Qed.

Lemma set_weq {A} (E E' : set A) :
  (forall a, E a <-> E' a) -> E ≡ E'.
Proof.
  firstorder.
Qed.

Instance Inhabited_leq A : Proper (flip leq --> impl) (Inhabited A).
Proof.
  compute. firstorder.
Qed.

Instance Inhabited_weq A : Proper (weq --> iff) (Inhabited A).
Proof.
  compute. firstorder.
Qed.

(** TODO remove this def *)
(* if R is a partial strict order R, then S extends R, is a strict
   order, and is "total along" the equivalence relation ER *)
Definition extends_along {A} (R ER S : relation A) :=
  R ≦ S /\
  is_strict_order S /\
  ER ≡ S ⊔ S° ⊔ 1.

(* TODO remove *)
(* Definition equivalence_classes_sig {A} (R : relation A) : Ensemble A -> Type := *)
(*   fun C => { x | C x /\ forall y, R x y <-> C y }. *)

Lemma loc_sym_ {c} (x y : events c) : loc c x y <-> loc c y x.
Proof.
  split; apply loc_sym.
Qed.

Lemma loc_sym__ {c} : (loc c)° ≡ loc c.
Proof.
  split; apply loc_sym.
Qed.

(** below, trying to define [location] as [loc] equivalence classes,
    but that seems convoluted, it's probably better to define
    [location] in Cat.v *)
(** this can be implemented with [equivalence_classes] but it seems
backwards, so maybe we should define [loc] with [location_of] instead *)
Definition location (c : candidate) : Type := sig (equivalence_classes (loc c)).

Program Definition location_of {c} (x : events c) : location c
  := exist _ (fun y => loc _ x y) (ex_intro _ x (conj (loc_refl c _) ltac:(tauto))).

Lemma location_of_spec : forall c x y , location_of x = location_of y <-> loc c x y.
Proof.
  intros c x y; split.
  - intros [=e]. change ((fun y : events c => loc c x y) y). rewrite e. apply loc_refl.
  - intros e. apply sig_ext. simpl.
    apply functional_extensionality; intros z.
    apply propositional_extensionality; split.
    + intros. apply loc_trans with x; auto. now apply loc_sym.
    + intros. apply loc_trans with y; auto.
Qed.

Lemma location_of_surj : forall {c} (l : location c), exists e, location_of e = l.
Proof.
  intros c [C (x & Cx & xC)]. exists x. apply sig_ext; simpl.
  apply functional_extensionality; intros z.
  apply propositional_extensionality; split; apply xC.
Qed.

Definition atloc {c} (l : location c) : set (events c) := fun e => location_of e = l.

(*
(** this can be implemented with [equivalence_classes] but it seems
backwards, so maybe we should define [loc] with [location_of] instead *)
(* Definition location (c : candidate) : Type := equivalence_classes (loc c). *)
Variable location : candidate -> Type.
Variable location_eq_dec : forall {c} (l1 l2 : location c), {l1 = l2} + {l1 <> l2}.
Variable location_of : forall {c}, events c -> location c.
Variable location_of_spec : forall c (e1 e2 : events c),
    location_of e1 = location_of e2 <-> loc c e1 e2.
Variable location_of_surj : forall {c} (l : location c), exists e, location_of e = l.
Program Definition atloc {c} (l : location c) : set (events c) :=
  fun e => exist _ (location_of e = l) _.
Next Obligation. destruct (location_eq_dec (location_of e) l); auto. Defined.
*)

(* TODO eliminate these definitions? *)
Definition strict_total_order_on {A}  (E : set A) (R : relation A) :=
  is_strict_order R /\
  R ≦ [E] ⋅ top ⋅ [E] /\
  total_on E R.

(*
Definition linear_extension_on {A} (E : set A) (R S : relation A) :=
  R ≦ S /\ strict_total_order_on E S.
*)

(** [linearisations E R] is the set of strict total orders that
contain ([R] restricted to [E]). When [R] is not itself transitive, it
is possible that the result is different from [linearisations E (R^+)]
*)

(*
Definition linearisations {A} (E : set A) (R : relation A)
  : Ensemble (relation A)
  := fun S => strict_total_order_on E S /\ [E] ⋅ R ⋅ [E] ≦ S.
*)
(*
Definition linearisations' {A} (E : Ensemble A) (R : relation A)
  : Ensemble (relation A)
  := fun S => strict_total_order_on' E S /\ [E] ⋅ R ⋅ [E] ≦ S.
*)

(* the finite version of this is proved in zoo.v *)

Lemma strict_order_of_acyclic {A} (R : relation A) :
  acyclic R <-> is_strict_order (R^+).
Proof.
  unfold acyclic, is_strict_order, is_transitive, relalg.is_irreflexive. intuition hkat.
Qed.

(*
(* TODO unused? *)
Lemma linearisations_exist {A} (E : set A) (R : relation A) :
  finite_set E ->
  acyclic ([E] ⋅ R ⋅ [E]) -> exists S, linearisations E R S.
Proof.
  intros F OR % strict_order_of_acyclic.
  destruct (every_strict_order_can_be_total_on E (([E]⋅R⋅[E])^+)) as (S & OS & SE & Tot & RS);
    try (intros; apply Classical_Prop.classic).
  assumption.
  now apply is_strict_order_spec.
  exists S. split. split; auto. now apply is_strict_order_spec.
  repeat (easy || split). rewrite <-RS. kat.
Qed.
*)

Lemma partition_spec {c} (E : Ensemble (events c)) (E' : Ensemble (events c)) :
  partition (loc c) E E' <-> Inhabited _ E' /\ exists l, E' ≡ atloc l ⊓ E.
Proof.
  split.
  - intros (i & C & Ceq & ->). split; auto.
    destruct Ceq as (x & Cx & xC).
    exists (location_of x).
    rewrite to_set_cap.
    enough (C ≡ atloc (location_of x)) as ->. now apply capC.
    apply set_weq. simpl. intros y. now rewrite <-xC, <-location_of_spec.
  - intros (i & l & e). split; auto. eexists (atloc l). split.
    + destruct (location_of_surj l) as (x, <-). exists x. split. easy.
      intros y. rewrite <-location_of_spec. easy.
    + apply Extensionality_Ensembles'; split.
      * intros x ex. split; apply e, ex.
      * intros x []. apply e; split; auto.
Qed.

(* Previous definition that included sets that were too small: *)
(* Definition partition {A} (equiv : relation A) (X : Ensemble A) *)
(*   : Ensemble (Ensemble A) *)
(*   := fun Xi => (forall x, Xi x -> X x) /\ forall x y, Xi x -> Xi y -> equiv x y. *)

Lemma union_of_relations_leq {A} Rs (S : relation A) :
  union_of_relations Rs ≦ S <-> forall R, Rs R -> R ≦ S.
Proof.
  split.
  - intros L R r. rewrite <-L. intros x y xy. exists R; auto.
  - intros L x y (R & r & xy). eapply L; eauto.
Qed.

(* All linearisations of [R] along different [sets] *)
Definition co_locs {A} (R : relation A) (sets : Ensemble (Ensemble A))
  : Ensemble (Ensemble (relation A))
  := subset_image (fun E => linearisations E R) sets.

(* TODO remove the definition above -- as long as the lemma below is
proved, the rest of this file (and probably all the repo) will work *)
Lemma co_locs_partition_spec {c} R E S :
  co_locs R (partition (loc c) E) S <->
  exists l, Inhabited _ (E ⊓ atloc l) /\ S = linearisations (E ⊓ atloc l) R.
Proof.
  split.
  - intros (E' & (i & C & (x & Cx & xC) & ->) & ->).
    exists (location_of x).
    enough (Intersection (events c) E C = E ⊓ atloc (location_of x)) as <-; auto.
    apply set_ext.
    rewrite to_set_cap, set_ext. f_equal. apply set_ext.
    intros a. rewrite <-xC, <-location_of_spec. unfold atloc. split; auto.
  - intros (l & i & ->).
    unfold co_locs, subset_image.
    set (x := (E ⊓ atloc l)). exists x. subst x.
    split; auto.
    rewrite partition_spec. split; auto.
    exists l. now rewrite capC.
Qed.

(*
Definition cross {A} (S : Ensemble (Ensemble (relation A)))
  : Ensemble (relation A)
  := subset_image union_of_relations (one_of_each S).
*)

Definition generate_orders A (loc : relation A) (s : set A) (pco : relation A)
  : Ensemble (relation A)
  := cross (co_locs pco (partition loc s)).

(* alternate specification for [generate_orders E R S], that is, [S]
must relate any two [R]-related [E] events at the same location, and
be a linearisation of [E] on each location *)

Lemma co_locs_located {c} R (E : set _) x (Ex : E x) :
  co_locs R (partition (loc c) E) (linearisations (E ⊓ atloc (location_of x)) R).
Proof.
  apply co_locs_partition_spec; eexists; split; [ | easy ].
  exists x; easy.
Qed.

(* TODO when done, maybe remove: *)
Lemma co_locs_colocated {c} R (E : set _) x y (Ey : E y) (xy : loc c x y) :
  co_locs R (partition (loc c) E) (linearisations (E ⊓ atloc (location_of x)) R).
Proof.
  apply co_locs_partition_spec; eexists; split; [ | easy ].
  exists y; split; auto. apply location_of_spec, loc_sym, xy.
Qed.

Lemma co_locs_atloc {c} R (E : set _) l x (Ex : E x) (lx : atloc l x) :
  co_locs R (partition (loc c) E) (linearisations (E ⊓ atloc l) R).
Proof.
  apply co_locs_partition_spec; eexists; split; [ | easy ].
  exists x; easy.
Qed.

Lemma co_locs_inhabited {c} R (E : set _) x :
  Inhabited (events c) (E ⊓ atloc (location_of x)) ->
  co_locs R (partition (loc c) E) (linearisations (E ⊓ atloc (location_of x)) R).
Proof.
  intro i.
  apply co_locs_partition_spec; eauto.
Qed.

Lemma generate_orders_spec_3 {c} E (R S : relation (events c)) :
  generate_orders (events c) (loc c) E R S <->
  (R ⊓ [E] ⋅ loc c ⋅ [E]) ≦ S
  /\ S ≦ loc c
  /\ forall l, strict_total_order_on (E ⊓ atloc l) ([atloc l] ⋅ S ⋅ [atloc l]).
Proof.
  split.
  - (* Let [f] be the function choosing the linearisation for each
    location. [S] is the union of all those linearisations. *)
    intros [rels [(f & f_sound & (f_tot & f_fun) & ->%Extensionality_Ensembles') ->]].
    split; [ | split ].
    + intros x y.
      destruct_rel.
      pose (l := location_of x).
      (* pose (R' := ([E ⊓ atloc l] ⋅ R ⋅ [E ⊓ atloc l])). *)
      specialize (f_tot (linearisations (E ⊓ atloc l) R)). apply proj1 in f_tot.
      destruct f_tot as [S RS]. now apply co_locs_located.
      exists S. split. eexists. split; eauto. now apply co_locs_located.
      apply f_sound in RS. destruct RS as (_ & _ & _ & RS). apply RS.
      * exists y; auto. exists x; auto. repeat (split; auto). repeat (split; auto). simpl.
        subst l. symmetry. now apply location_of_spec.
    + apply union_of_relations_leq.
      intros S (Rl & (l & i & ->) % co_locs_partition_spec & RS). apply f_sound in RS.
      destruct RS as (_ & e & _ & _). rewrite e.
      intros x y.
      rewrite tst_dot_tst.
      intros ((_, ?) & _ & (_, ?)).
      apply location_of_spec.
      congruence.
    + (* Let us prove that this union of relation is a strict total
         order for each location*)
      intros l; split; split.
      * (* irreflexivity *)
        unfold relalg.is_irreflexive. apply antisym; [ | ka ].
        assert ([atloc l] ≦ 1) as -> by kat. ra_normalise.
        intros x y [(S, ((R' & (aa & bb & ->)
                          & ((ST, SI) & Sdom & Stot & RS) % f_sound), xx)) <-].
        apply SI. split; easy.
      * (* transitivity *)
        unfold is_transitive.
        intros x z [y xy yz].
        specialize (f_tot (linearisations (E ⊓ atloc (location_of x)) R)).
        apply proj1 in f_tot.
        rewrite tst_dot_tst in *.
        destruct xy as (lx & xy & ly).
        destruct yz as (_  & yz & lz).
        destruct xy as (T & (R' & (l' & i & ->) % co_locs_partition_spec & fRT) & xy).
        destruct yz as (U & (R' & (l'' & i' & ->) % co_locs_partition_spec & fRU) & yz).
        split; auto. split; auto.
        destruct (f_sound _ _ fRT) as ((TT & TI) & TE & ET & RT).
        destruct (f_sound _ _ fRU) as ((TU & UI) & UE & EU & RU).
        assert (l' = location_of x /\ l' = location_of y) as [].
        { (* TODO automate this *)
          apply TE in xy. destruct xy as [? [? [<- [_ ?]]] [-> [_ ?]]]. easy. }
        assert (l'' = location_of y /\ l'' = location_of z) as [].
        { (* TODO automate this *)
          apply UE in yz. destruct yz as [? [? [<- [_ ?]]] [-> [_ ?]]]. easy. }
        subst l' l''.
        replace (location_of y) with (location_of x) in fRU.
        assert (T = U) by now eapply f_fun; eauto. subst T.
        exists U. split. 2: now apply TU; exists y; auto.
        eexists. split; eauto. now apply co_locs_inhabited.
      * (* domain/range are in [E] *)
        intros x y xy.
        rewrite tst_dot_tst in xy. destruct xy as (lx & xy & ly).
        destruct xy as (S & (qdw & (l' & i & ->) % co_locs_partition_spec
                          & (OS & SE & ES & RS) % f_sound) & xy).
        apply SE in xy.
        rewrite tst_dot_tst in xy. destruct xy as ((Ex, l'x) & _ & (Ey, l'y)).
        assert (l = l') as <- by now rewrite <-lx, <-l'x.
        rewrite tst_dot_tst. easy.
      * (* totality on [E ⊓ atloc l] *)
        unfold total_on.
        elim_cnv. ra_normalise.
        intros x y xy.
        pose proof xy as xy'.
        rewrite tst_dot_tst in xy. destruct xy as ((l'x, Ex) & _ & (l'y, Ey)).
        specialize (f_tot (linearisations (E ⊓ atloc l) R)). apply proj1 in f_tot.
        destruct f_tot as [S fRS]. now eapply co_locs_atloc; eauto.
        destruct (f_sound _ _ fRS) as ((SI & ST) & SE & ES & RS).
        destruct (ES x y) as [xy | yx]. now auto.
        -- left.
           rewrite tst_dot_tst.
           intuition.
           exists S; intuition.
           eexists; split; eauto.
           now eapply co_locs_atloc; eauto.
        -- right.
           rewrite tst_dot_tst.
           intuition.
           exists S; intuition.
           eexists; split; eauto.
           now eapply co_locs_atloc; eauto.
  - (* suppose [S] covers [R ⊓ loc] on [E], that [S ≦ loc] and that it
       is a strict total order on each location. We show it satisfies
       [generate_orders] *)
    intros (RS & Sloc & ES).
    assert (Slocx : forall x y l,
               S x y -> l = location_of x ->
               ([E ⊓ atloc l] ⋅ S ⋅ [E ⊓ atloc l]) x y).
    { intros x y l xy ->. destruct (ES (location_of x)) as (_ & SE & _).
      spec SE x y. hnf in SE. spec SE.
      - rewrite tst_dot_tst; intuition. reflexivity.
        apply location_of_spec, loc_sym, Sloc, xy.
      - rewrite tst_dot_tst in *. tauto. }
    (* [S] is the union of all its restrictions to a location... that
       are not empty (this is necessary since [partition] excludes
       empty sets) *)
    exists (fun Sl : relation _ => exists l, Inhabited _ (E ⊓ atloc l)
                                /\ Sl = [atloc l]⋅S⋅[atloc l]).
    split; swap 1 2.
    + apply rel_ext, antisym; intros x y xy.
      * exists ([atloc (location_of x)]⋅S⋅[atloc (location_of x)]).
        split.
        -- exists (location_of x); split; auto. exists x. split. 2: easy.
           eapply Slocx in xy. rewrite tst_dot_tst in xy. apply xy. reflexivity.
        -- pose proof (Slocx x y _ xy eq_refl).
           destruct_rel. rewrite tst_dot_tst; tauto.
      * destruct xy as (? & (l & i & ->) & xy).
        rewrite tst_dot_tst in xy.
        easy.
    + (* Choice function: for each set of linearisations on a given
         location, we unsurprisingly choose the one restriction of [S]
         to this location. We must also not choose anything when the
         set is empty. *)
      pose (f :=
              fun Rs fRs =>
                exists l, Inhabited _ (E ⊓ atloc l) /\
                  Rs = linearisations (E ⊓ atloc l) R /\
                  fRs = [atloc l] ⋅ S ⋅ [atloc l]).
      exists f. split. 2:split. 2:split.
      * (* f is a _sound_ choice function *)
        intros Rs fRs. subst f. intros (l & i & -> & ->). split!; apply ?(ES l).
        now apply is_irreflexive_spec2, (ES l).
        rewrite <-RS.
        intros x y xy.
        rewrite tst_dot_tst in *.
        destruct xy as ((Ex, lx) & xy & (Ey, ly)). intuition. split; auto.
        rewrite tst_dot_tst. intuition.
        apply location_of_spec. now rewrite lx, ly.
      * (* the domain of f is correct *)
        intros Rs. rewrite co_locs_partition_spec.
        split.
        -- intros (l & i & ->). eexists. exists l. eauto.
        -- intros (R1 & l & i & -> & _). eauto.
      * (* f is a function(al relation) *)
        intros Rs.
        enough (H : forall b b' : relation (events c), f Rs b -> f Rs b' -> b ≦ b').
        { intros b b' e e'. apply rel_ext, antisym; eauto. }
        intros S1 S2 (l1 & i1 & e1 & ->) (l2 & i2 & e2 & ->).
        pose proof ES l1 as Sl1.
        pose proof ES l2 as Sl2.
        assert (HS : linearisations (E ⊓ atloc l1) R ([atloc l1]⋅S⋅[atloc l1])).
        { split!; apply ?(ES l1). apply is_irreflexive_spec2, (ES l1).
          rewrite <-RS.
          intros x y ((ex & x2) & xy & (ey & y2)) % tst_dot_tst.
          rewrite tst_dot_tst. intuition. split; auto.
          rewrite tst_dot_tst. intuition. apply location_of_spec. congruence.
        }
        rewrite <-e1, e2 in HS. destruct HS as (OS & S12 & _ & _).
        intros x y xy.
        pose proof (S12 _ _ xy) as ((_ & x2) & _ & (_ & y2)) % tst_dot_tst.
        rewrite tst_dot_tst in *.
        intuition.
      * (* [fun Sl => ...] is indeed the image through this function *)
        split.
        -- intros R1 (l & i & ->).
           eexists. split. apply co_locs_partition_spec. exists l; auto.
           exists l. auto.
        -- intros R1 (Rs_ & (l & i & ->)%co_locs_partition_spec & (l' & i' & D & ->)).
           exists l'. split; auto.
Qed.

Lemma generate_orders_total {c} E (R S : relation (events c)) :
  generate_orders (events c) (loc c) E R S -> [E] ⋅ loc c ⋅ [E] ≦ S ⊔ S° ⊔ 1.
Proof.
  intros (RS & Sloc & SO) % generate_orders_spec_3.
  intros x y (ex & xy & ey) % tst_dot_tst.
  destruct (SO (location_of x)) as (A & B & C).
  destruct (Classical_Prop.classic (x = y)) as [<- | n]. now right. left.
  unfold total_on in C. elim_cnv in C. rewrite dotA in C.
  destruct (C x y) as [H|H].
  - rewrite tst_dot_tst. repeat split; auto. symmetry. now apply location_of_spec.
  - left. now rewrite tst_dot_tst in H.
  - right. now rewrite tst_dot_tst in H.
Qed.

Lemma loc_location_of {c} S : S ≦ loc c ->
 forall x y, S x y -> ([atloc (location_of x)]⋅S⋅[atloc (location_of x)]) x y.
Proof.
  intros Sloc x y xy. rewrite tst_dot_tst. intuition. easy.
  apply eq_sym, location_of_spec, Sloc, xy.
Qed.

Lemma generate_orders_total' {c} E (R S : relation (events c)) :
  generate_orders (events c) (loc c) E R S -> [E] ⋅ (!1 ⊓ loc c) ⋅ [E] ≡ S ⊔ S°.
Proof.
  intros G. apply antisym.
  - apply generate_orders_total in G.
    intros x y (ex & (n & xy) & ey) % tst_dot_tst.
    destruct (G x y). now rewrite tst_dot_tst. now auto. now destruct n.
  - apply generate_orders_spec_3 in G. destruct G as (_ & Sloc & G).
    rewrite capC, <-cap_cartes. apply leq_xcap. apply leq_xcap.
    + rewrite Sloc. rewrite loc_sym__. ra.
    + intros x y xy e.
      destruct (G (location_of x)) as ((SI & ST) & SE & ES).
      destruct xy as [xy | xy].
      * apply SI with x y. split. 2:easy. now apply loc_location_of.
      * apply SI with y x. split. 2:easy.
        rewrite tst_dot_tst. intuition. 2:easy.
        apply location_of_spec, Sloc, xy.
    + enough (S ≦ [E]⋅top⋅[E]) as ->. now elim_cnv; kat.
      (* factoriser le travail avec loc x ci-dessus *)
      intros x y xy. destruct (G (location_of x)) as ((SI & ST) & SE & ES).
      apply loc_location_of in xy; auto.
      apply SE in xy.
      rewrite tst_dot_tst in *. repeat split; apply xy.
Qed.

Lemma generate_orders_order {c} E (R S : relation (events c)) :
  generate_orders (events c) (loc c) E R S -> is_strict_order S.
Proof.
  intros (RS & Sloc & G)%generate_orders_spec_3.
  split.
  - rewrite is_irreflexive_spec2, <-is_irreflexive_spec3. intros x xx.
    apply loc_location_of in xx; auto.
    destruct (G (location_of x)) as ((SI & _) & _).
    rewrite is_irreflexive_spec2, <-is_irreflexive_spec3 in SI.
    apply (SI x xx).
  - intros x z [y xy yz].
    assert (el : location_of x = location_of y). apply location_of_spec, Sloc, xy.
    apply loc_location_of in xy; auto.
    apply loc_location_of in yz; auto. rewrite <-el in yz.
    destruct (G (location_of x)) as ((_ & ST) & _).
    specialize (ST x z ltac:(exists y; eauto)).
    rewrite tst_dot_tst in ST. tauto.
Qed.

Lemma generate_orders_dom {c} E (R S : relation (events c)) :
  generate_orders (events c) (loc c) E R S -> S ≦ [E] ⋅ S ⋅ [E].
Proof.
  rewrite generate_orders_spec_3.
  intros [_ [sl os]].
  intros  x y xy.
  apply loc_location_of in xy; auto.
  specialize (os (location_of x)).
  destruct os as (os & l & tot).
  specialize (l _ _ xy).
  destruct_rel. rewrite tst_dot_tst. tauto.
Qed.


(** * Hoare: Hoare Logic, Part I *)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Imp.
Require Import Maps.
(* /TERSE: HIDEFROMHTML *)

(** In the past couple of chapters, we've begun applying the
    mathematical tools developed in the first part of the course to
    studying the theory of a small programming language, Imp.

    - We defined a type of _abstract syntax trees_ for Imp, together
      with an _evaluation relation_ (a partial function on states)
      that specifies the _operational semantics_ of programs.

      The language we defined, though small, captures some of the key
      features of full-blown languages like C, C++, and Java,
      including the fundamental notion of mutable state and some
      common control structures.

    - We proved a number of _metatheoretic properties_ -- "meta" in
      the sense that they are properties of the language as a whole,
      rather than of particular programs in the language.  These
      included:

        - determinism of evaluation

        - equivalence of some different ways of writing down the
          definitions (e.g., functional and relational definitions of
          arithmetic expression evaluation)

        - guaranteed termination of certain classes of programs

        - correctness (in the sense of preserving meaning) of a number
          of useful program transformations

        - behavioral equivalence of programs (in the [Equiv] chapter).

    If we stopped here, we would already have something useful: a set
    of tools for defining and discussing programming languages and
    language features that are mathematically precise, flexible, and
    easy to work with, applied to a set of key properties.  All of
    these properties are things that language designers, compiler
    writers, and users might care about knowing.  Indeed, many of them
    are so fundamental to our understanding of the programming
    languages we deal with that we might not consciously recognize
    them as "theorems."  But properties that seem intuitively obvious
    can sometimes be quite subtle (sometimes also subtly wrong!).

    We'll return to the theme of metatheoretic properties of whole
    languages later in the book when we discuss _types_ and _type
    soundness_.  In this chapter, though, we turn to a different set
    of issues.

    Our goal is to carry out some simple examples of _program
    verification_ -- i.e., to use the precise definition of Imp to
    prove formally that particular programs satisfy particular
    specifications of their behavior.  We'll develop a reasoning
    system called _Floyd-Hoare Logic_ -- often shortened to just
    _Hoare Logic_ -- in which each of the syntactic constructs of Imp
    is equipped with a generic "proof rule" that can be used to reason
    compositionally about the correctness of programs involving this
    construct.

    Hoare Logic originated in the 1960s, and it continues to be the
    subject of intensive research right up to the present day.  It
    lies at the core of a multitude of tools that are being used in
    academia and industry to specify and verify real software
    systems.

    Hoare Logic combines two beautiful ideas: a natural way of
    writing down _specifications_ of programs, and a _compositional
    proof technique_ for proving that programs are correct with
    respect to such specifications -- where by "compositional" we mean
    that the structure of proofs directly mirrors the structure of the
    programs that they are about. *)

(* ################################################################# *)
(** * Assertions *)

(** To talk about specifications of programs, the first thing we
    need is a way of making _assertions_ about properties that hold at
    particular points during a program's execution -- i.e., claims
    about the current state of the memory when execution reaches that
    point.  Formally, an assertion is just a family of propositions
    indexed by a [state]. *)

Definition Assertion := state -> Prop.

(** **** Exercise: 1 star, optional (assertions)  *)
(** Paraphrase the following assertions in English (or your favorite
    natural language). *)

Module ExAssertions.
Definition as1 : Assertion := fun st => st X = 3.
Definition as2 : Assertion := fun st => st X <= st Y.
Definition as3 : Assertion :=
  fun st => st X = 3 \/ st X <= st Y.
Definition as4 : Assertion :=
  fun st => st Z * st Z <= st X /\
            ~ (((S (st Z)) * (S (st Z))) <= st X).
Definition as5 : Assertion := fun st => True.
Definition as6 : Assertion := fun st => False.
(* FILL IN HERE *)
End ExAssertions.
(** [] *)

(** This way of writing assertions can be a little bit heavy,
    for two reasons: (1) every single assertion that we ever write is
    going to begin with [fun st => ]; and (2) this state [st] is the
    only one that we ever use to look up variables in assertions (we
    will never need to talk about two different memory states at the
    same time).  For discussing examples informally, we'll adopt some
    simplifying conventions: we'll drop the initial [fun st =>], and
    we'll write just [X] to mean [st X].  Thus, instead of writing *)
(**

      fun st => (st Z) * (st Z) <= m /\
                ~ ((S (st Z)) * (S (st Z)) <= m)

    we'll write just

      Z * Z <= m /\ ~((S Z) * (S Z) <= m).
*)

(** Given two assertions [P] and [Q], we say that [P] _implies_ [Q],
    written [P ->> Q] (in ASCII, [P -][>][> Q]), if, whenever [P]
    holds in some state [st], [Q] also holds. *)

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" := (assert_implies P Q)
                      (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

(** (The [hoare_spec_scope] annotation here tells Coq that this
    notation is not global but is intended to be used in particular
    contexts.  The [Open Scope] tells Coq that this file is one such
    context.) *)

(** We'll also want the "iff" variant of implication between
    assertions: *)

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* ################################################################# *)
(** * Hoare Triples *)

(** Next, we need a way of making formal claims about the
    behavior of commands. *)

(** In general, the behavior of a command is to transform one state to
    another, so it is natural to express claims about commands in
    terms of assertions that are true before and after the command
    executes:

      - "If command [c] is started in a state satisfying assertion
        [P], and if [c] eventually terminates in some final state,
        then this final state will satisfy the assertion [Q]."

    Such a claim is called a _Hoare Triple_.  The property [P] is
    called the _precondition_ of [c], while [Q] is the
    _postcondition_.  Formally: *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
     c / st \\ st'  ->
     P st  ->
     Q st'.

(** Since we'll be working a lot with Hoare triples, it's useful to
    have a compact notation:

       {{P}} c {{Q}}.
*)
(** (The traditional notation is [{P} c {Q}], but single braces
    are already used for other things in Coq.)  *)

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(** **** Exercise: 1 star, optional (triples)  *)
(** Paraphrase the following Hoare triples in English.

   1) {{True}} c {{X = 5}}

   2) {{X = m}} c {{X = m + 5)}}

   3) {{X <= Y}} c {{Y <= X}}

   4) {{True}} c {{False}}

   5) {{X = m}}
      c
      {{Y = real_fact m}}

   6) {{True}}
      c
      {{(Z * Z) <= m /\ ~ (((S Z) * (S Z)) <= m)}}
*)

(** [] *)

(** **** Exercise: 1 star, optional (valid_triples)  *)
(** Which of the following Hoare triples are _valid_ -- i.e., the
    claimed relation between [P], [c], and [Q] is true?

   1) {{True}} X ::= 5 {{X = 5}}

   2) {{X = 2}} X ::= X + 1 {{X = 3}}

   3) {{True}} X ::= 5; Y ::= 0 {{X = 5}}

   4) {{X = 2 /\ X = 3}} X ::= 5 {{X = 0}}

   5) {{True}} SKIP {{False}}

   6) {{False}} SKIP {{True}}

   7) {{True}} WHILE True DO SKIP END {{False}}

   8) {{X = 0}}
      WHILE X == 0 DO X ::= X + 1 END
      {{X = 1}}

   9) {{X = 1}}
      WHILE X <> 0 DO X ::= X + 1 END
      {{X = 100}}
*)
(** [] *)

(** (Note that we're using informal mathematical notations for
   expressions inside of commands, for readability, rather than their
   formal [aexp] and [bexp] encodings.  We'll continue doing so
   throughout the chapter.)

   To get us warmed up for what's coming, here are two simple
   facts about Hoare triples. *)

Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  apply H.  Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~(P st)) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  unfold not in H. apply H in HP.
  inversion HP.  Qed.

(* ################################################################# *)
(** * Proof Rules *)

(** The goal of Hoare logic is to provide a _compositional_
    method for proving the validity of specific Hoare triples.  That
    is, we want the structure of a program's correctness proof to
    mirror the structure of the program itself.  To this end, in the
    sections below, we'll introduce a rule for reasoning about each of
    the different syntactic forms of commands in Imp -- one for
    assignment, one for sequencing, one for conditionals, etc. -- plus
    a couple of "structural" rules for gluing things together.  We
    will then be able to prove programs correct using these proof
    rules, without ever unfolding the definition of [hoare_triple]. *)

(* ================================================================= *)
(** ** Assignment *)

(** The rule for assignment is the most fundamental of the Hoare logic
    proof rules.  Here's how it works.

    Consider this valid Hoare triple:

       {{ Y = 1 }}  X ::= Y  {{ X = 1 }}

    In English: if we start out in a state where the value of [Y]
    is [1] and we assign [Y] to [X], then we'll finish in a
    state where [X] is [1].  That is, the property of being equal
    to [1] gets transferred from [Y] to [X].

    Similarly, in

       {{ Y + Z = 1 }}  X ::= Y + Z  {{ X = 1 }}

    the same property (being equal to one) gets transferred to
    [X] from the expression [Y + Z] on the right-hand side of
    the assignment.

    More generally, if [a] is _any_ arithmetic expression, then

       {{ a = 1 }}  X ::= a {{ X = 1 }}

    is a valid Hoare triple.

    This can be made even more general. To conclude that an
    arbitrary property [Q] holds after [X ::= a], we need to assume
    that [Q] holds before [X ::= a], but _with all occurrences of_ [X]
    replaced by [a] in [Q]. This leads to the Hoare rule for
    assignment

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

    where "[Q [X |-> a]]" is pronounced "[Q] where [a] is substituted
    for [X]".

    For example, these are valid applications of the assignment
    rule:

      {{ (X <= 5) [X |-> X + 1]
         i.e., X + 1 <= 5 }}
      X ::= X + 1
      {{ X <= 5 }}

      {{ (X = 3) [X |-> 3]
         i.e., 3 = 3}}
      X ::= 3
      {{ X = 3 }}

      {{ (0 <= X /\ X <= 5) [X |-> 3]
         i.e., (0 <= 3 /\ 3 <= 5)}}
      X ::= 3
      {{ 0 <= X /\ X <= 5 }}
*)

(** To formalize the rule, we must first formalize the idea of
    "substituting an expression for an Imp variable in an assertion."
    That is, given a proposition [P], a variable [X], and an
    arithmetic expression [a], we want to derive another proposition
    [P'] that is just the same as [P] except that, wherever [P]
    mentions [X], [P'] should instead mention [a].

    Since [P] is an arbitrary Coq proposition, we can't directly
    "edit" its text.  Instead, we can achieve the effect we want by
    evaluating [P] in an updated state: *)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

(** That is, [P [X |-> a]] is an assertion -- let's call it [P'] --
    that is just like [P] except that, wherever [P] looks up the
    variable [X] in the current state, [P'] instead uses the value
    of the expression [a].

    To see how this works, let's calculate what happens with a couple
    of examples.  First, suppose [P'] is [(X <= 5) [X |-> 3]] -- that
    is, more formally, [P'] is the Coq expression

    fun st =>
      (fun st' => st' X <= 5)
      (t_update st X (aeval st (ANum 3))),

    which simplifies to

    fun st =>
      (fun st' => st' X <= 5)
      (t_update st X 3)

    and further simplifies to

    fun st =>
      ((t_update st X 3) X) <= 5)

    and by further simplification to

    fun st =>
      (3 <= 5).

    That is, [P'] is the assertion that [3] is less than or equal to
    [5] (as expected).

    For a more interesting example, suppose [P'] is [(X <= 5) [X |->
    X+1]].  Formally, [P'] is the Coq expression

    fun st =>
      (fun st' => st' X <= 5)
      (t_update st X (aeval st (APlus (AId X) (ANum 1)))),

    which simplifies to

    fun st =>
      (((t_update st X (aeval st (APlus (AId X) (ANum 1))))) X) <= 5

    and further simplifies to

    fun st =>
      (aeval st (APlus (AId X) (ANum 1))) <= 5.

    That is, [P'] is the assertion that [X+1] is at most [5].
*)

(** Now we can give the precise proof rule for assignment:

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

(** We can prove formally that this rule is indeed valid. *)

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(** Here's a first formal proof using this rule. *)

Example assn_sub_example :
  {{(fun st => st X = 3) [X |-> ANum 3]}}
  (X ::= (ANum 3))
  {{fun st => st X = 3}}.
Proof.
  apply hoare_asgn.  Qed.

(** **** Exercise: 2 stars (hoare_asgn_examples)  *)
(** Translate these informal Hoare triples...

    1) {{ (X <= 5) [X |-> X + 1] }}
       X ::= X + 1
       {{ X <= 5 }}

    2) {{ (0 <= X /\ X <= 5) [X |-> 3] }}
       X ::= 3
       {{ 0 <= X /\ X <= 5 }}

   ...into formal statements (use the names [assn_sub_ex1]
   and [assn_sub_ex2]) and use [hoare_asgn] to prove them. *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 2 stars (hoare_asgn_wrong)  *)
(** The assignment rule looks backward to almost everyone the first
    time they see it.  If it still seems puzzling, it may help
    to think a little about alternative "forward" rules.  Here is a
    seemingly natural one:

      ------------------------------ (hoare_asgn_wrong)
      {{ True }} X ::= a {{ X = a }}

    Give a counterexample showing that this rule is incorrect and
    argue informally that it is really a counterexample.  (Hint:
    The rule universally quantifies over the arithmetic expression
    [a], and your counterexample needs to exhibit an [a] for which
    the rule doesn't work.) *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars, advanced (hoare_asgn_fwd)  *)
(** However, by using an auxiliary variable [m] to remember the
    original value of [X] we can define a Hoare rule for assignment
    that does, intuitively, "work forwards" rather than backwards.

       ------------------------------------------ (hoare_asgn_fwd)
       {{fun st => P st /\ st X = m}}
         X ::= a
       {{fun st => P st' /\ st X = aeval st' a }}
       (where st' = t_update st X m)

    Note that we use the original value of [X] to reconstruct the
    state [st'] before the assignment took place. Prove that this rule
    is correct (the first hypothesis is the functional extensionality
    axiom, which you will need at some point). Also note that this
    rule is more complicated than [hoare_asgn].
*)

Theorem hoare_asgn_fwd :
  (forall {X Y: Type} {f g : X -> Y},
     (forall (x: X), f x = g x) ->  f = g) ->
  forall m a P,
  {{fun st => P st /\ st X = m}}
    X ::= a
  {{fun st => P (t_update st X m)
            /\ st X = aeval (t_update st X m) a }}.
Proof.
  intros functional_extensionality m a P.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, advanced (hoare_asgn_fwd_exists)  *)
(** Another way to define a forward rule for assignment is to
    existentially quantify over the previous value of the assigned
    variable.

      ------------------------------------ (hoare_asgn_fwd_exists)
      {{fun st => P st}}
        X ::= a
      {{fun st => exists m, P (t_update st X m) /\
                     st X = aeval (t_update st X m) a }}
*)

Theorem hoare_asgn_fwd_exists :
  (forall {X Y: Type} {f g : X -> Y},
     (forall (x: X), f x = g x) ->  f = g) ->
  forall a P,
  {{fun st => P st}}
    X ::= a
  {{fun st => exists m, P (t_update st X m) /\
                st X = aeval (t_update st X m) a }}.
Proof.
  intros functional_extensionality a P.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Consequence *)

(** Sometimes the preconditions and postconditions we get from the
    Hoare rules won't quite be the ones we want in the particular
    situation at hand -- they may be logically equivalent but have a
    different syntactic form that fails to unify with the goal we are
    trying to prove, or they actually may be logically weaker (for
    preconditions) or stronger (for postconditions) than what we need.
    For instance, while

      {{(X = 3) [X |-> 3]}} X ::= 3 {{X = 3}},

    follows directly from the assignment rule,

      {{True}} X ::= 3 {{X = 3}}

    does not.  This triple is valid, but it is not an instance of
    [hoare_asgn] because [True] and [(X = 3) [X |-> 3]] are not
    syntactically equal assertions.  However, they are logically
    equivalent, so if one triple is valid, then the other must
    certainly be as well.  We can capture this observation with the
    following rule:

                {{P'}} c {{Q}}
                  P <<->> P'
         -----------------------------   (hoare_consequence_pre_equiv)
                {{P}} c {{Q}}

    Taking this line of thought a bit further, we can see that
    strengthening the precondition or weakening the postcondition of a
    valid triple always produces another valid triple. This
    observation is captured by two _Rules of Consequence_.

                {{P'}} c {{Q}}
                   P ->> P'
         -----------------------------   (hoare_consequence_pre)
                {{P}} c {{Q}}

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

(** Here are the formal versions: *)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

(** For example, we can use the first consequence rule like this:

                {{ True }} ->>
                {{ 1 = 1 }}
    X ::= 1
                {{ X = 1 }}

    Or, formally... *)

Example hoare_asgn_example1 :
  {{fun st => True}} (X ::= (ANum 1)) {{fun st => st X = 1}}.
Proof.
  apply hoare_consequence_pre
    with (P' := (fun st => st X = 1) [X |-> ANum 1]).
  apply hoare_asgn.
  intros st H. unfold assn_sub, t_update. simpl. reflexivity.
Qed.

(** Finally, for convenience in some proofs, we can state a combined
    rule of consequence that allows us to vary both the precondition
    and the postcondition at the same time.

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

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* ================================================================= *)
(** ** Digression: The [eapply] Tactic *)

(** This is a good moment to introduce another convenient feature of
    Coq.  We had to write "[with (P' := ...)]" explicitly in the proof
    of [hoare_asgn_example1] and [hoare_consequence] above, to make
    sure that all of the metavariables in the premises to the
    [hoare_consequence_pre] rule would be set to specific
    values.  (Since [P'] doesn't appear in the conclusion of
    [hoare_consequence_pre], the process of unifying the conclusion
    with the current goal doesn't constrain [P'] to a specific
    assertion.)

    This is annoying, both because the assertion is a bit long and
    also because, in [hoare_asgn_example1], the very next thing we are
    going to do -- applying the [hoare_asgn] rule -- will tell us
    exactly what it should be!  We can use [eapply] instead of [apply]
    to tell Coq, essentially, "Be patient: The missing part is going
    to be filled in later in the proof." *)

Example hoare_asgn_example1' :
  {{fun st => True}}
  (X ::= (ANum 1))
  {{fun st => st X = 1}}.
Proof.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  intros st H.  reflexivity.  Qed.

(** In general, [eapply H] tactic works just like [apply H] except
    that, instead of failing if unifying the goal with the conclusion
    of [H] does not determine how to instantiate all of the variables
    appearing in the premises of [H], [eapply H] will replace these
    variables with _existential variables_ (written [?nnn]), which
    function as placeholders for expressions that will be
    determined (by further unification) later in the proof. *)

(** In order for [Qed] to succeed, all existential variables need to
    be determined by the end of the proof. Otherwise Coq
    will (rightly) refuse to accept the proof. Remember that the Coq
    tactics build proof objects, and proof objects containing
    existential variables are not complete. *)

Lemma silly1 : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (forall x y : nat, P x y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. apply HP.

(** Coq gives a warning after [apply HP].  (The warnings look
    different between Coq 8.4 and Coq 8.5.  In 8.4, the warning says
    "No more subgoals but non-instantiated existential variables."  In
    8.5, it says "All the remaining goals are on the shelf," meaning
    that we've finished all our top-level proof obligations but along
    the way we've put some aside to be done later, and we have not
    finished those.)  Trying to close the proof with [Qed] gives an
    error. *)

Abort.

(** An additional constraint is that existential variables cannot be
    instantiated with terms containing ordinary variables that did not
    exist at the time the existential variable was created.  (The
    reason for this technical restriction is that allowing such
    instantiation would lead to inconsistency of Coq's logic.) *)

Lemma silly2 :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. destruct HP as [y HP'].

(** Doing [apply HP'] above fails with the following error:

     Error: Impossible to unify "?175" with "y".

    In this case there is an easy fix: doing [destruct HP] _before_
    doing [eapply HQ]. *)

Abort.

Lemma silly2_fixed :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP'].
  eapply HQ. apply HP'.
Qed.

(** The [apply HP'] in the last step unifies the existential variable
    in the goal with the variable [y].

    Note that the [assumption] tactic doesn't work in this case, since
    it cannot handle existential variables.  However, Coq also
    provides an [eassumption] tactic that solves the goal if one of
    the premises matches the goal up to instantiations of existential
    variables. We can use it instead of [apply HP'] if we like. *)

Lemma silly2_eassumption : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP']. eapply HQ. eassumption.
Qed.

(** **** Exercise: 2 stars (hoare_asgn_examples_2)  *)
(** Translate these informal Hoare triples...

       {{ X + 1 <= 5 }}  X ::= X + 1  {{ X <= 5 }}
       {{ 0 <= 3 /\ 3 <= 5 }}  X ::= 3  {{ 0 <= X /\ X <= 5 }}

   ...into formal statements (name them [assn_sub_ex1'] and
   [assn_sub_ex2']) and use [hoare_asgn] and [hoare_consequence_pre]
   to prove them. *)

(* FILL IN HERE *)
(** [] *)

(* ================================================================= *)
(** ** Skip *)

(** Since [SKIP] doesn't change the state, it preserves any
    property [P]:

      --------------------  (hoare_skip)
      {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* ================================================================= *)
(** ** Sequencing *)

(** More interestingly, if the command [c1] takes any state where
    [P] holds to a state where [Q] holds, and if [c2] takes any
    state where [Q] holds to one where [R] holds, then doing [c1]
    followed by [c2] will take any state where [P] holds to one
    where [R] holds:

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

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(** Note that, in the formal rule [hoare_seq], the premises are
    given in backwards order ([c2] before [c1]).  This matches the
    natural flow of information in many of the situations where we'll
    use the rule, since the natural way to construct a Hoare-logic
    proof is to begin at the end of the program (with the final
    postcondition) and push postconditions backwards through commands
    until we reach the beginning. *)

(** Informally, a nice way of displaying a proof using the sequencing
    rule is as a "decorated program" where the intermediate assertion
    [Q] is written between [c1] and [c2]:

      {{ a = n }}
    X ::= a;;
      {{ X = n }}    <---- decoration for Q
    SKIP
      {{ X = n }}
*)

(** Here's an example of a program involving both assignment and
    sequencing. *)

Example hoare_asgn_example3 : forall a n,
  {{fun st => aeval st a = n}}
  (X ::= a;; SKIP)
  {{fun st => st X = n}}.
Proof.
  intros a n. eapply hoare_seq.
  - (* right part of seq *)
    apply hoare_skip.
  - (* left part of seq *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    intros st H. subst. reflexivity.
Qed.

(** We typically use [hoare_seq] in conjunction with
    [hoare_consequence_pre] and the [eapply] tactic, as in this
    example. *)

(** **** Exercise: 2 stars (hoare_asgn_example4)  *)
(** Translate this "decorated program" into a formal proof:

                   {{ True }} ->>
                   {{ 1 = 1 }}
    X ::= 1;;
                   {{ X = 1 }} ->>
                   {{ X = 1 /\ 2 = 2 }}
    Y ::= 2
                   {{ X = 1 /\ Y = 2 }}
*)

Example hoare_asgn_example4 :
  {{fun st => True}} (X ::= (ANum 1);; Y ::= (ANum 2))
  {{fun st => st X = 1 /\ st Y = 2}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (swap_exercise)  *)
(** Write an Imp program [c] that swaps the values of [X] and [Y] and
    show that it satisfies the following specification:

      {{X <= Y}} c {{Y <= X}}
*)

Definition swap_program : com
  (* REPLACE THIS LINE WITH   := _your_definition_ . *) . Admitted.

Theorem swap_exercise :
  {{fun st => st X <= st Y}}
  swap_program
  {{fun st => st Y <= st X}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (hoarestate1)  *)
(** Explain why the following proposition can't be proven:

      forall (a : aexp) (n : nat),
         {{fun st => aeval st a = n}}
         (X ::= (ANum 3);; Y ::= a)
         {{fun st => st Y = n}}.
*)

(* FILL IN HERE *)
(** [] *)

(* ================================================================= *)
(** ** Conditionals *)

(** What sort of rule do we want for reasoning about conditional
    commands?

    Certainly, if the same assertion [Q] holds after executing
    either of the branches, then it holds after the whole conditional.
    So we might be tempted to write:

              {{P}} c1 {{Q}}
              {{P}} c2 {{Q}}
      --------------------------------
      {{P}} IFB b THEN c1 ELSE c2 {{Q}}

   However, this is rather weak. For example, using this rule,
   we cannot show

     {{ True }}
     IFB X == 0
     THEN Y ::= 2
     ELSE Y ::= X + 1
     FI
     {{ X <= Y }}

   since the rule tells us nothing about the state in which the
   assignments take place in the "then" and "else" branches. *)

(** Fortunately, we can say something more precise.  In the
    "then" branch, we know that the boolean expression [b] evaluates to
    [true], and in the "else" branch, we know it evaluates to [false].
    Making this information available in the premises of the rule gives
    us more information to work with when reasoning about the behavior
    of [c1] and [c2] (i.e., the reasons why they establish the
    postcondition [Q]). *)
(**

              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

(** To interpret this rule formally, we need to do a little work.
    Strictly speaking, the assertion we've written, [P /\ b], is the
    conjunction of an assertion and a boolean expression -- i.e., it
    doesn't typecheck.  To fix this, we need a way of formally
    "lifting" any bexp [b] to an assertion.  We'll write [bassn b] for
    the assertion "the boolean expression [b] evaluates to [true] (in
    the given state)." *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

(** A couple of useful facts about [bassn]: *)

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(** Now we can formalize the Hoare proof rule for conditionals
    and prove it correct. *)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  - (* b is true *)
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  - (* b is false *)
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* ----------------------------------------------------------------- *)
(** *** Example *)

(** Here is a formal proof that the program we used to motivate the
    rule satisfies the specification we gave. *)

Example if_example :
    {{fun st => True}}
  IFB (BEq (AId X) (ANum 0))
    THEN (Y ::= (ANum 2))
    ELSE (Y ::= APlus (AId X) (ANum 1))
  FI
    {{fun st => st X <= st Y}}.
Proof.
  (* WORKED IN CLASS *)
  apply hoare_if.
  - (* Then *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold bassn, assn_sub, t_update, assert_implies.
    simpl. intros st [_ H].
    apply beq_nat_true in H.
    rewrite H. omega.
  - (* Else *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold assn_sub, t_update, assert_implies.
    simpl; intros st _. omega.
Qed.

(** **** Exercise: 2 stars (if_minus_plus)  *)
(** Prove the following hoare triple using [hoare_if]: *)

Theorem if_minus_plus :
  {{fun st => True}}
  IFB (BLe (AId X) (AId Y))
    THEN (Z ::= AMinus (AId Y) (AId X))
    ELSE (Y ::= APlus (AId X) (AId Z))
  FI
  {{fun st => st Y = st X + st Z}}.
Proof.
  (* FILL IN HERE *) Admitted.

(* ----------------------------------------------------------------- *)
(** *** Exercise: One-sided conditionals *)

(** **** Exercise: 4 stars (if1_hoare)  *)

(** In this exercise we consider extending Imp with "one-sided
    conditionals" of the form [IF1 b THEN c FI]. Here [b] is a
    boolean expression, and [c] is a command. If [b] evaluates to
    [true], then command [c] is evaluated. If [b] evaluates to
    [false], then [IF1 b THEN c FI] does nothing.

    We recommend that you do this exercise before the ones that
    follow, as it should help solidify your understanding of the
    material. *)

(** The first step is to extend the syntax of commands and introduce
    the usual notations.  (We've done this for you.  We use a separate
    module to prevent polluting the global name space.) *)

Module If1.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CIf1 : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAss X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'IF1' b 'THEN' c 'FI'" :=
  (CIf1 b c) (at level 80, right associativity).

(** Next we need to extend the evaluation relation to accommodate
    [IF1] branches.  This is for you to do... What rule(s) need to be
    added to [ceval] to evaluate one-sided conditionals? *)

Reserved Notation "c1 '/' st '\\' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st : state, SKIP / st \\ st
  | E_Ass : forall (st : state) (a1 : aexp) (n : nat) (X : id),
            aeval st a1 = n -> (X ::= a1) / st \\ t_update st X n
  | E_Seq : forall (c1 c2 : com) (st st' st'' : state),
            c1 / st \\ st' -> c2 / st' \\ st'' -> (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
               beval st b1 = true ->
               c1 / st \\ st' -> (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
                beval st b1 = false ->
                c2 / st \\ st' -> (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall (b1 : bexp) (st : state) (c1 : com),
                 beval st b1 = false -> (WHILE b1 DO c1 END) / st \\ st
  | E_WhileLoop : forall (st st' st'' : state) (b1 : bexp) (c1 : com),
                  beval st b1 = true ->
                  c1 / st \\ st' ->
                  (WHILE b1 DO c1 END) / st' \\ st'' ->
                  (WHILE b1 DO c1 END) / st \\ st''
(* FILL IN HERE *)

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

(** Now we repeat (verbatim) the definition and notation of Hoare triples. *)

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st \\ st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

(** Finally, we (i.e., you) need to state and prove a theorem,
    [hoare_if1], that expresses an appropriate Hoare logic proof rule
    for one-sided conditionals. Try to come up with a rule that is
    both sound and as precise as possible. *)

(* FILL IN HERE *)

(** For full credit, prove formally [hoare_if1_good] that your rule is
    precise enough to show the following valid Hoare triple:

  {{ X + Y = Z }}
  IF1 Y <> 0 THEN
    X ::= X + Y
  FI
  {{ X = Z }}
*)

(** Hint: Your proof of this triple may need to use the other proof
    rules also. Because we're working in a separate module, you'll
    need to copy here the rules you find necessary. *)

Lemma hoare_if1_good :
  {{ fun st => st X + st Y = st Z }}
  IF1 BNot (BEq (AId Y) (ANum 0)) THEN
    X ::= APlus (AId X) (AId Y)
  FI
  {{ fun st => st X = st Z }}.
Proof. (* FILL IN HERE *) Admitted.

End If1.
(** [] *)

(* ================================================================= *)
(** ** Loops *)

(** Finally, we need a rule for reasoning about while loops. *)

(** Suppose we have a loop

      WHILE b DO c END

    and we want to find a pre-condition [P] and a post-condition
    [Q] such that

      {{P}} WHILE b DO c END {{Q}}

    is a valid triple. *)

(** First of all, let's think about the case where [b] is false at the
    beginning -- i.e., let's assume that the loop body never executes
    at all.  In this case, the loop behaves like [SKIP], so we might
    be tempted to write: *)

(**

      {{P}} WHILE b DO c END {{P}}.
*)

(** But, as we remarked above for the conditional, we know a
    little more at the end -- not just [P], but also the fact
    that [b] is false in the current state.  So we can enrich the
    postcondition a little: *)
(**

      {{P}} WHILE b DO c END {{P /\ ~b}}
*)

(** What about the case where the loop body _does_ get executed?
    In order to ensure that [P] holds when the loop finally
    exits, we certainly need to make sure that the command [c]
    guarantees that [P] holds whenever [c] is finished.
    Moreover, since [P] holds at the beginning of the first
    execution of [c], and since each execution of [c]
    re-establishes [P] when it finishes, we can always assume
    that [P] holds at the beginning of [c].  This leads us to the
    following rule: *)
(**

                   {{P}} c {{P}}
        -----------------------------------
        {{P}} WHILE b DO c END {{P /\ ~b}}
*)
(** This is almost the rule we want, but again it can be improved a
    little: at the beginning of the loop body, we know not only that
    [P] holds, but also that the guard [b] is true in the current
    state.  This gives us a little more information to use in
    reasoning about [c] (showing that it establishes the invariant by
    the time it finishes).  This gives us the final version of the
    rule:
*)
(**

               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}

    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  - (* E_WhileEnd *)
    split. assumption. apply bexp_eval_false. assumption.
  - (* E_WhileLoop *)
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

(** One subtlety in the terminology is that calling some assertion [P]
    a "loop invariant" doesn't just mean that it is preserved by the
    body of the loop in question (i.e., [{{P}} c {{P}}], where [c] is
    the loop body), but rather that [P] _together with the fact that
    the loop's guard is true_ is a sufficient precondition for [c] to
    ensure [P] as a postcondition.

    This is a slightly (but significantly) weaker requirement.  For
    example, if [P] is the assertion [X = 0], then [P] _is_ an
    invariant of the loop

    WHILE X = 2 DO X := 1 END

    although it is clearly _not_ preserved by the body of the
    loop. *)

Example while_example :
    {{fun st => st X <= 3}}
  WHILE (BLe (AId X) (ANum 2))
  DO X ::= APlus (AId X) (ANum 1) END
    {{fun st => st X = 3}}.
Proof.
  eapply hoare_consequence_post.
  apply hoare_while.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  unfold bassn, assn_sub, assert_implies, t_update. simpl.
    intros st [H1 H2]. apply leb_complete in H2. omega.
  unfold bassn, assert_implies. intros st [Hle Hb].
    simpl in Hb. destruct (leb (st X) 2) eqn : Heqle.
    exfalso. apply Hb; reflexivity.
    apply leb_iff_conv in Heqle. omega.
Qed.

(** We can use the while rule to prove the following Hoare triple,
    which may seem surprising at first... *)

Theorem always_loop_hoare : forall P Q,
  {{P}} WHILE BTrue DO SKIP END {{Q}}.
Proof.
  (* WORKED IN CLASS *)
  intros P Q.
  apply hoare_consequence_pre with (P' := fun st : state => True).
  eapply hoare_consequence_post.
  apply hoare_while.
  - (* Loop body preserves invariant *)
    apply hoare_post_true. intros st. apply I.
  - (* Loop invariant and negated guard imply postcondition *)
    simpl. intros st [Hinv Hguard].
    exfalso. apply Hguard. reflexivity.
  - (* Precondition implies invariant *)
    intros st H. constructor.  Qed.

(** Of course, this result is not surprising if we remember that
    the definition of [hoare_triple] asserts that the postcondition
    must hold _only_ when the command terminates.  If the command
    doesn't terminate, we can prove anything we like about the
    post-condition. *)

(** Hoare rules that only talk about terminating commands are
    often said to describe a logic of "partial" correctness.  It is
    also possible to give Hoare rules for "total" correctness, which
    build in the fact that the commands terminate. However, in this
    course we will only talk about partial correctness. *)

(* ----------------------------------------------------------------- *)
(** *** Exercise: [REPEAT] *)

(** **** Exercise: 4 stars, advanced (hoare_repeat)  *)
(** In this exercise, we'll add a new command to our language of
    commands: [REPEAT] c [UNTIL] a [END]. You will write the
    evaluation rule for [repeat] and add a new Hoare rule to
    the language for programs involving it. *)

Module RepeatExercise.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

(** [REPEAT] behaves like [WHILE], except that the loop guard is
    checked _after_ each execution of the body, with the loop
    repeating as long as the guard stays _false_.  Because of this,
    the body will always execute at least once. *)

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

(** Add new rules for [REPEAT] to [ceval] below.  You can use the rules
    for [WHILE] as a guide, but remember that the body of a [REPEAT]
    should always execute at least once, and that the loop ends when
    the guard becomes true.  Then update the [ceval_cases] tactic to
    handle these added cases.  *)

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ;; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileEnd : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileLoop : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
(* FILL IN HERE *)
.

(** A couple of definitions from above, copied here so they use the
    new [ceval]. *)

Notation "c1 '/' st '\\' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion)
                        : Prop :=
  forall st st', (c / st \\ st') -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level).

(** To make sure you've got the evaluation rules for [REPEAT] right,
    prove that [ex1_repeat evaluates correctly. *)

Definition ex1_repeat :=
  REPEAT
    X ::= ANum 1;;
    Y ::= APlus (AId Y) (ANum 1)
  UNTIL (BEq (AId X) (ANum 1)) END.

Theorem ex1_repeat_works :
  ex1_repeat / empty_state \\
               t_update (t_update empty_state X 1) Y 1.
Proof.
  (* FILL IN HERE *) Admitted.

(** Now state and prove a theorem, [hoare_repeat], that expresses an
    appropriate proof rule for [repeat] commands.  Use [hoare_while]
    as a model, and try to make your rule as precise as possible. *)

(* FILL IN HERE *)

(** For full credit, make sure (informally) that your rule can be used
    to prove the following valid Hoare triple:

  {{ X > 0 }}
  REPEAT
    Y ::= X;;
    X ::= X - 1
  UNTIL X = 0 END
  {{ X = 0 /\ Y > 0 }}
*)

End RepeatExercise.
(** [] *)

(* ################################################################# *)
(** * Summary *)

(** So far, we've introduced Hoare Logic as a tool for reasoning about
    Imp programs.  In the reminder of this chapter we'll explore a
    systematic way to use Hoare Logic to prove properties about
    programs. The rules of Hoare Logic are:

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

             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}

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

              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{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}}

    In the next chapter, we'll see how these rules are used to prove
    that programs satisfy specifications of their behavior. *)

(* ################################################################# *)
(** * Additional Exercises *)

(** **** Exercise: 3 stars (himp_hoare)  *)
(** In this exercise, we will derive proof rules for the [HAVOC]
    command, which we studied in the last chapter.

    First, we enclose this work in a separate module, and recall the
    syntax and big-step semantics of Himp commands. *)

Module Himp.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CHavoc : id -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'HAVOC' X" := (CHavoc X) (at level 60).

Reserved Notation "c1 '/' st '\\' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st : state, SKIP / st \\ st
  | E_Ass : forall (st : state) (a1 : aexp) (n : nat) (X : id),
            aeval st a1 = n -> (X ::= a1) / st \\ t_update st X n
  | E_Seq : forall (c1 c2 : com) (st st' st'' : state),
            c1 / st \\ st' -> c2 / st' \\ st'' -> (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
               beval st b1 = true ->
               c1 / st \\ st' -> (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
                beval st b1 = false ->
                c2 / st \\ st' -> (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall (b1 : bexp) (st : state) (c1 : com),
                 beval st b1 = false -> (WHILE b1 DO c1 END) / st \\ st
  | E_WhileLoop : forall (st st' st'' : state) (b1 : bexp) (c1 : com),
                  beval st b1 = true ->
                  c1 / st \\ st' ->
                  (WHILE b1 DO c1 END) / st' \\ st'' ->
                  (WHILE b1 DO c1 END) / st \\ st''
  | E_Havoc : forall (st : state) (X : id) (n : nat),
              (HAVOC X) / st \\ t_update st X n

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

(** The definition of Hoare triples is exactly as before. Unlike our
    notion of program equivalence, which had subtle consequences with
    occassionally nonterminating commands (exercise [havoc_diverge]),
    this definition is still fully satisfactory. Convince yourself of
    this before proceeding. *)

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st', c / st \\ st' -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

(** Complete the Hoare rule for [HAVOC] commands below by defining
    [havoc_pre] and prove that the resulting rule is correct. *)

Definition havoc_pre (X : id) (Q : Assertion) : Assertion
  (* REPLACE THIS LINE WITH   := _your_definition_ . *) . Admitted.

Theorem hoare_havoc : forall (Q : Assertion) (X : id),
  {{ havoc_pre X Q }} HAVOC X {{ Q }}.
Proof.
  (* FILL IN HERE *) Admitted.

End Himp.
(** [] *)

(** $Date: 2016-07-13 12:41:41 -0400 (Wed, 13 Jul 2016) $ *)


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* The syntax of computations.  *)

Set Implicit Arguments.

Require Export Bvector.
Require Export List.
Require Export fcf.Blist.
Require Export fcf.EqDec.
Require Import fcf.Fold.

Inductive Comp : Set -> Type :=
| Ret : forall (A : Set), eq_dec A -> A -> Comp A
| Bind : forall (A B : Set), Comp B -> (B -> Comp A) -> Comp A
| Rnd : forall n, Comp (Bvector n)
| Repeat : forall (A : Set), Comp A -> (A -> bool) -> Comp A.

(* syntactic equality for Comp *)
Inductive Comp_eq : forall (A : Set), Comp A -> Comp A -> Prop :=
  | Comp_eq_Ret : forall (A : Set)(pf1 pf2 : eq_dec A)(a : A),
    Comp_eq (Ret pf1 a) (Ret pf2 a)
  | Comp_eq_Bind : forall (A B : Set)(c1x c1y : Comp B)(c2x c2y : B -> Comp A),
    Comp_eq c1x c1y ->
    (forall b, (Comp_eq (c2x b) (c2y b))) ->
    Comp_eq (Bind c1x c2x) (Bind c1y c2y)
  | Comp_eq_Rnd : forall n,
    Comp_eq (Rnd n) (Rnd n)
  | Comp_eq_Repeat : forall (A : Set)(c1 c2 : Comp A)(P1 P2 : A -> bool),
    Comp_eq c1 c2 ->
    (forall a, P1 a = P2 a) ->
    Comp_eq (Repeat c1 P1) (Repeat c2 P2).

Hint Constructors Comp_eq : comp.

Theorem Comp_eq_refl : forall (A : Set)(c : Comp A),
  Comp_eq c c.

  induction c; intuition; eauto with comp.
Qed.

Lemma Bvector_exists : forall n,
  Bvector n.

  induction n; intuition.
  econstructor.
  econstructor.
  econstructor.
  eapply IHn.
Qed.

Lemma comp_base_exists : forall (A : Set),
  Comp A ->
  A.

  induction 1; intuition;
  eauto using Bvector_exists.
Qed.

Require Import fcf.EqDec.

Lemma comp_EqDec : forall (A : Set),
  Comp A ->
  EqDec A.

  induction 1; intuition.
  exists (fun a1 a2 => if e a1 a2 then true else false).
  intuition.
  destruct (e x y); simpl in *; trivial. discriminate.
  subst.
  destruct (e y y); trivial; congruence.

  eapply H.
  eapply comp_base_exists; eauto.
Qed.

Lemma comp_eq_dec : forall (A : Set),
  Comp A ->
  eq_dec A.

  induction 1; intuition.
  eapply H.
  eapply comp_base_exists; eauto.
  specialize (@Bvector_eq_dec n); intuition.
Qed.

Lemma bind_EqDec : forall (A B : Set),
  Comp B ->
  (B -> Comp A) ->
  EqDec A.

  intuition.
  eapply comp_EqDec.
  eapply X0.
  eapply comp_base_exists.
  eauto.

Qed.

Lemma bind_eq_dec : forall (A B : Set),
  Comp B ->
  (B -> Comp A) ->
  eq_dec A.

  intuition.
  eapply comp_eq_dec.
  eapply X0.
  eapply comp_base_exists.
  eauto.

Qed.

(*
Instance comp_eq_dec : forall (A : Set),
  Comp A ->
  EqDec A.

eapply comp_base_EqDec.
Qed.

Instance bind_EqDec : forall (B A : Set),
  Comp B ->
  (B -> Comp A) ->
  EqDec A.

intuition.
eapply comp_EqDec.
eapply X0.
eapply comp_base_exists.
eauto.
Qed.

*)

Fixpoint getSupport(A : Set)(c : Comp A) : list A :=
  match c with
    | Ret _ a => a :: nil
    | Bind c1 c2 => getUnique (flatten (map (fun b => (getSupport (c2 b))) (getSupport c1))) (bind_eq_dec c1 c2)
    | Rnd n => getAllBvectors n
    | Repeat c1 P => (filter P (getSupport c1))
  end.

(* Only well-formed computations are guaranteed to terminate. *)
Inductive well_formed_comp : forall (A : Set), Comp A -> Prop :=
  | well_formed_Ret :
    forall (A : Set)(pf : eq_dec A)(a : A),
      well_formed_comp (Ret pf a)
  | well_formed_Bind :
    forall (A B : Set)(c1 : Comp B)(c2 : B -> Comp A),
      well_formed_comp c1 ->
      (forall b, In b (getSupport c1) -> well_formed_comp (c2 b)) ->
      well_formed_comp (Bind c1 c2)
   | well_formed_Rnd : forall n,
     well_formed_comp (Rnd n)
   | well_formed_Repeat :
     forall (A : Set)(eqd : eq_dec A)(c : Comp A) P b,
      well_formed_comp c ->
      In b (filter P (getSupport c)) ->
      well_formed_comp (Repeat c P).

Delimit Scope comp_scope with comp.

Theorem lt_eq_false :
  forall n,
    n < n -> False.

  destruct n; intuition.

Qed.

Lemma length_nz_exists : forall (A : Type)(ls : list A),
                           length ls > 0 ->
                           exists a, In a ls.

  destruct ls; intuition; simpl in *.
  exfalso.
  eapply lt_eq_false; eauto.

  econstructor; eauto.
Qed.

Theorem getSupport_length_nz : forall (A : Set)(c : Comp A),
  well_formed_comp c ->
  length (getSupport c) > 0.

  induction 1; intuition; simpl in *.

  apply length_getUnique_nz.
  apply length_nz_exists in IHwell_formed_comp.
  destruct IHwell_formed_comp.

  eapply length_flatten_nz.
  eapply in_map_iff.
  econstructor; intuition; eauto.
  eapply H1.
  trivial.

  apply getAllBvectors_length_nz.

  destruct (filter P (getSupport c)); simpl in *; intuition.
Qed.

Lemma filter_NoDup : forall (A : Set)(ls : list A)(P : A -> bool),
  NoDup ls ->
  NoDup (filter P ls).

  induction ls; intuition; simpl in *.
  inversion H; clear H; subst.
  case_eq (P a); intuition.
  econstructor; intuition.
  eapply H2.
  eapply filter_In; eauto.

Qed.

Lemma getSupport_NoDup : forall (A : Set)(c : Comp A),
  NoDup (getSupport c).

  induction c; intuition; simpl in *.

  econstructor.
  apply in_nil.
  econstructor.

  eapply getUnique_NoDup.

  eapply getAllBvectors_NoDup.

  eapply filter_NoDup.
  trivial.

Qed.

Lemma getSupport_Bind_In : forall (A B : Set) (c : Comp B)(f : B -> Comp A) a,
  In a (getSupport (Bind c f)) ->
  exists b,
    In b (getSupport c) /\
    In a (getSupport (f b)).

  intuition.
  simpl in *.
  apply in_getUnique_if in H.
  eapply in_flatten in H.
  destruct H.
  intuition.
  apply in_map_iff in H0.
  destruct H0.
  intuition.
  subst.
  econstructor.
  intuition;
    eauto.

Qed.

Ltac pairInv :=
  match goal with
    | [H : (_, _) = (_, _) |-_ ] => inversion H; clear H; subst
  end.

Ltac destruct_exists :=
  match goal with
    | [H : exists x, _ |- _ ] =>
      destruct H
  end.

Theorem getSupport_In_Ret :
  forall (A : Set)(eqd : eq_dec A) x a,
    In x (getSupport (Ret eqd a)) ->
    x = a.

  intuition.

  simpl in *.
  intuition.

Qed.

Theorem getSupport_In_Seq :
  forall (A B : Set)(c : Comp A)(f : A -> Comp B) b a,
    In a (getSupport c) ->
    In b (getSupport (f a)) ->
    In b (getSupport (Bind c f)).

  intuition.
  simpl.
  eapply in_getUnique.
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eauto.
  eauto.
  trivial.
Qed.

Local Open Scope comp_scope.

Definition maybeBind(A B : Type)(opt_a : option A)(f : A -> B) : option B :=
  match opt_a with
    | None => None
    | Some a => Some (f a)
  end.

Inductive OracleComp : Set -> Set -> Set -> Type :=
| OC_Query : forall (A B : Set), A -> OracleComp A B B
| OC_Run : forall (A B C A' B' S : Set),
  EqDec S ->
  EqDec B ->
  EqDec A ->
  OracleComp A B C ->
  (S -> A -> OracleComp A' B' (B * S)) ->
  S ->
  OracleComp A' B' (C * S)
| OC_Ret : forall A B C, Comp C -> OracleComp A B C
| OC_Bind : forall A B C C', OracleComp A B C -> (C -> OracleComp A B C') -> OracleComp A B C'.

Theorem oc_base_exists : forall (A B C : Set), OracleComp A B C -> (A -> B) -> C.

  induction 1; intuition; simpl in *.
  eapply comp_base_exists; intuition.

Qed.

Theorem oc_EqDec : forall (A B C: Set),  OracleComp A B C -> (A -> B) -> (A -> EqDec B) -> EqDec C.

  induction 1; intuition.
  eapply pair_EqDec; intuition.
  eapply IHX; intuition.
  apply oc_base_exists in X1;
  intuition.
  eapply comp_EqDec; intuition.

  eapply H.
  eapply oc_base_exists;
  eauto.
  intuition.
  intuition.

Qed.

Lemma well_formed_val_exists :
  forall (A : Set)(c : Comp A),
    well_formed_comp c ->
    exists x, In x (getSupport c).

  induction 1; intuition; simpl in *.

  econstructor; intuition.

  destruct IHwell_formed_comp.
  edestruct H1; eauto.
  econstructor.
  eapply in_getUnique.
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eauto.
  eauto.
  eauto.

  exists (oneVector n).
  eapply in_getAllBvectors.

  econstructor.
  eauto.
Qed.


Require Import Bintree.
Require Import Bool.
Require Import Env.
Require Import Free_algebra.
Require Import Form.

Unset Boxed Definitions.

Section with_env.

Variable Denv : domain_env.
Variable Sigma : Free_algebra.signature Denv.
Variable Pi : signature Denv.

Notation "[ T ; i ]" := (mkE Denv i T).

Fixpoint interp_vars (V:var_ctx) (F:Full V) (Inside:var_env Denv -> Prop)
{struct F} : Prop :=
match F with
  F_empty => Inside empty
| F_push dom V0 F0 =>
      interp_vars V0 F0
	(fun Venv => forall var: interp_domain Denv dom,
	            (Inside (Venv \ (mkE Denv dom var))))
end.

Fixpoint interp_hyps (hyps: hyp_ctx) (F:Full hyps) (Inside:var_env Denv -> Prop)
{struct F} :var_env Denv -> Prop :=
match F with
  F_empty => Inside
| F_push f hyps0 F0 =>
      interp_hyps hyps0 F0
	(fun Venv => interp_form Denv Sigma Pi Venv nil f -> Inside Venv)
end.

Fixpoint interp_var_list (Venv:var_env Denv) (V:list domain)
(Inside: var_env Denv -> Prop)  {struct V} : Prop :=
 match V with
 nil => Inside Venv
| dom::V0 =>
 forall var: interp_domain Denv dom,
 interp_var_list (Venv\mkE Denv dom var) V0 Inside
end.

Fixpoint interp_hyp_list (hyps: list form) (Head: var_env Denv -> Prop)
{struct hyps} : var_env Denv -> Prop :=
  match hyps with
  nil => Head
  | f::hyps0 =>
       fun Venv => interp_form Denv Sigma Pi Venv nil f -> interp_hyp_list hyps0 Head Venv
end.

Definition interp_seq (V:var_ctx) (FV:Full V) (hyps:hyp_ctx) (F:Full hyps)  (goal:form) : Prop :=
interp_vars V FV (interp_hyps hyps F
(fun Venv => interp_form Denv Sigma Pi Venv nil goal)).

Definition interp (V:list domain) (hyps:list form) (goal:form) :Prop :=
interp_var_list empty V (interp_hyp_list hyps
	(fun Venv => interp_form Denv Sigma Pi Venv nil goal)).

Inductive WF_hyp_ctx (V:var_ctx) :
  forall hyps:hyp_ctx, Full hyps -> Prop :=
    WF_empty : WF_hyp_ctx V empty F_empty
  | WF_push_hyp : forall gamma f F, WF_form Denv Sigma Pi V nil f ->
    WF_hyp_ctx V gamma F ->
    WF_hyp_ctx V (gamma \ f) (F_push f gamma F).

Inductive WF_seq (V:var_ctx) (hyps:hyp_ctx) (F:Full hyps) (goal:form) :Prop :=
WF_turnstyle :
WF_hyp_ctx V hyps F -> WF_form Denv Sigma Pi V nil goal -> WF_seq V hyps F goal.

Fixpoint check_ctx (V:var_ctx) (hyps:hyp_ctx) (F:Full hyps) {struct F} : bool :=
  match F with
    F_empty => true
  | F_push f hyps0 F0 =>
         if check_form Denv Sigma Pi V nil f then
           check_ctx V hyps0 F0
       else false
end.

Definition check_seq (V:var_ctx) (hyps:hyp_ctx) (F:Full hyps) (goal:form) : bool :=
 if check_form Denv Sigma Pi V nil goal then check_ctx V hyps F else false.

Lemma WF_checked_ctx : forall V ctx F,
  check_ctx V ctx F = true -> WF_hyp_ctx V ctx F.
induction F.
constructor 1.
simpl.
caseq (check_form Denv Sigma Pi V nil a).
constructor 2.
apply WF_checked_form;assumption.
apply IHF;assumption.
congruence.
Qed.

Lemma WF_checked_seq : forall V ctx F goal,
check_seq V ctx F goal = true -> WF_seq V ctx F goal.
intros V ctx F goal;unfold check_seq.
caseq (check_form Denv Sigma Pi V nil goal).
split.
apply WF_checked_ctx;assumption.
apply WF_checked_form;assumption.
congruence.
Qed.

Lemma Weak_WF_ctx : forall vars hyps F dom,
Full vars ->
WF_hyp_ctx vars hyps F ->
WF_hyp_ctx (vars\dom) hyps F.
induction F.
left.
right;inversion H0;dependent rewrite H8 in H9;simpl in H9;subst.
apply Weak_WF_form;auto.
apply IHF;auto.
Qed.

(* si une formule est tautologique alors elle est vraie dans tout contexte *)
Lemma Compose0 : forall vars F' hyps F  (A:var_env Denv -> Prop),
(forall Venv, Instanceof Denv vars F' Venv -> A Venv) ->
interp_vars vars F' (interp_hyps  hyps F A).
intros vars F' hyps F .
induction F;induction F';intros A H;simpl in * |-*.
apply H;left.
eauto.
apply (IHF' (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, A (Venv \ [var; a]))).
intros Venv Inst x.
apply H;right;auto.
eauto.
eauto.
Qed.

Lemma Compose1 : forall vars F' hyps F  (A B:var_env Denv -> Prop),
(forall Venv, Instanceof Denv vars F' Venv -> A Venv -> B Venv) ->
interp_vars vars F' (interp_hyps hyps F A) ->
interp_vars vars F' (interp_hyps hyps F B).
intros vars F' hyps F .
induction F;
induction F';intros A B H;simpl in * |-*.
apply H;left.
intros; apply (IHF' (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, A (Venv \ [var; a]))
   (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, B (Venv \ [var; a])));auto.
intros Venv Inst HA x.
apply H.
right;auto.
auto.
apply IHF;eauto.
apply IHF;eauto.
Qed.

Lemma Compose2 : forall vars F' hyps F  (A B C:var_env Denv -> Prop),
(forall Venv, Instanceof Denv vars F' Venv -> A Venv -> B Venv -> C Venv) ->
interp_vars vars F' (interp_hyps hyps F A) ->
interp_vars vars F' (interp_hyps hyps F B) ->
interp_vars vars F' (interp_hyps hyps F C).
intros vars F' hyps F .
induction F;
induction F';intros A B C H;simpl in * |-*.
apply H;left.
intros HA HB.
apply (IHF' (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, A (Venv \ [var; a]))
   (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, B (Venv \ [var; a]))
   (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, C (Venv \ [var; a])));auto.
intros Venv Inst HAA HBB x.
apply H;auto.
right;auto.
apply IHF;eauto.
apply IHF;eauto.
Qed.

Lemma Compose3 : forall vars F' hyps F  (A B C D:var_env Denv -> Prop),
(forall Venv, Instanceof Denv vars F' Venv -> A Venv -> B Venv -> C Venv -> D Venv) ->
interp_vars vars F' (interp_hyps hyps F A) ->
interp_vars vars F' (interp_hyps hyps F B) ->
interp_vars vars F' (interp_hyps hyps F C) ->
interp_vars vars F' (interp_hyps hyps F D).
intros vars F' hyps F .
induction F;
induction F';intros A B C D H;simpl in * |-*.
apply H ;left.
intros HA HB HC.
apply (IHF' (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, A (Venv \ [var; a]))
   (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, B (Venv \ [var; a]))
   (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, C (Venv \ [var; a]))
   (fun Venv : var_env Denv =>
   forall var : interp_domain Denv a, D (Venv \ [var; a])));auto.
intros Venv Inst HAA HBB HCC x.
apply H;auto.
right;auto.
apply IHF;eauto.
apply IHF;eauto.
Qed.

Ltac norefl := repeat match goal with [ H: ?x = ?x |- _ ] => clear H end.

Lemma Global_bind :
forall dom vars Fv hyps Fh Inside,
WF_hyp_ctx vars hyps Fh ->
interp_vars vars Fv
  (fun Venv : var_env Denv =>
   forall var : interp_domain Denv dom,
   interp_hyps hyps Fh Inside (Venv \ [var; dom])) ->
interp_vars vars Fv
  (interp_hyps hyps Fh
     (fun Venv : var_env Denv =>
      forall var : interp_domain Denv dom, Inside (Venv \ [var; dom]))).

induction Fh;simpl.
auto.
intros Inside W;inversion W;simpl;subst.
norefl.
intro h.
cut
(interp_vars vars Fv
  (interp_hyps S Fh
     (fun Venv : var_env Denv =>
     forall var : interp_domain Denv dom,
     (fun V =>
      interp_form Denv Sigma Pi V nil a ->
      Inside V) (Venv \ [var; dom])))).
apply (Compose1 vars Fv S Fh).
intros Venv Inst hh Ha x.
apply (hh x).
apply (proj1 (Weak_interp_form _ _ _ _ _ _ [x;dom] a nil Inst H2) Ha).
dependent rewrite H6 in H7 ;simpl in H7.
change
(interp_vars vars Fv
  (interp_hyps S Fh
     (fun Venv : var_env Denv =>
      forall var : interp_domain Denv dom,
      (fun V =>
      interp_form Denv Sigma Pi V nil a ->
      Inside  V) (Venv \ [var; dom])))).
apply IHFh;auto.
Qed.

Lemma WF_form_In : forall V hyps F f,
In f hyps F ->
WF_hyp_ctx V hyps F ->
WF_form Denv Sigma Pi V nil f .
induction F;simpl In.
intros;elim H.
intros f [H | H] W;subst;inversion W.
trivial.
apply IHF;trivial.
change
(let (x,P) := existS (fun S: Store form => Full S) S F1 in
             WF_hyp_ctx V x P) in H8.
rewrite H7 in H8.
assumption.
Qed.

Lemma WF_form_hyp : forall V hyps F i f,
get i hyps = PSome f ->
WF_hyp_ctx V hyps F ->
WF_form Denv Sigma Pi V nil f.
intros hyps F V i f ei.
apply WF_form_In.
apply get_In with i;trivial.
Qed.

Theorem Project_In : forall V F hyps Fh f, In f hyps Fh ->
WF_hyp_ctx V hyps Fh ->
interp_seq V F hyps Fh f.
induction Fh.
simpl;intros f H _;elim H.
simpl In.
intros f [H | H] W.
subst;unfold interp_seq;simpl interp_hyps.
apply (Compose0 V F S Fh) ;auto.
inversion W.
change
(let (x,P) := existS (fun S : Store form => Full S) S F1 in
             WF_hyp_ctx V x P) in H8.
rewrite H7 in H8.
simpl in H8.
generalize (IHFh f H H8).
unfold interp_seq;simpl.
apply Compose1.
auto.
Qed.

Theorem Project : forall V F hyps Fh i f,
get i hyps = PSome f ->
WF_hyp_ctx V hyps Fh ->
interp_seq V F hyps Fh f.
intros; apply Project_In;trivial.
apply get_In with i;assumption.
Qed.

Lemma interp_list_app_var : forall l dom (Inside: var_env Denv -> Prop),
interp_var_list empty l
  (fun Venv => forall x,  Inside (Venv \ [ x ; dom ] )) <->
interp_var_list empty (l ++ dom :: nil) Inside.
intros l dom;generalize (@empty (obj_entry Denv)) (@F_empty (obj_entry Denv)).
induction l.
intros S F Inside.
simpl;split;trivial.
simpl.
intros S F Inside .
elim (IHl S F Inside).
split;
intros h1 var;elim (IHl (S \ [var;a]) (F_push _ _ F) Inside);
auto.
Qed.

Lemma interp_list_app_form : forall l f Venv (Inside: var_env Denv -> Prop),
interp_hyp_list l
  (fun Venv => interp_form Denv Sigma Pi Venv nil f -> Inside Venv) Venv <->
interp_hyp_list (l ++ f :: nil) Inside Venv.
intros l f.
induction l;simpl.
simpl;split;trivial.
intros Venv Inside.
split;
intros h1 var;elim (IHl Venv  Inside);
auto.
Qed.

Definition form_Eq p q := forall vars rels ,
 (interp_form Denv Sigma Pi vars rels p <-> interp_form Denv Sigma Pi vars rels q).

Lemma interp_seq_interp:   forall goal,
  forall vars Fv lvars,
  Equiv domain (@eq domain) lvars vars Fv ->
  forall hyps Fh lhyps,
  Equiv form form_Eq lhyps hyps Fh ->
  (interp_seq vars Fv hyps  Fh goal <->
  interp lvars lhyps goal).
intros goal vars Fv lvars Ev hyps Fh lhyps Eh.
unfold interp_seq,interp.
apply iff_trans with
(interp_vars vars Fv
  (interp_hyp_list lhyps
     (fun Venv : var_env Denv => interp_form Denv Sigma Pi Venv nil goal))).
generalize lhyps Eh
(fun Venv : var_env Denv => interp_form Denv Sigma Pi Venv nil goal);
clear lhyps Eh;induction Fh;intros lhyps Eh Inside;inversion Eh;simpl.
split;trivial.
apply iff_trans with
    (interp_vars vars Fv
    (interp_hyp_list l
    (fun Venv : var_env Denv =>
    interp_form Denv Sigma Pi Venv nil a -> Inside Venv))).
dependent rewrite H7 in H3;simpl in H3;subst.
apply IHFh;auto.
simpl;split.
apply (Compose1 vars Fv empty F_empty
     (interp_hyp_list l
     (fun Venv : var_env Denv =>
      interp_form Denv Sigma Pi Venv nil a -> Inside Venv))
      (interp_hyp_list (l ++ a0 :: nil) Inside)).
intros Venv Inst.
elim (interp_list_app_form l a0 Venv Inside).
intros hh _ h;apply hh;clear hh;generalize h;clear h.
generalize l;induction l0;simpl.
assert (h:=proj1(H8 Venv nil));auto.
auto.
apply (Compose1 vars Fv empty F_empty
      (interp_hyp_list (l ++ a0 :: nil) Inside)
     (interp_hyp_list l
     (fun Venv : var_env Denv =>
      interp_form Denv Sigma Pi Venv nil a -> Inside Venv))).
intros Venv Inst.
elim (interp_list_app_form l a Venv Inside).
intros _ hh h;apply hh;clear hh;generalize h;clear h.
generalize l;induction l0;simpl.
assert (h:=proj2(H8 Venv nil));auto.
auto.
generalize lvars Ev (interp_hyp_list lhyps
     (fun Venv : var_env Denv => interp_form Denv Sigma Pi Venv nil goal));
clear lvars Ev;induction Fv;intros lvars Ev Inside;inversion Ev;simpl.
split;trivial.
apply iff_trans with
    (interp_var_list empty l
    (fun Venv : var_env Denv =>
    forall var : interp_domain Denv a, Inside (Venv \ [var; a])));auto.
dependent rewrite H7 in H3;simpl in H3.
apply IHFv;auto.
subst.
apply interp_list_app_var.
Qed.

End with_env.


(** * Integer with infinity *)
(******************************************************************************)
(*       Copyright (C) 2019-2021 Florent Hivert <florent.hivert@lri.fr>       *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrfun ssrnat eqtype fintype choice.
From mathcomp Require Import order bigop.

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

Import Order.Syntax.
Import Order.TTheory.

Section NatBar.

Open Scope order_scope.

(** Clone of option nat to avoid the very confusing chain of coercions *)
(**   option -> bool -> nat                                            *)
Inductive natbar : Set :=  Nat of nat | Inf.
Definition opt_natbar (v : natbar) : option nat :=
  if v is Nat n then Some n else None.
Definition natbar_opt (v : option nat) : natbar :=
  if v is Some n then Nat n else Inf.

Lemma opt_natbarK : cancel opt_natbar natbar_opt.
Proof. by case. Qed.
Lemma natbar_optK : cancel natbar_opt opt_natbar.
Proof. by case. Qed.
Definition natbar_eqMixin := CanEqMixin opt_natbarK.
Canonical natbar_eqType := Eval hnf in EqType natbar natbar_eqMixin.
Definition natbar_choiceMixin := CanChoiceMixin opt_natbarK.
Canonical natbar_choiceType := Eval hnf in ChoiceType natbar natbar_choiceMixin.
Definition natbar_countMixin := CanCountMixin opt_natbarK.
Canonical natbar_countType := Eval hnf in CountType natbar natbar_countMixin.

Implicit Type (m n o p : nat).
Implicit Type (u v w x y : natbar).

Lemma Nat_inj : injective Nat. Proof. by move=> m n []. Qed.
Lemma Nat_eqE m n : (Nat m == Nat n) = (m == n).
Proof. by apply/eqP/eqP => [/Nat_inj|<-]. Qed.

Definition addbar u v : natbar :=
  match u, v with
  | Nat m, Nat n => Nat (m + n)
  | _, _ => Inf
  end.

Lemma add0bar : left_id  (Nat 0) addbar. Proof. by case. Qed.
Lemma addbar0 : right_id (Nat 0) addbar.
Proof. by case=> //= n; rewrite addn0. Qed.

Lemma addIbar : left_zero  Inf addbar. Proof. by case. Qed.
Lemma addbarI : right_zero Inf addbar. Proof. by case. Qed.

Lemma addbarCA : left_commutative addbar.
Proof. by case=> [m|] [n|] [p|] //=; rewrite addnCA. Qed.

Lemma addbarC : commutative addbar.
Proof. by case=> [m|] [n|] //=; rewrite addnC. Qed.

Lemma addbarA : associative addbar.
Proof. by case=> [m|] [n|] [p|] //=; rewrite addnA. Qed.

Lemma addbarAC : right_commutative addbar.
Proof. by case=> [m|] [n|] [p|] //=; rewrite addnAC. Qed.

Lemma addbarACA : interchange addbar addbar.
Proof. by case=> [m|] [n|] [p|] [q|] //=; rewrite addnACA. Qed.

Lemma addbar_eq0 u v : (addbar u v == Nat 0) = (u == Nat 0) && (v == Nat 0).
Proof.
by case: u v => [m|] [n|] //=; rewrite !Nat_eqE /= ?addn_eq0 ?andbF.
Qed.

Lemma addbar_eqI u v : (addbar u v == Inf) = (u == Inf) || (v == Inf).
Proof. by case: u v => [m|] [n|]. Qed.

Canonical natbar_monoid := Monoid.Law addbarA add0bar addbar0.
Canonical natbar_comoid := Monoid.ComLaw addbarC.

(** Valuation ordering *)
Definition lebar u v :=
  match u, v with
  | _, Inf => true
  | Nat m, Nat n => m <= n
  | _, _ => false
  end.
Definition ltbar u v := (v != u) && (lebar u v).
Definition meetbar x y := if ltbar x y then x else y.
Definition joinbar x y := if ltbar x y then y else x.
Definition lebar_display : unit. Proof. exact: tt. Qed.

Program Definition natbar_OrderMixin :=
  @LeOrderMixin _ lebar ltbar meetbar joinbar _ _ _ _ _ _.
Next Obligation. by case=> [m|] [n|] //=; rewrite -eqn_leq => /eqP ->. Qed.
Next Obligation. by case=> [m|] [n|] [p|] //=; apply leq_trans. Qed.
Next Obligation. by case=> [m|] [n|] //=; exact: leq_total. Qed.

Canonical natbar_porderType :=
  Eval hnf in POrderType lebar_display natbar natbar_OrderMixin.
Canonical natbar_atticeType :=
  Eval hnf in LatticeType natbar natbar_OrderMixin.
Canonical natbar_distrLatticeType :=
  Eval hnf in DistrLatticeType natbar natbar_OrderMixin.
Canonical natbar_orderType :=
  Eval hnf in OrderType natbar natbar_OrderMixin.

Lemma le0bar v : Nat 0 <= v. Proof. by case: v. Qed.
Canonical natbar_bLatticeType :=
  Eval hnf in BLatticeType natbar (BottomMixin le0bar).

Lemma leEnatbar (n m : nat) : (Nat n <= Nat m) = (n <= m)%N.
Proof. by []. Qed.

Lemma ltEnatbar (n m : nat) : (Nat n < Nat m) = (n < m)%N.
Proof. by rewrite lt_neqAle leEnatbar Nat_eqE ltn_neqAle. Qed.

Lemma lebar_total : total lebar.
Proof. exact: le_total. Qed.

Lemma lebarI v : v <= Inf. Proof. by case v. Qed.

Canonical natbar_tbDistrLatticeType :=
  Eval hnf in TBLatticeType natbar (TopMixin lebarI).

Lemma ltbar0Sn n : 0 < Nat n.+1.       Proof. by []. Qed.
Lemma ltbarS n : Nat n < Nat n.+1.     Proof. by rewrite ltEnatbar. Qed.
Lemma lebarS n : Nat n <= Nat n.+1.    Proof. by rewrite leEnatbar. Qed.
Hint Resolve lebarS : core.
Lemma ltIbar v : Inf < v = false.      Proof. exact/le_gtF/lex1. Qed.
Lemma leInatbar n : Inf <= Nat n = false.
Proof. by []. Qed.

Lemma minbarE : {morph Nat : m n / minn m n >-> Order.meet m n}.
Proof.
move=> m n; case: (leqP m n) => [| /ltnW].
- by rewrite -leEnatbar => /meet_idPl.
- by rewrite -leEnatbar => /meet_idPr.
Qed.

Lemma maxbarE : {morph Nat : m n / maxn m n >-> Order.join m n}.
Proof.
move=> m n; case: (leqP m n) => [| /ltnW].
- by rewrite -leEnatbar => /join_idPr.
- by rewrite -leEnatbar => /join_idPl.
Qed.

End NatBar.