(** * Rigs category *)
(** ** Contents
- Precategory of rigs
- Category of rigs
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.UnivalenceAxiom.

Require Import UniMath.Algebra.BinaryOperations.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.RigsAndRings.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Local Open Scope cat.

(** * Precategory of rigs *)
Section def_rig_precategory.

  Definition rig_fun_space (A B : rig) : hSet := make_hSet (rigfun A B) (isasetrigfun A B).

  Definition rig_precategory_ob_mor : precategory_ob_mor :=
    tpair (λ ob : UU, ob -> ob -> UU) rig (λ A B : rig, rig_fun_space A B).

  Definition rig_precategory_data : precategory_data :=
    make_precategory_data
      rig_precategory_ob_mor (λ (X : rig), (rigisotorigfun (idrigiso X)))
      (fun (X Y Z : rig) (f : rigfun X Y) (g : rigfun Y Z) => rigfuncomp f g).

  Local Definition rig_id_left (X Y : rig) (f : rigfun X Y) :
    rigfuncomp (rigisotorigfun (idrigiso X)) f = f.
  Proof.
    use rigfun_paths. use idpath.
  Defined.
  Opaque rig_id_left.

  Local Definition rig_id_right (X Y : rig) (f : rigfun X Y) :
    rigfuncomp f (rigisotorigfun (idrigiso Y)) = f.
  Proof.
    use rigfun_paths. use idpath.
  Defined.
  Opaque rig_id_right.

  Local Definition rig_assoc (X Y Z W : rig) (f : rigfun X Y) (g : rigfun Y Z) (h : rigfun Z W) :
    rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h.
  Proof.
    use rigfun_paths. use idpath.
  Defined.
  Opaque rig_assoc.

  Lemma is_precategory_rig_precategory_data : is_precategory rig_precategory_data.
  Proof.
    use make_is_precategory_one_assoc.
    - intros a b f. use rig_id_left.
    - intros a b f. use rig_id_right.
    - intros a b c d f g h. use rig_assoc.
  Qed.

  Definition rig_precategory : precategory :=
    make_precategory rig_precategory_data is_precategory_rig_precategory_data.

  Lemma has_homsets_rig_precategory : has_homsets rig_precategory.
  Proof.
    intros X Y. use isasetrigfun.
  Qed.

End def_rig_precategory.

(** * Category of rigs *)
Section def_rig_category.

  Definition rig_category : category := make_category _ has_homsets_rig_precategory.

  (** ** (rigiso X Y) ≃ (iso X Y) *)

  Lemma rig_iso_is_equiv (A B : ob rig_category) (f : z_iso A B) : isweq (pr1 (pr1 f)).
  Proof.
    use isweq_iso.
    - exact (pr1rigfun _ _ (inv_from_z_iso f)).
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x).
      intros x0. use isapropisrigfun.
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x).
      intros x0. use isapropisrigfun.
  Defined.
  Opaque rig_iso_is_equiv.

  Lemma rig_iso_equiv (X Y : ob rig_category) : z_iso X Y -> rigiso (X : rig) (Y : rig).
  Proof.
    intro f.
    use make_rigiso.
    - exact (make_weq (pr1 (pr1 f)) (rig_iso_is_equiv X Y f)).
    - exact (pr2 (pr1 f)).
  Defined.

  Lemma rig_equiv_is_z_iso (X Y : ob rig_category) (f : rigiso (X : rig) (Y : rig)) :
    @is_z_isomorphism rig_precategory X Y (rigfunconstr (pr2 f)).
  Proof.
    exists (rigfunconstr (pr2 (invrigiso f))).
    use make_is_inverse_in_precat.
    - use rigfun_paths. use funextfun. intros x. use homotinvweqweq.
    - use rigfun_paths. use funextfun. intros y. use homotweqinvweq.
  Defined.
  Opaque rig_equiv_is_z_iso.

  Lemma rig_equiv_z_iso (X Y : ob rig_category) : rigiso (X : rig) (Y : rig) -> z_iso X Y.
  Proof.
    intros f.
    exists (rigfunconstr (pr2 f)).
    exact (rig_equiv_is_z_iso X Y f).
  Defined.

  Lemma rig_iso_equiv_is_equiv (X Y : rig_category) : isweq (rig_iso_equiv X Y).
  Proof.
    use isweq_iso.
    - exact (rig_equiv_z_iso X Y).
    - intros x. use z_iso_eq. use rigfun_paths. use idpath.
    - intros y. use rigiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + use idpath.
  Defined.
  Opaque rig_iso_equiv_is_equiv.

  Definition rig_iso_equiv_weq (X Y : ob rig_category) :
    weq (z_iso X Y) (rigiso (X : rig) (Y : rig)).
  Proof.
    use make_weq.
    - exact (rig_iso_equiv X Y).
    - exact (rig_iso_equiv_is_equiv X Y).
  Defined.

  Lemma rig_equiv_iso_is_equiv (X Y : ob rig_category) : isweq (rig_equiv_z_iso X Y).
  Proof.
    use isweq_iso.
    - exact (rig_iso_equiv X Y).
    - intros y. use rigiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + use idpath.
    - intros x. use z_iso_eq. use rigfun_paths. use idpath.
  Defined.
  Opaque rig_equiv_iso_is_equiv.

  Definition rig_equiv_weq_iso (X Y : ob rig_category) :
    (rigiso (X : rig) (Y : rig)) ≃ (z_iso X Y).
  Proof.
    use make_weq.
    - exact (rig_equiv_z_iso X Y).
    - exact (rig_equiv_iso_is_equiv X Y).
  Defined.

  (** ** Category of rigs *)

  Definition rig_category_isweq (X Y : ob rig_category) : isweq (λ p : X = Y, idtoiso p).
  Proof.
    use (@isweqhomot
           (X = Y) (z_iso X Y)
           (pr1weq (weqcomp (rig_univalence X Y) (rig_equiv_weq_iso X Y)))
           _ _ (weqproperty (weqcomp (rig_univalence X Y)
                                     (rig_equiv_weq_iso X Y)))).
    intros e. induction e.
    use (pathscomp0 weqcomp_to_funcomp_app).
    use total2_paths_f.
    - use idpath.
    - use proofirrelevance. use isaprop_is_z_isomorphism.
  Defined.
  Opaque rig_category_isweq.

  Definition rig_category_is_univalent : is_univalent rig_category.
  Proof.
    intros X Y. exact (rig_category_isweq X Y).
  Defined.

  Definition rig_univalent_category : univalent_category :=
    make_univalent_category rig_category rig_category_is_univalent.

End def_rig_category.


(********************************************************************************
* Formalization of labelled lambda ex calculus				        *
*									        *
* Flavio L. C. de Moura & Daniel L. Ventura & Washington R. Segundo, 2014	*
*********************************************************************************)

Set Implicit Arguments.
Require Import Metatheory LambdaES_Defs LambdaES_Infra LambdaES_FV.
Require Import Rewriting_Defs Rewriting_Lib.
Require Import Equation_C Lambda Lambda_Ex.

(*
(** Given a relation Red, constructs its contextual closure just over Lterms *)
Inductive L_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | L_redex : forall t s, Red t s -> L_contextual_closure Red t s
  | L_app_left : forall t t' u, Lterm u -> L_contextual_closure Red t t' ->
	  		L_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | L_app_right : forall t u u', Lterm t -> L_contextual_closure Red u u' ->
	  		L_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | L_abs_in : forall t t' L, (forall x, x \notin L -> L_contextual_closure Red (t^x) (t'^x))
      -> L_contextual_closure Red (pterm_abs t) (pterm_abs t')
.

(** Given a relation Red, constructs its parallel contextual closure *)
Inductive p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | p_redex : forall t s, Red t s -> p_contextual_closure Red t s
  | p_app : forall t t' u u', p_contextual_closure Red t t' -> p_contextual_closure Red u u' ->
	  		p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
  | p_abs_in : forall t t' L, (forall x, x \notin L -> p_contextual_closure Red (t^x) (t'^x)) ->
               p_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | p_subst : forall t t' u u' L, (forall x, x \notin L -> p_contextual_closure Red (t^x) (t'^x)) ->
              p_contextual_closure Red u u' ->
	      p_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u') .
*)

(** Step 1 *)

(** Grammar of labelled pre-terms. Labelled terms extend the ordinary
 terms with a new constructor for marked explicit substitutions. *)

Inductive lab_term : pterm -> Prop :=
  | lab_term_var : forall x,
      lab_term (pterm_fvar x)
  | lab_term_app : forall t1 t2,
      lab_term t1 ->
      lab_term t2 ->
      lab_term (pterm_app t1 t2)
  | lab_term_abs : forall L t1,
      (forall x, x \notin L -> lab_term (t1 ^ x)) ->
      lab_term (pterm_abs t1)
  | lab_term_sub : forall L t1 t2,
     (forall x, x \notin L -> lab_term (t1 ^ x)) ->
      lab_term t2 -> lab_term (t1[t2])
  | lab_term_sub' : forall L t1 t2,
     (forall x, x \notin L -> lab_term (t1 ^ x)) ->
      (term t2) -> (SN lex t2) ->
      lab_term (t1 [[ t2 ]]).

Definition lab_body (t : pterm) :=
           exists L, forall x, x \notin L -> lab_term (t ^ x).

(** Given a relation Red, constructs the contextual closure for labelled terms. *)

Inductive lab_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | lab_redex : forall t s, Red t s -> lab_contextual_closure Red t s
  | lab_app_left : forall t t' u, lab_term u -> lab_contextual_closure Red t t' ->
	  		lab_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | lab_app_right : forall t u u', lab_term t -> lab_contextual_closure Red u u' ->
	  		lab_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | lab_abs_in : forall t t' L, (forall x, x \notin L -> lab_contextual_closure Red (t^x) (t'^x))
      -> lab_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | lab_subst_left : forall t t' u L, lab_term u ->
	  	(forall x, x \notin L -> lab_contextual_closure Red (t^x) (t'^x)) ->
	        lab_contextual_closure Red  (t[u]) (t'[u])
  | lab_subst_right : forall t u u', lab_body t -> lab_contextual_closure Red u u' ->
	  	lab_contextual_closure Red  (t[u]) (t[u'])
  | lab_subst'_left : forall t t' u L, term u -> SN lex u ->
	  	(forall x, x \notin L -> lab_contextual_closure Red (t^x) (t'^x)) ->
	        lab_contextual_closure Red  (t[[u]]) (t'[[u]])
  | lab_subst'_right : forall t u u', lab_body t -> SN lex u -> Red u u' ->
	  	lab_contextual_closure Red  (t[[u]]) (t[[u']])
.

(* ====================================================================== *)
(** ** Alternative definition for local closure *)

(* ********************************************************************** *)
(** Local closure for marked terms. *)

Fixpoint lc_at' (k:nat) (t:pterm) {struct t} : Prop :=
  match t with
  | pterm_bvar i    => i < k
  | pterm_fvar x    => True
  | pterm_app t1 t2 => lc_at' k t1 /\ lc_at' k t2
  | pterm_abs t1    => lc_at' (S k) t1
  | pterm_sub t1 t2 => (lc_at' (S k) t1) /\ lc_at' k t2
  | pterm_sub' t1 t2 => (lc_at k t2) /\ (SN lex t2) /\ (lc_at' (S k) t1)
  end.

Definition term'' t := lc_at' 0 t.

Definition body'' t := lc_at' 1 t.

(** Labelled lambda ex calculus. There is just one B rule that works
both in the labelled and non-labelled calculus. *)

(** Labelled equations *)

Inductive lab_eqc  : pterm -> pterm -> Prop :=
| lab_eqc_rf: forall u, lab_eqc u u
| lab_eqc_rx1 : forall t u v,
                  lab_term u -> term v -> lab_eqc (t[u][[v]]) ((& t)[[v]][u])
| lab_eqc_rx2 : forall t u v,
                  term u -> lab_term v -> lab_eqc (t[[u]][v]) ((& t)[v][[u]])
| lab_eqc_rx3 : forall t u v,
                  term u -> term v -> lab_eqc (t[[u]][[v]]) ((& t)[[v]][[u]]).

Lemma lab_eqc_sym : forall t u, lab_eqc t u -> lab_eqc u t.
Proof.
  intros t u Heqc.
  destruct Heqc.
  apply lab_eqc_rf.
  replace ((t [u]) [[v]]) with (((& (& t)) [u]) [[v]]).
  apply lab_eqc_rx2; assumption.
  rewrite bswap_idemp; trivial.
  replace ((t [[u]]) [v]) with (((& (& t)) [[u]]) [v]).
  apply lab_eqc_rx1; assumption.
  rewrite bswap_idemp; trivial.
  replace ((t [[u]]) [[v]]) with (((& (& t)) [[u]]) [[v]]).
  apply lab_eqc_rx3; assumption.
  rewrite bswap_idemp; trivial.
Qed.

Lemma lab_eqc_trans : forall t u v, lab_eqc t u -> lab_eqc u v -> lab_eqc t v.
Proof.
  intros t u v Htu Huv.
  destruct Huv.
  assumption.
  inversion Htu.
  apply lab_eqc_rx1; assumption.
  rewrite bswap_idemp; trivial.
  apply lab_eqc_rf.
  inversion Htu.
  apply lab_eqc_rx2; assumption.
  rewrite bswap_idemp; trivial.
  apply lab_eqc_rf.
  inversion Htu.
  apply lab_eqc_rx3; assumption.
  rewrite bswap_idemp; trivial.
  apply lab_eqc_rf.
Qed.

Instance lab_eqc_eq : Equivalence lab_eqc.
Proof.
 split; intros_all.
 apply lab_eqc_rf.
 apply lab_eqc_sym; trivial.
 generalize H H0. apply lab_eqc_trans.
Qed.

Definition lab_eqC (t: pterm) (u : pterm) :=  trans_closure (lab_contextual_closure lab_eqc) t u .
Notation "t =~e u" := (lab_eqC t u) (at level 66).

(** TBD:regularity and contextual lemmas are missing. *)

(** Step 2 *)

(** The extended reduction system. This system is used to propagate
terminating labelled substitutions. *)

Inductive lab_sys_x : pterm -> pterm -> Prop :=
| lab_reg_rule_var : forall t, lab_term (pterm_bvar 0 [[t]]) -> lab_sys_x (pterm_bvar 0 [[t]]) t

| lab_reg_rule_gc : forall t u, lab_term t -> lab_term (t[[u]]) -> lab_sys_x (t[[u]]) t

| lab_reg_rule_app : forall t1 t2 u, lab_term (t1[[u]]) -> lab_term (t2[[u]]) ->
  lab_sys_x ((pterm_app t1 t2)[[u]]) (pterm_app (t1[[u]]) (t2[[u]]))

| lab_reg_rule_lamb : forall t u, lab_term ((pterm_abs t)[[u]]) ->
  lab_sys_x ((pterm_abs t)[[u]]) (pterm_abs ((& t)[[u]]))

| lab_reg_rule_comp : forall t u v, lab_term ((t[u])[[v]]) -> ~ term u ->
  lab_sys_x (t[u][[v]]) (((& t)[[v]])[u[[v]]]).
Notation "t ->_lab_x u" := (lab_sys_x t u) (at level 59, left associativity).

Inductive lab_sys_lx: pterm -> pterm -> Prop :=
| B_lx : forall t u, t ->_B u -> lab_sys_lx t u
| sys_x_lx : forall t u, t ->_x u -> lab_sys_lx t u
| sys_x_lab_lx : forall t u, t ->_lab_x u -> lab_sys_lx t u.

Definition red_ctx_mod_lab_eqC (R: pterm -> pterm -> Prop) (t: pterm) (u : pterm) :=
           exists t' u', (t =~e t')/\(contextual_closure R t' u')/\(u' =~e u).

Definition lab_ex (t: pterm) (u : pterm) :=
    exists t' u', (t =~e t')/\(lab_contextual_closure lab_sys_x t' u')/\(u' =~e u).

Definition lab_lex (t: pterm) (u : pterm) :=
    exists t' u', (t =~e t')/\(lab_contextual_closure lab_sys_lx t' u')/\(u' =~e u).

Notation "t -->[ex] u" := (lab_ex t u) (at level 59, left associativity).
Notation "t -->[lex] u" := (lab_lex t u) (at level 59, left associativity).

Definition red_lab_regular (R : pterm -> pterm -> Prop) :=
  forall t t',  R t t' -> lab_term t /\ lab_term t'.

Definition red_lab_regular' (R : pterm -> pterm -> Prop) :=
  forall t t',  R t t' -> (lab_term t <-> lab_term t').

(** Unlabelled of S-terms *)
Fixpoint U_lab (t : pterm) : pterm :=
  match t with
  | pterm_bvar i    => pterm_bvar i
  | pterm_fvar x    => pterm_fvar x
  | pterm_app t1 t2 => pterm_app (U_lab t1) (U_lab t2)
  | pterm_abs t1    => pterm_abs (U_lab t1)
  | pterm_sub t1 t2 => pterm_sub (U_lab t1) (U_lab t2)
  | pterm_sub' t1 t2 => pterm_sub (U_lab t1) t2
  end.

(* ********************************************************************** *)
(** pterm lists  properties *)

Fixpoint cr_lc_at_list (n : nat) (l : list pterm) {struct l} : Prop :=
 match l with
 | nil => True
 | t::lu =>  lc_at' n t /\ (cr_lc_at_list (S n) lu)
 end.

Lemma lc_at_mult_sub : forall n t lu, lc_at' n (t//[lu]) <-> (lc_at' (n + length lu) t /\ cr_lc_at_list n lu).
Proof.
 intros. generalize n; clear n. induction lu; simpl.
 split. intro. assert (Q : n + 0 = n); try omega. rewrite Q. split; trivial.
 intro. assert (Q : n + 0 = n); try omega. rewrite Q in H. apply H.
 intro n. replace (n + S (length lu)) with ((S n) + length lu). split.
 intro H. destruct H. split.
 apply IHlu; trivial. split; trivial. apply IHlu; trivial.
 intro H. destruct H. destruct H0. split; trivial. apply IHlu. split; trivial.
 omega.
Qed.

(** Step 3 *)

(** Step 4 *)


Require Export Iron.Language.SimpleData.Ty.
Require Export Iron.Language.SimpleData.Def.

(* Expressions *)
Inductive exp : Type :=
 (* Functions *)
 | XVar   : nat -> exp
 | XLam   : ty  -> exp -> exp
 | XApp   : exp -> exp -> exp

 (* Data Types *)
 | XCon   : datacon -> list exp -> exp
 | XCase  : exp     -> list alt -> exp

 (* Alternatives *)
with alt     : Type :=
 | AAlt   : datacon -> list ty  -> exp -> alt.

Hint Constructors exp.
Hint Constructors alt.

(********************************************************************)
(* Mutual induction principle for expressions.
   As expressions are indirectly mutually recursive with lists,
   Coq's Combined scheme command won't make us a strong enough
   induction principle, so we need to write it out by hand. *)
Theorem exp_mutind
 : forall
    (PX : exp -> Prop)
    (PA : alt -> Prop)
 ,  (forall n,                                PX (XVar n))
 -> (forall t  x1,   PX x1                 -> PX (XLam t x1))
 -> (forall x1 x2,   PX x1 -> PX x2        -> PX (XApp x1 x2))
 -> (forall dc xs,            Forall PX xs -> PX (XCon dc xs))
 -> (forall x  aa,   PX x  -> Forall PA aa -> PX (XCase x aa))
 -> (forall dc ts x, PX x                  -> PA (AAlt dc ts x))
 ->  forall x, PX x.
Proof.
 intros PX PA.
 intros var lam app con case alt.
 refine (fix  IHX x : PX x := _
         with IHA a : PA a := _
         for  IHX).

 (* expressions *)
 case x; intros.

 Case "XVar".
  apply var.

 Case "XLam".
  apply lam.
   apply IHX.

 Case "XApp".
  apply app.
   apply IHX.
   apply IHX.

 Case "XCon".
  apply con.
   induction l; intuition.

 Case "XCase".
  apply case.
   apply IHX.
   induction l; intuition.

 (* alternatives *)
 case a; intros.

 Case "XAlt".
  apply alt.
   apply IHX.
Qed.


Require Export refine.
Require Export parser.

Require Export Station.
Require Export Vehicle.
Require Export comp.

(** The CyCab example *)

Definition FVehicle: IA := parse
 "IA [s1,s2,s3,s4,s5,s6] (s1) [fstart,start,emrg,far,halt] [pos,reset] [move,stop]
  [s1->(start)s2, s2->(move)s3, s2->(emrg)s5, s3->(pos)s4, s3->(emrg)s5, s4->(far)s2,
  s4->(halt)s1, s4->(emrg)s5, s5->(reset)s1, s1->(fstart)s6, s6->(move)s6, s6->(emrg)s5,
  s6->(stop)s1]".

(* FVehicle is a refinement of Vehicle *)
Eval compute in IAutomaton.bRefine Vehicle FVehicle.

Eval compute in IAutomaton.b_compatible FVehicle Station.

(*Definition FVehicle_Station_prod: IA := IAutomaton.IAProd FVehicle Station.
Eval compute in :> FVehicle_Station_prod.*)

Definition FVehicle_Station: IA :=IAutomaton.composition FVehicle Station.
Eval compute in :> FVehicle_Station.

(* the composition results comply with the refinement relation *)
Eval compute in IAutomaton.bRefine Vehicle_Station FVehicle_Station.

(*********** security of FVehicle*Station ******************************************)

(*************************** \Gamma(fstart)=h ****************************)
(* SIR-GNNI at m: true *)
Definition FVehicle_Station_hid_m: IA :=
 IAutomaton.hiding FVehicle_Station (ASet.GenActs [&"emrg",&"reset",&"fstart"]).

Definition FVehicle_Station_res_m: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction FVehicle_Station (ASet.GenActs [&"emrg",&"fstart"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> FVehicle_Station_hid_m.
Eval compute in :> FVehicle_Station_res_m.
Eval compute in SIRGNNI_refinement FVehicle_Station_res_m FVehicle_Station_hid_m.

(* SME-NI at m: true *)
Definition FVehicle_Station_rep_m: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement FVehicle_Station (&"tau") (ASet.GenActs [&"emrg",&"fstart"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> FVehicle_Station_rep_m.
Eval compute in SMENI_refinement FVehicle_Station_rep_m FVehicle_Station_hid_m.

(* SIR-GNNI at l: true *)
Definition FVehicle_Station_hid_l: IA :=
  IAutomaton.hiding FVehicle_Station
  (ASet.GenActs [&"emrg",&"start",&"fstart",&"reset"]).

Definition FVehicle_Station_res_l: IA :=
  IAutomaton.hiding
  ( IAutomaton.restriction FVehicle_Station (ASet.GenActs [&"emrg",&"start",&"fstart"]) )
  (ASet.GenActs [&"reset"]).

Eval compute in :>FVehicle_Station_hid_l.
Eval compute in :>FVehicle_Station_res_l.
Eval compute in SIRGNNI_refinement FVehicle_Station_res_l FVehicle_Station_hid_l.

(* SME-NI at l: true *)
Definition FVehicle_Station_rep_l: IA :=
  IAutomaton.hiding
  ( IAutomaton.replacement FVehicle_Station (&"tau") (ASet.GenActs [&"emrg",&"start",&"fstart"]) )
  (ASet.GenActs [&"reset"]).

Eval compute in :>FVehicle_Station_rep_l.
Eval compute in SMENI_refinement FVehicle_Station_rep_l FVehicle_Station_hid_l.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(** *  Syntactic Lambda calculus *)

(** Lambda terms modulo alpha-equivalence (and its monadic
    structure given by the substitution). *)

Set Implicit Arguments.

Require Export Misc.

(** ** Notations *)

Reserved Notation "x == y" (at level 70, no associativity).
Reserved Notation "x == y :> X"
  (at level 70, y at next level, no associativity).

Reserved Notation "x //= f" (at level 42, left associativity).
Reserved Notation "x //- f" (at level 42, left associativity).

Implicit Type X Y Z : Set.

(** ** Inductive datatype of terms *)

Inductive term (X : Set) : Set :=
  | var : X -> term X
  | app : term X -> term X -> term X
  | abs : term (option X) -> term X.

Hint Extern 1 (_ = _ :> term _) => autorewrite with slc; simpl : slc.

Fixpoint fct X Y (f : X -> Y) (x : term X) { struct x } : term Y :=
  match x with
  | var a => var (f a)
  | app x y => app (x //- f) (y //- f)
  | abs x => abs (x //- optmap f)
  end
where "x //- f" := (@fct _ _ f x).

Lemma fct_fun_cong :
  forall X (x : term X) Y (f g : X -> Y),
  (forall u, f u = g u) -> x //- f = x //- g.
Proof.
induction x; simpl; auto.
intros. f_equal. apply IHx.
destruct u; simpl; auto.
Qed.

Lemma fct_fct :
  forall X Y Z (f : X -> Y) (g : Y -> Z) (x : term X) ,
  x //- f //- g = x //- (fun u => g (f u)).
Proof.
intros. generalize Y Z f g; clear Y Z f g.
induction x; simpl; intros; auto.
f_equal. rewrite IHx.
apply fct_fun_cong. destruct u; reflexivity.
Qed.
Hint Rewrite fct_fct : slc.

Lemma fct_id : forall X (f : X -> X) (x : term X),
  (forall u, f u = u) -> x //- f = x.
Proof.
induction x; intros; simpl; f_equal; auto.
apply IHx.
destruct u; simpl; auto.
Qed.

Definition shift X (x : term X) : term (option X) :=
  x //- @Some X.

Lemma shift_fct : forall X Y (f : X -> Y) (x : term X),
  shift (x //- f) = x //- fun a => Some (f a).
Proof.
unfold shift. intros. rewrite fct_fct. reflexivity.
Qed.

Lemma fct_shift : forall X Y (f : option X -> Y) (x : term X),
  shift x //- f = x //- fun a => f (Some a).
Proof.
unfold shift. intros. rewrite fct_fct. reflexivity.
Qed.

Hint Rewrite shift_fct fct_shift : slc.

Definition comm
  (X Y : Set) (f : X -> term Y) (x : option X) : term (option Y) :=
  match x with
  | Some a => shift (f a)
  | None => var None
  end.

Remark comm_var : forall X (u : option X), comm (@var X) u = var u.
Proof.
destruct u; reflexivity.
Qed.

Fixpoint slc_bind X Y (f : X -> term Y) (x : term X) { struct x } : term Y :=
  match x with
  | var x => f x
  | app x y => app (x //= f) (y //= f)
  | abs x => abs (x //= comm f)
  end
where "x //= f" := (@slc_bind _ _ f x).

Ltac slc :=
  intros;
  repeat first [ progress simpl fct
               | progress simpl slc_bind
               | progress autorewrite with slc ];
  auto with slc.

Lemma slc_bind_fun_cong : forall X (x : term X) Y (f g : X -> term Y),
  (forall u, f u = g u) -> x //= f = x //= g.
Proof.
induction x; simpl; intros; auto.
f_equal. apply IHx.
destruct u; simpl; auto.
Qed.

Lemma slc_bind_var : forall X Y (f : X -> term Y) (x : X),
  var x //=  f = f x.
Proof.
reflexivity.
Qed.

Lemma slc_var_bind_match : forall X (x : term X) (f : X -> term X),
  (forall u, f u = var u) -> x //= f = x.
Proof.
induction x; simpl; intros; auto.
f_equal. apply IHx.
destruct u; simpl. rewrite H. reflexivity. reflexivity.
Qed.
Hint Resolve slc_var_bind_match : slc.

Lemma slc_var_bind : forall X (x : term X),
  x //= @var X = x.
Proof.
intros. apply slc_var_bind_match. reflexivity.
Qed.

Lemma slc_fct_bind : forall X Y Z (f : X -> term Y) (g : Y -> Z) (x : term X),
  x //= f //- g = x //= fun u => f u //- g.
Proof.
intros. generalize Y Z f g; clear Y Z f g.
induction x; simpl; intros; f_equal; auto.
rewrite IHx.
apply slc_bind_fun_cong.
destruct u; slc.
Qed.
Hint Rewrite slc_fct_bind : slc.

Lemma slc_bind_fct : forall X Y Z (f : X -> Y) (g : Y -> term Z) (x : term X),
  x //- f //= g = x //= fun u => g (f u).
Proof.
intros; generalize Y Z f g; clear Y Z f g.
induction x; simpl; intros; f_equal; auto.
rewrite IHx.
apply slc_bind_fun_cong. clear x IHx.
destruct u; reflexivity.
Qed.
Hint Rewrite slc_bind_fct : slc.

Lemma slc_shift_bind : forall X Y (f : X -> term Y) (x : term X),
  shift (x //= f) = x //= fun a => shift (f a).
Proof.
unfold shift. intros.
rewrite slc_fct_bind. reflexivity.
Qed.

Lemma slc_bind_shift : forall X Y (f : option X -> term Y) (x : term X),
  shift x //= f = x //= fun a => f (Some a).
Proof.
unfold shift. intros.
rewrite slc_bind_fct. reflexivity.
Qed.

Hint Rewrite slc_shift_bind slc_bind_shift : slc.

Lemma slc_bind_bind : forall X Y Z
  (f : X -> term Y) (g : Y -> term Z) (x : term X),
  x //= f //= g = x //= fun u => f u //= g.
Proof.
intros. generalize Y Z f g; clear Y Z f g.
induction x; simpl; intros; f_equal; auto.
rewrite IHx.
apply slc_bind_fun_cong.
clear x IHx. destruct u; slc.
Qed.
Hint Rewrite slc_bind_bind : slc.

Lemma slc_fct_as_bind : forall X Y (f : X -> Y) (x : term X),
  x //- f = x //= (fun a => var (f a)).
Proof.
intros. generalize Y f; clear Y f.
induction x; simpl; intros; auto.
rewrite IHx; clear IHx.
f_equal. apply slc_bind_fun_cong.
destruct u; reflexivity.
Qed.

Definition app1 X (x : term X) : term (option X) :=
  app (shift x) (var None).

Lemma app1_app : forall X (x : term X),
  app1 x = app (shift x) (var None).
Proof.
reflexivity.
Qed.

Opaque app1.

Lemma fct_app1 : forall X Y (f : X -> Y) (x : term X),
  app1 x //- (optmap f) = app1 (x //- f).
Proof.
intros.
do 2 rewrite app1_app.
simpl. slc.
Qed.
Hint Rewrite fct_app1 : slc.

Lemma app_as_app1 : forall X (x y : term X),
  app x y = app1 x //= default (@var _) y.
Proof.
intros. rewrite app1_app. slc.
symmetry. slc.
Qed.

Lemma slc_bind_app1 : forall X Y (f : option X -> term Y) (x : term X),
  app1 x //= f = app (x //= fun u : X => f (Some u)) (f None).
Proof.
intros. rewrite app1_app. simpl. slc.
Qed.

Hint Rewrite slc_bind_app1 : slc.

Inductive Beta X : term X -> term X -> Prop :=
  | beta_intro : forall (x1 : term (option X)) (x2 : term X),
      Beta (app (abs x1) x2) (x1 //= (default (fun a => var a) x2)).

Lemma beta_intro_alt : forall X (x1 : term (option X)) (x2 y : term X),
  x1 //= (default (fun a => var a) x2) = y -> Beta (app (abs x1) x2) y.
Proof.
intros. subst y. apply beta_intro.
Qed.

Inductive lcr (X : Set) : term X -> term X -> Prop :=
  | lcr_var : forall a : X, var a == var a
  | lcr_app : forall x1 x2 y1 y2 : term X,
      x1 == x2 -> y1 == y2 -> app x1 y1 == app x2 y2
  | lcr_abs : forall x y : term (option X), x == y -> abs x == abs y
  | lcr_beta : forall x y : term X, Beta x y -> x == y
  | lcr_eta : forall x : term X, abs (app1 x) == x
  | lcr_sym : forall x y : term X, y == x -> x == y
  | lcr_trs : forall x y z : term X, lcr x y -> lcr y z -> lcr x z
where "x == y" := (@lcr _ x y).

Hint Resolve lcr_var lcr_app lcr_abs lcr_eta lcr_beta lcr_trs : slc.
Hint Immediate lcr_sym : slc.

Lemma lcr_rfl : forall X (x : term X), x == x.
Proof.
induction x; constructor; auto.
Qed.
Hint Resolve lcr_rfl : slc.

Lemma lcr_eq : forall X (x y : term X), x = y -> x == y.
Proof.
intros; subst y; slc.
Qed.
Hint Resolve lcr_eq : slc.

Lemma eta_fct : forall X Y (f : X -> Y) (x : term X),
  abs (app1 x) //- f = abs (app1 (x //- f)).
Proof.
induction x; simpl; slc.
Qed.

Lemma lcr_fct : forall X Y (f : X -> Y) (x y : term X),
  x == y -> x //- f == y //- f.
Proof.
intros. generalize Y f. clear Y f.
induction H; intros; try solve [simpl; slc].
2: eauto with slc.
destruct H.
simpl. slc.
apply lcr_beta. apply beta_intro_alt.
slc.
apply slc_bind_fun_cong.
destruct u; reflexivity.
Qed.

Hint Resolve lcr_fct : slc.

Lemma slc_eta_bind : forall X Y (f : X -> term Y) (x : term X),
  abs (app1 x) //= f = abs (app1 (x //= f)).
Proof.
intros. simpl. slc.
rewrite app1_app. slc.
Qed.

Lemma lcr_bind_arg : forall X Y (f : X -> term Y) (x y : term X),
  x == y -> x //= f == y //= f.
Proof.
intros. generalize Y f; clear Y f.
induction H; intros; try solve [simpl; slc].
3: eauto with slc.
2: rewrite slc_eta_bind; slc.
destruct H. simpl.
rewrite slc_bind_bind.
apply lcr_beta.
apply beta_intro_alt.
rewrite slc_bind_bind.
apply slc_bind_fun_cong.
destruct u; simpl; slc.
Qed.

Lemma lcr_bind_fun : forall X Y  (f g : X -> term Y) (x : term X),
  (forall u, f u == g u) -> x //= f == x //= g.
Proof.
intros. generalize Y f g H; clear Y f g H.
induction x; intros; simpl; slc.
apply lcr_abs.
apply IHx.
destruct u; simpl; unfold shift; slc.
Qed.

Lemma lcr_bind : forall X Y (f g : X -> term Y) (x y : term X),
  (forall u, f u == g u) -> x == y -> x //= f == y //= g.
Proof.
intros.
apply lcr_trs with (x //= g).
apply lcr_bind_fun; assumption.
apply lcr_bind_arg; assumption.
Qed.

Lemma lcr_app1 : forall X (x y : term X),
  x == y -> app1 x == app1 y.
Proof.
intros. do 2 rewrite app1_app. unfold shift. slc.
Qed.


(*
(C) Copyright 2010, COQTAIL team

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

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

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

Require Import NArith.
Require Import Omega.
Require Import Max.

Inductive eqmod (n:nat) : nat -> nat -> Prop :=
     | eqmod_base : forall k, k < n -> eqmod n k k
     | eqmod_nS : forall k l, eqmod n k l -> eqmod n k (n + l).

Lemma pred_itere : forall n, 0 < n -> forall m, {k:nat | m < n} + {k | m = n + k}.
Proof.
intros n n_pos m ; induction m.
 left ; exists 0 ; assumption.
 case (Compare_dec.le_lt_dec (S m) n) ; intro Hyp.
 case (Compare_dec.le_lt_eq_dec _ _ Hyp) ; clear Hyp ; intro Hyp.
 left ; exists 0 ; assumption.
 right ; exists 0 ; rewrite Hyp ; trivial.
 case IHm ; intro H.
 left ; exists 0 ; apply False_ind ; destruct H as (_,Hf) ; omega.
 destruct H as (k,Hk) ; right ; exists (S k).
 rewrite <- plus_n_Sm ; rewrite Hk ; simpl ; reflexivity.
Qed.

Lemma eqmod_bounded : forall n m l, eqmod n l m -> l < n.
Proof.
intros n m l eqmodnl ; induction eqmodnl ; assumption.
Qed.

Lemma eqmod_uniqueness1 : forall n m l, l < n -> eqmod n l m -> forall p, p < n ->
      p <> l -> ~eqmod n p m.
Proof.
intros n m l l_ub eqmodnl p p_ub p_neq Hf ;
 induction eqmodnl.
 inversion Hf ; intuition.
 apply IHeqmodnl.
 assumption.
 assumption.
 inversion Hf.
 assert (Temp := eqmod_bounded _ _ _ Hf).
 apply False_ind ; clear -H1 Temp ; intuition.
 assert (Temp := Plus.plus_reg_l _ _ _ H) ; rewrite <- Temp ; assumption.
Qed.

Lemma eqmod_uniqueness2 : forall n m l l', l < n -> l' < n -> eqmod n m l' -> eqmod n m l -> l = l'.
Proof.
intros n m l l' l_ub l'_ub eqmodnl eqmodnl' ; inversion eqmodnl'.
 inversion eqmodnl ; intuition.
 rewrite <- H1 in l_ub ; apply False_ind ; clear -l_ub ; intuition.
Qed.

Lemma eqmod_uniqueness : forall n m l l', eqmod n l m -> eqmod n l' m -> l = l'.
Proof.
intros n m l l' eqmodnl eqmodnl'.
 induction eqmodnl.
 induction eqmodnl'.
 reflexivity.
 apply False_ind ; intuition.
 apply IHeqmodnl ; inversion eqmodnl'.
 apply False_ind ; intuition.
 assert (Temp := Plus.plus_reg_l _ _ _ H) ;
 rewrite <- Temp ; assumption.
Qed.

Lemma disjoints_prelim : forall n, 0 < n -> forall M m, m < max n M ->
      {k | k < n /\ eqmod n k m /\ forall l, l <> k -> ~ eqmod n l m}.
Proof.
intros n n_pos M ; induction M ; intros m m_ub.
 rewrite max_l in m_ub ; [| intuition].
 exists m ; repeat split ; [assumption | |].
 constructor ; assumption.
 intros l l_neq Hyp ; apply l_neq ; apply eqmod_uniqueness with (n:=n) (m:=m).
 intuition.
 constructor ; assumption.
 case (Compare_dec.le_lt_dec m (max n M)) ; intro m_ub'.
 case (Compare_dec.le_lt_eq_dec _ _ m_ub') ; clear m_ub' ; intro m_ub'.
 apply IHM ; intuition.
 case (pred_itere _ n_pos m) ; intro Hyp.
  exists 0 ; apply False_ind ; destruct Hyp as (_,Hf).
  assert (Hf' : n <= m).
  apply Le.le_trans with (max n M) ; [apply Max.le_max_l | rewrite m_ub' ; intuition].
  intuition.
  destruct Hyp as (k,Hk).
  case (Compare_dec.le_lt_dec k n) ; intro Temp.
  case (Compare_dec.le_lt_eq_dec _ _ Temp) ; clear Temp ; intro Temp.
  exists k ; repeat split ; [assumption | |].
  rewrite Hk ; constructor ; constructor ; assumption.
  intros l l_neq eqmodnl ; assert (l_ub := eqmod_bounded _ _ _ eqmodnl) ;
  apply (eqmod_uniqueness1 _ _ _ l_ub eqmodnl _ Temp).
  intro Hf ; apply l_neq ; symmetry ; assumption.
  rewrite Hk ; constructor ; constructor ; assumption.
  exists 0 ; repeat split.
  assumption.
  rewrite Hk ; constructor.
  replace n with (n+0) in Temp by intuition ; rewrite Temp ; repeat constructor ; assumption.
  intros l l_neq eqmodnl ; rewrite Hk in eqmodnl.
  apply l_neq ; apply eqmod_uniqueness2 with (n:=n) (m:=l).
  apply (eqmod_bounded _ _ _ eqmodnl).
  assumption.
  inversion eqmodnl.
  apply False_ind ; intuition.
  assert (Temp2 := Plus.plus_reg_l _ _ _ H) ;
  replace n with (n+0) in Temp by intuition ; rewrite Temp2, Temp in H1.
  clear -H1 ; inversion H1.
  apply False_ind ; intuition.
  repeat (rewrite itere_S in H) ; assert (Temp2 := Plus.plus_reg_l _ _ _ H) ; rewrite <- Temp2 ;
  assumption.
  constructor.
  apply (eqmod_bounded _ _ _ eqmodnl).
  assert (k_ub : k < max n M).
  rewrite Hk in m_ub' ; intuition.
  destruct (IHM k k_ub) as (p, [p_ub [eqmodnp noteqmodnl]]) ; exists p ; repeat split.
  assumption.
  assert (H := eqmod_nS _ _ _ eqmodnp).
  rewrite Hk ; assumption.
  intros l l_neq_p eqmodnl.
  rewrite Hk in eqmodnl ; inversion eqmodnl.
  clear -H ; intuition.
  repeat (rewrite itere_S in H) ; assert (Temp2 := Plus.plus_reg_l _ _ _ H) ;
  replace n with (n+0) in Temp by intuition.
  rewrite Temp2 in H1.
  apply (noteqmodnl _ l_neq_p H1).
  exists 0 ; apply False_ind.
  assert (max n M = M).
  clear -m_ub m_ub' ; induction n.
  intuition.
  case (Max.max_dec (S n) M) ; intro H.
  rewrite H in m_ub'.
  case (Max.max_dec (S n) (S M)) ; intro H'.
  rewrite H' in m_ub ; apply False_ind ; intuition.
  assert (M < m).
  apply Lt.le_lt_trans with (max (S n) M).
  apply Max.le_max_r.
  rewrite H ; assumption.
  rewrite H' in m_ub.
  apply False_ind ; intuition.
  assumption.
  assert (m < max (S n) (S M)).
  apply Lt.lt_le_trans with (max n (S M)).
  assumption.
  generalize M ; clear ; induction n.
  intuition.
  intro M ; replace (max (S (S n)) (S M)) with (S (max (S n) M)) by intuition.
  replace (max (S n) (S M)) with (S (max n M)) by intuition.
  apply Le.le_n_S.
  destruct M.
  repeat (rewrite Max.max_comm ; simpl); intuition.
  apply IHn.
  simpl in H0.
  intuition.
Qed.

Lemma disjoints : forall n, 0 < n -> forall m,
      {k | k < n /\ eqmod n k m /\ forall l, l <> k -> ~ eqmod n l m}.
Proof.
intros n n_pos m ; apply disjoints_prelim with (M:= (S m)) ; intuition.
Qed.

Lemma surjectif : forall n m p, m < n -> eqmod n m (n * p + m).
Proof.
intros n m p m_ub ; induction p.
 replace (n * 0) with 0 by omega ; constructor ; assumption.
 replace ((n * S p) + m) with (n + ((n * p) + m)).
 constructor ; assumption.
 rewrite Mult.mult_succ_r ; omega.
Qed.

Lemma n_decomp : forall N n m p, 0 < n -> p < (S N) * n -> eqmod n m p -> {k | p = k * n + m}.
Proof.
intro N ; induction N ; intros n m p n_pos p_ub p_eqmodn.
 exists 0 ; inversion p_eqmodn.
 intuition.
 rewrite <- H1 in p_ub ; apply False_ind ; intuition.
 case (Compare_dec.le_lt_dec p ((S N) * n)) ; intro p_ub2.
 case (Compare_dec.le_lt_eq_dec _ _ p_ub2) ; intro H.
 apply (IHN _ _ _ n_pos H p_eqmodn).
  rewrite H in p_eqmodn.
  replace (S N * n) with (N * n + n) in p_eqmodn.
  destruct (IHN n m (N * n) n_pos) as (k, Hk).
  apply Mult.mult_lt_compat_r ; [constructor | apply n_pos].
  inversion p_eqmodn.
  apply False_ind.
  assert (N * n < 0).
  apply Plus.plus_lt_reg_l with n.
  intuition.
  apply (Lt.lt_n_O _ H3).
  replace l with (N * n) in H2.
  assumption.
  intuition.
  exists (S k) ; simpl ; rewrite <- Plus.plus_assoc ; rewrite <- Hk ; intuition.
  apply Plus.plus_comm.
  assert (Hrew : p = n + (p - n)).
  apply Minus.le_plus_minus.
  apply Le.le_trans with (S N * n) ; intuition.
  apply Le.le_trans with (S 0 * n) ; intuition ; apply Mult.mult_le_compat_r ;
  intuition.
  destruct (IHN n m (p-n) n_pos) as (k, Hk).
  apply Plus.plus_lt_reg_l with n.
  rewrite <- Hrew ; intuition.
  rewrite Plus.plus_comm in Hrew ; rewrite Hrew in p_eqmodn ; inversion p_eqmodn.
  apply False_ind ; apply Lt.lt_irrefl with n.
  apply Lt.lt_trans with (S N * n).
  intuition.
  apply Lt.lt_trans with p.
  assumption.
  rewrite Hrew ; assumption.
  assert (Hrew' : l = p - n) by intuition.
  rewrite Hrew' in H1 ; assumption.
  exists (S k) ; simpl ; rewrite <- Plus.plus_assoc ; rewrite <- Hk ; intuition.
Qed.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo79:
  prime  6568809752638910349004891->
  prime  14364231743055391865087823571184881.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      14364231743055391865087823571184881
      2186732800
      ((6568809752638910349004891,1)::nil)
      0
      99144
      18
      324)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section VotesLeCurrentTermInterface.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition votes_le_currentTerm net :=
    forall h t n,
      In (t, n) (votes (fst (nwState net h))) ->
      t <= currentTerm (snd (nwState net h)).

  Class votes_le_current_term_interface : Prop :=
    {
      votes_le_current_term_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          votes_le_currentTerm net
    }.
End VotesLeCurrentTermInterface.


From SyDPaCC.Tree Require Import
     Skeletons Closure BTree LTree.
From SyDPaCC.Bsml Require Import Model.Core Model.Pid Model.Sequential Skeletons.StdLib.
Require Import Lia NArith.
From SyDPaCC.Core Require Import Bmf Parallelization.

Open Scope sydpacc_scope.
Open Scope N_scope.

(** * Functions for the Application of map *)
Definition kL_c (A : Type) (predA: A -> bool): A -> N := fun x => if predA x then 1 else 0.
Definition kN_c (B : Type) (predB: B -> bool) : B -> N := fun x => if predB x then 1 else 0.

(** * Functions for the Application of reduce *)
Definition k_c: (N * N * N) -> N := fun t => match t with (a,b,c) => a + b + c end.
Definition phi_c : N -> N := fun x => x.
Definition psiN_c : (N * N * N) -> N := fun t => match t with (a,b,c) => a + b + c end.
Definition psiL_c : (N * N * N) -> N := fun t => match t with (a,b,c) => a + b + c end.
Definition psiR_c : (N * N * N) -> N := fun t => match t with (a,b,c) => a + b + c end.

#[local] Instance sum_closure : ClosureU k_c phi_c psiN_c psiL_c psiR_c.
Proof.
  constructor.
  split.
  + intros l b r. unfold k_c, psiN_c. unfold phi_c. reflexivity.
  + split.
    ++ intros x l y b r. unfold psiN_c, psiL_c.
       lia.
    ++ intros x l y b r. unfold psiN_c, psiR_c.
       lia.
Qed.

(** * The Sequential Application *)

Definition spec_candidates {A B} (predA: A -> bool)  (predB: B -> bool):
  BTree.t A B -> option N :=
  Some ∘ (BTree.reduce k_c) ∘ (BTree.map (kL_c A predA) (kN_c B predB)).

(** * The Parallel Application *)

Module Make (Import Bsml : SyDPaCC.Bsml.Model.Core.BSML).

  Module Pid := Pid.Make Bsml.Bsp.
  Module StdLib := StdLib.Make Bsml Pid.
  Module Import Skel := Tree.Skeletons.Make Bsml.

  Typeclasses eauto := (bfs).

  Definition candidates {A B} (predA: A->bool) (predB: B->bool) :
    Skel.PLTree A B -> option N :=
    Eval sydpacc in
    parallel(spec_candidates predA predB).

End Make.

Close Scope sydpacc_scope.
Close Scope N_scope.


Require Import VerdiRaft.Raft.

Section MaxIndexSanity.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition maxIndex_lastApplied net :=
    forall h,
      lastApplied (nwState net h) <= maxIndex (log (nwState net h)).

  Definition maxIndex_commitIndex net :=
    forall h,
      commitIndex (nwState net h) <= maxIndex (log (nwState net h)).

  Definition maxIndex_sanity net :=
    maxIndex_lastApplied net /\ maxIndex_commitIndex net.

  Class max_index_sanity_interface : Prop :=
    {
      max_index_sanity_invariant :
        forall net,
          raft_intermediate_reachable net ->
          maxIndex_sanity net
    }.
End MaxIndexSanity.


Require Import Platform.Sets.

Set Implicit Arguments.

Module Type KEY.
  Parameter key : Type.
  Parameter eq_dec : forall x y : key, {x = y} + {x <> y}.
End KEY.

Module Type DATA.
  Parameter data : Type.
End DATA.

Module Dict (MKey : KEY) (MData : DATA).

  Import MKey MData.

  Module SetKey : S with Definition A := key.
    Definition A := key.
    Definition eq_dec := eq_dec.
  End SetKey.
  Module MSet := Make SetKey.

  Definition map := key -> data.

  Definition dict := (MSet.set * map)%type.

  Definition upd_map (m : map) k v k' :=
    if eq_dec k' k then v else m k'.

  Definition keys (d : dict) := fst d.

  Definition mem (d : dict) (k : key) := fst d k.

  Definition sel (d : dict) (k : key) := snd d k.

  Definition upd (d : dict) k v := (MSet.add (fst d) k, upd_map (snd d) k v).

  Definition remove (d : dict) (k : key) := (MSet.del (fst d) k, snd d).

  Lemma sel_upd_eq : forall m k v k', k' = k ->  sel (upd m k v) k' = v.
    intros; unfold sel, upd, upd_map; simpl; destruct (eq_dec k' k); intuition.
  Qed.

  Lemma sel_upd_ne : forall m k v k', k' <> k -> sel (upd m k v) k' = sel m k'.
    intros; unfold sel, upd, upd_map; simpl; destruct (eq_dec k' k); intuition.
  Qed.

End Dict.


(* QuickChick Prelude *)
Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import String List. Open Scope string.

From QuickChick Require Import QuickChick Tactics.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
Import QcDefaultNotation. Open Scope qc_scope.

Set Bullet Behavior "Strict Subproofs".

(* End prelude *)

(* IMPORTS *)
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.lia.Lia.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import ListNotations.
Require Import Maps.
Require Import Imp.
(* /IMPORTS *)

Definition aequiv (a1 a2 : aexp) : Prop :=
  forall (st:state),
    aeval st a1 = aeval st a2.

Definition bequiv (b1 b2 : bexp) : Prop :=
  forall (st:state),
    beval st b1 = beval st b2.

Definition cequiv (c1 c2 : com) : Prop :=
  forall (st st' : state),
    (c1 / st \\ st') <-> (c2 / st \\ st').

Theorem skip_left: forall c,
  cequiv
     (SKIP;; c)
     c.
Proof.
  (* WORKED IN CLASS *)
  intros c st st'.
  split; intros H.
  - (* -> *)
    inversion H. subst.
    inversion H2. subst.
    assumption.
  - (* <- *)
    apply E_Seq with st.
    apply E_Skip.
    assumption.
Qed.

(** **** Exercise: 2 stars (skip_right)  *)
(** Prove that adding a [SKIP] after a command results in an
    equivalent program *)

Theorem skip_right: forall c,
  cequiv
    (c ;; SKIP)
    c.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Similarly, here is a simple transformation that optimizes [IFB]
    commands: *)

Theorem IFB_true_simple: forall c1 c2,
  cequiv
    (IFB BTrue THEN c1 ELSE c2 FI)
    c1.
Proof.
  intros c1 c2.
  split; intros H.
  - (* -> *)
    inversion H; subst. assumption. inversion H5.
  - (* <- *)
    apply E_IfTrue. reflexivity. assumption.  Qed.

(** Of course, few programmers would be tempted to write a conditional
    whose guard is literally [BTrue].  A more interesting case is when
    the guard is _equivalent_ to true: *)
(** _Theorem_: If [b] is equivalent to [BTrue], then [IFB b THEN c1
    ELSE c2 FI] is equivalent to [c1]. *)
(**
   _Proof_:

     - ([->]) We must show, for all [st] and [st'], that if [IFB b
       THEN c1 ELSE c2 FI / st \\ st'] then [c1 / st \\ st'].

       Proceed by cases on the rules that could possibly have been
       used to show [IFB b THEN c1 ELSE c2 FI / st \\ st'], namely
       [E_IfTrue] and [E_IfFalse].

       - Suppose the final rule rule in the derivation of [IFB b THEN
         c1 ELSE c2 FI / st \\ st'] was [E_IfTrue].  We then have, by
         the premises of [E_IfTrue], that [c1 / st \\ st'].  This is
         exactly what we set out to prove.

       - On the other hand, suppose the final rule in the derivation
         of [IFB b THEN c1 ELSE c2 FI / st \\ st'] was [E_IfFalse].
         We then know that [beval st b = false] and [c2 / st \\ st'].

         Recall that [b] is equivalent to [BTrue], i.e., forall [st],
         [beval st b = beval st BTrue].  In particular, this means
         that [beval st b = true], since [beval st BTrue = true].  But
         this is a contradiction, since [E_IfFalse] requires that
         [beval st b = false].  Thus, the final rule could not have
         been [E_IfFalse].

     - ([<-]) We must show, for all [st] and [st'], that if [c1 / st
       \\ st'] then [IFB b THEN c1 ELSE c2 FI / st \\ st'].

       Since [b] is equivalent to [BTrue], we know that [beval st b] =
       [beval st BTrue] = [true].  Together with the assumption that
       [c1 / st \\ st'], we can apply [E_IfTrue] to derive [IFB b THEN
       c1 ELSE c2 FI / st \\ st'].  []

   Here is the formal version of this proof: *)

Theorem IFB_true: forall b c1 c2,
     bequiv b BTrue  ->
     cequiv
       (IFB b THEN c1 ELSE c2 FI)
       c1.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  - (* -> *)
    inversion H; subst.
    + (* b evaluates to true *)
      assumption.
    + (* b evaluates to false (contradiction) *)
      unfold bequiv in Hb. simpl in Hb.
      rewrite Hb in H5.
      inversion H5.
  - (* <- *)
    apply E_IfTrue; try assumption.
    unfold bequiv in Hb. simpl in Hb.
    rewrite Hb. reflexivity.  Qed.

(** **** Exercise: 2 stars, recommended (IFB_false)  *)
Theorem IFB_false: forall b c1 c2,
  bequiv b BFalse  ->
  cequiv
    (IFB b THEN c1 ELSE c2 FI)
    c2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (swap_if_branches)  *)
(** Show that we can swap the branches of an IF if we also negate its
    guard. *)

Theorem swap_if_branches: forall b e1 e2,
  cequiv
    (IFB b THEN e1 ELSE e2 FI)
    (IFB BNot b THEN e2 ELSE e1 FI).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For [WHILE] loops, we can give a similar pair of theorems.  A loop
    whose guard is equivalent to [BFalse] is equivalent to [SKIP],
    while a loop whose guard is equivalent to [BTrue] is equivalent to
    [WHILE BTrue DO SKIP END] (or any other non-terminating program).
    The first of these facts is easy. *)

Theorem WHILE_false : forall b c,
  bequiv b BFalse ->
  cequiv
    (WHILE b DO c END)
    SKIP.
Proof.
  intros b c Hb. split; intros H.
  - (* -> *)
    inversion H; subst.
    + (* E_WhileEnd *)
      apply E_Skip.
    + (* E_WhileLoop *)
      rewrite Hb in H2. inversion H2.
  - (* <- *)
    inversion H; subst.
    apply E_WhileEnd.
    rewrite Hb.
    reflexivity.  Qed.

(** **** Exercise: 2 stars, advanced, optional (WHILE_false_informal)  *)
(** Write an informal proof of [WHILE_false].

(* FILL IN HERE *)
[]
*)

(** To prove the second fact, we need an auxiliary lemma stating that
    [WHILE] loops whose guards are equivalent to [BTrue] never
    terminate. *)

(** _Lemma_: If [b] is equivalent to [BTrue], then it cannot be the
    case that [(WHILE b DO c END) / st \\ st'].

    _Proof_: Suppose that [(WHILE b DO c END) / st \\ st'].  We show,
    by induction on a derivation of [(WHILE b DO c END) / st \\ st'],
    that this assumption leads to a contradiction.

      - Suppose [(WHILE b DO c END) / st \\ st'] is proved using rule
        [E_WhileEnd].  Then by assumption [beval st b = false].  But
        this contradicts the assumption that [b] is equivalent to
        [BTrue].

      - Suppose [(WHILE b DO c END) / st \\ st'] is proved using rule
        [E_WhileLoop].  Then we are given the induction hypothesis
        that [(WHILE b DO c END) / st \\ st'] is contradictory, which
        is exactly what we are trying to prove!

      - Since these are the only rules that could have been used to
        prove [(WHILE b DO c END) / st \\ st'], the other cases of
        the induction are immediately contradictory. [] *)

Lemma WHILE_true_nonterm : forall b c st st',
  bequiv b BTrue ->
  ~( (WHILE b DO c END) / st \\ st' ).
Proof.
  (* WORKED IN CLASS *)
  intros b c st st' Hb.
  intros H.
  remember (WHILE b DO c END) as cw eqn:Heqcw.
  induction H;
    (* Most rules don't apply, and we can rule them out
       by inversion *)
    inversion Heqcw; subst; clear Heqcw.
  (* The two interesting cases are the ones for WHILE loops: *)
  - (* E_WhileEnd *) (* contradictory -- b is always true! *)
    unfold bequiv in Hb.
    (* [rewrite] is able to instantiate the quantifier in [st] *)
    rewrite Hb in H. inversion H.
  - (* E_WhileLoop *) (* immediate from the IH *)
    apply IHceval2. reflexivity.  Qed.

(** **** Exercise: 2 stars, optional (WHILE_true_nonterm_informal)  *)
(** Explain what the lemma [WHILE_true_nonterm] means in English.

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

(** **** Exercise: 2 stars, recommended (WHILE_true)  *)
(** Prove the following theorem. _Hint_: You'll want to use
    [WHILE_true_nonterm] here. *)

Theorem WHILE_true: forall b c,
  bequiv b BTrue  ->
  cequiv
    (WHILE b DO c END)
    (WHILE BTrue DO SKIP END).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** A more interesting fact about [WHILE] commands is that any finite
    number of copies of the body can be "unrolled" without changing
    meaning.  Unrolling is a common transformation in real compilers. *)

Theorem loop_unrolling: forall b c,
  cequiv
    (WHILE b DO c END)
    (IFB b THEN (c ;; WHILE b DO c END) ELSE SKIP FI).
Proof.
  (* WORKED IN CLASS *)
  intros b c st st'.
  split; intros Hce.
  - (* -> *)
    inversion Hce; subst.
    + (* loop doesn't run *)
      apply E_IfFalse. assumption. apply E_Skip.
    + (* loop runs *)
      apply E_IfTrue. assumption.
      apply E_Seq with (st' := st'0). assumption. assumption.
  - (* <- *)
    inversion Hce; subst.
    + (* loop runs *)
      inversion H5; subst.
      apply E_WhileLoop with (st' := st'0).
      assumption. assumption. assumption.
    + (* loop doesn't run *)
      inversion H5; subst. apply E_WhileEnd. assumption.  Qed.

(** **** Exercise: 2 stars, optional (seq_assoc)  *)
Theorem seq_assoc : forall c1 c2 c3,
  cequiv ((c1;;c2);;c3) (c1;;(c2;;c3)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Proving program properties involving assignments is one place
    where the Functional Extensionality axiom often comes in handy. *)
(*
Theorem identity_assignment : forall (X:id),
  cequiv
    (X ::= AId X)
    SKIP.
Proof.
   intros. split; intro H.
     - (* -> *)
       inversion H; subst. simpl.
       replace (t_update st X (st X)) with st.
       + constructor.
       + apply functional_extensionality. intro.
         rewrite t_update_same; reflexivity.
     - (* <- *)
       replace st' with (t_update st' X (aeval st' (AId X))).
       + inversion H. subst. apply E_Ass. reflexivity.
       + apply functional_extensionality. intro.
         rewrite t_update_same. reflexivity.
Qed.
*)

(** **** Exercise: 2 stars, recommended (assign_aequiv)  *)
Theorem assign_aequiv : forall X e,
  aequiv (AId X) e ->
  cequiv SKIP (X ::= e).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (equiv_classes)  *)

(** Given the following programs, group together those that are
    equivalent in Imp. Your answer should be given as a list of lists,
    where each sub-list represents a group of equivalent programs. For
    example, if you think programs (a) through (h) are all equivalent
    to each other, but not to (i), your answer should look like this:

       [ [prog_a;prog_b;prog_c;prog_d;prog_e;prog_f;prog_g;prog_h] ;
         [prog_i] ]

    Write down your answer below in the definition of
    [equiv_classes]. *)

Definition prog_a : com :=
  WHILE BNot (BLe (AId X) (ANum 0)) DO
    X ::= APlus (AId X) (ANum 1)
  END.

Definition prog_b : com :=
  IFB BEq (AId X) (ANum 0) THEN
    X ::= APlus (AId X) (ANum 1);;
    Y ::= ANum 1
  ELSE
    Y ::= ANum 0
  FI;;
  X ::= AMinus (AId X) (AId Y);;
  Y ::= ANum 0.

Definition prog_c : com :=
  SKIP.

Definition prog_d : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    X ::= APlus (AMult (AId X) (AId Y)) (ANum 1)
  END.

Definition prog_e : com :=
  Y ::= ANum 0.

Definition prog_f : com :=
  Y ::= APlus (AId X) (ANum 1);;
  WHILE BNot (BEq (AId X) (AId Y)) DO
    Y ::= APlus (AId X) (ANum 1)
  END.

Definition prog_g : com :=
  WHILE BTrue DO
    SKIP
  END.

Definition prog_h : com :=
  WHILE BNot (BEq (AId X) (AId X)) DO
    X ::= APlus (AId X) (ANum 1)
  END.

Definition prog_i : com :=
  WHILE BNot (BEq (AId X) (AId Y)) DO
    X ::= APlus (AId Y) (ANum 1)
  END.

Definition equiv_classes : list (list com)
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
(** [] *)

(* ################################################################# *)
(** * Properties of Behavioral Equivalence *)

(** We next consider some fundamental properties of the program
    equivalence relations. *)

(* ================================================================= *)
(** ** Behavioral Equivalence Is an Equivalence *)

(** First, we verify that the equivalences on [aexps], [bexps], and
    [com]s really are _equivalences_ -- i.e., that they are reflexive,
    symmetric, and transitive.  The proofs are all easy. *)

Lemma refl_aequiv : forall (a : aexp), aequiv a a.
Proof.
  intros a st. reflexivity.  Qed.

Lemma sym_aequiv : forall (a1 a2 : aexp),
  aequiv a1 a2 -> aequiv a2 a1.
Proof.
  intros a1 a2 H. intros st. symmetry. apply H.  Qed.

Lemma trans_aequiv : forall (a1 a2 a3 : aexp),
  aequiv a1 a2 -> aequiv a2 a3 -> aequiv a1 a3.
Proof.
  unfold aequiv. intros a1 a2 a3 H12 H23 st.
  rewrite (H12 st). rewrite (H23 st). reflexivity.  Qed.

Lemma refl_bequiv : forall (b : bexp), bequiv b b.
Proof.
  unfold bequiv. intros b st. reflexivity.  Qed.

Lemma sym_bequiv : forall (b1 b2 : bexp),
  bequiv b1 b2 -> bequiv b2 b1.
Proof.
  unfold bequiv. intros b1 b2 H. intros st. symmetry. apply H.  Qed.

Lemma trans_bequiv : forall (b1 b2 b3 : bexp),
  bequiv b1 b2 -> bequiv b2 b3 -> bequiv b1 b3.
Proof.
  unfold bequiv. intros b1 b2 b3 H12 H23 st.
  rewrite (H12 st). rewrite (H23 st). reflexivity.  Qed.

Lemma refl_cequiv : forall (c : com), cequiv c c.
Proof.
  unfold cequiv. intros c st st'. apply iff_refl.  Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
  cequiv c1 c2 -> cequiv c2 c1.
Proof.
  unfold cequiv. intros c1 c2 H st st'.
  assert (c1 / st \\ st' <-> c2 / st \\ st') as H'.
  { (* Proof of assertion *) apply H. }
  apply iff_sym. assumption.
Qed.

Lemma iff_trans : forall (P1 P2 P3 : Prop),
  (P1 <-> P2) -> (P2 <-> P3) -> (P1 <-> P3).
Proof.
  intros P1 P2 P3 H12 H23.
  inversion H12. inversion H23.
  split; intros A.
    apply H1. apply H. apply A.
    apply H0. apply H2. apply A.  Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com),
  cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof.
  unfold cequiv. intros c1 c2 c3 H12 H23 st st'.
  apply iff_trans with (c2 / st \\ st'). apply H12. apply H23.  Qed.

(* ================================================================= *)
(** ** Behavioral Equivalence Is a Congruence *)

(** Less obviously, behavioral equivalence is also a _congruence_.
    That is, the equivalence of two subprograms implies the
    equivalence of the larger programs in which they are embedded:

              aequiv a1 a1'
      -----------------------------
      cequiv (i ::= a1) (i ::= a1')

              cequiv c1 c1'
              cequiv c2 c2'
         ------------------------
         cequiv (c1;;c2) (c1';;c2')

    ...and so on for the other forms of commands. *)

(** (Note that we are using the inference rule notation here not
    as part of a definition, but simply to write down some valid
    implications in a readable format. We prove these implications
    below.) *)

(** We will see a concrete example of why these congruence
    properties are important in the following section (in the proof of
    [fold_constants_com_sound]), but the main idea is that they allow
    us to replace a small part of a large program with an equivalent
    small part and know that the whole large programs are equivalent
    _without_ doing an explicit proof about the non-varying parts --
    i.e., the "proof burden" of a small change to a large program is
    proportional to the size of the change, not the program. *)

Theorem CAss_congruence : forall i a1 a1',
  aequiv a1 a1' ->
  cequiv (CAss i a1) (CAss i a1').
Admitted.

Theorem CWhile_congruence : forall b1 b1' c1 c1',
  bequiv b1 b1' -> cequiv c1 c1' ->
  cequiv (WHILE b1 DO c1 END) (WHILE b1' DO c1' END).
Proof.
  (* WORKED IN CLASS *)
  unfold bequiv,cequiv.
  intros b1 b1' c1 c1' Hb1e Hc1e st st'.
  split; intros Hce.
  - (* -> *)
    remember (WHILE b1 DO c1 END) as cwhile
      eqn:Heqcwhile.
    induction Hce; inversion Heqcwhile; subst.
    + (* E_WhileEnd *)
      apply E_WhileEnd. rewrite <- Hb1e. apply H.
    + (* E_WhileLoop *)
      apply E_WhileLoop with (st' := st').
      * (* show loop runs *) rewrite <- Hb1e. apply H.
      * (* body execution *)
        apply (Hc1e st st').  apply Hce1.
      * (* subsequent loop execution *)
        apply IHHce2. reflexivity.
  - (* <- *)
    remember (WHILE b1' DO c1' END) as c'while
      eqn:Heqc'while.
    induction Hce; inversion Heqc'while; subst.
    + (* E_WhileEnd *)
      apply E_WhileEnd. rewrite -> Hb1e. apply H.
    + (* E_WhileLoop *)
      apply E_WhileLoop with (st' := st').
      * (* show loop runs *) rewrite -> Hb1e. apply H.
      * (* body execution *)
        apply (Hc1e st st').  apply Hce1.
      * (* subsequent loop execution *)
        apply IHHce2. reflexivity.  Qed.

(** **** Exercise: 3 stars, optional (CSeq_congruence)  *)
Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;;c2) (c1';;c2').
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (CIf_congruence)  *)
Theorem CIf_congruence : forall b b' c1 c1' c2 c2',
  bequiv b b' -> cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (IFB b THEN c1 ELSE c2 FI)
         (IFB b' THEN c1' ELSE c2' FI).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For example, here are two equivalent programs and a proof of their
    equivalence... *)

Example congruence_example:
  cequiv
    (* Program 1: *)
    (X ::= ANum 0;;
     IFB (BEq (AId X) (ANum 0))
     THEN
       Y ::= ANum 0
     ELSE
       Y ::= ANum 42
     FI)
    (* Program 2: *)
    (X ::= ANum 0;;
     IFB (BEq (AId X) (ANum 0))
     THEN
       Y ::= AMinus (AId X) (AId X)   (* <--- changed here *)
     ELSE
       Y ::= ANum 42
     FI).
Proof.
  apply CSeq_congruence.
    apply refl_cequiv.
    apply CIf_congruence.
      apply refl_bequiv.
      apply CAss_congruence. unfold aequiv. simpl.
        symmetry. apply minus_diag.
      apply refl_cequiv.
Qed.

(** **** Exercise: 3 stars, advanced, optional (not_congr)  *)
(** We've shown that the [cequiv] relation is both an equivalence and
    a congruence on commands.  Can you think of a relation on commands
    that is an equivalence but _not_ a congruence? *)

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

(* ################################################################# *)
(** * Program Transformations *)

(** A _program transformation_ is a function that takes a program as
    input and produces some variant of the program as output.
    Compiler optimizations such as constant folding are a canonical
    example, but there are many others. *)

(** A program transformation is _sound_ if it preserves the
    behavior of the original program. *)

Definition atrans_sound (atrans : aexp -> aexp) : Prop :=
  forall (a : aexp),
    aequiv a (atrans a).

Definition btrans_sound (btrans : bexp -> bexp) : Prop :=
  forall (b : bexp),
    bequiv b (btrans b).

Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall (c : com),
    cequiv c (ctrans c).

(* ================================================================= *)
(** ** The Constant-Folding Transformation *)

(** An expression is _constant_ when it contains no variable
    references.

    Constant folding is an optimization that finds constant
    expressions and replaces them by their values. *)

Fixpoint fold_constants_aexp (a : aexp) : aexp :=
  match a with
  | ANum n       => ANum n
  | AId i        => AId i
  | APlus a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 + n2)
    | (a1', a2') => APlus a1' a2'
    end
  | AMinus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 - n2)
    | (a1', a2') => AMinus a1' a2'
    end
  | AMult a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 * n2)
    | (a1', a2') => AMult a1' a2'
    end
  end.

Example fold_aexp_ex1 :
    fold_constants_aexp
      (AMult (APlus (ANum 1) (ANum 2)) (AId X))
  = AMult (ANum 3) (AId X).
Proof. reflexivity. Qed.

(** Note that this version of constant folding doesn't eliminate
    trivial additions, etc. -- we are focusing attention on a single
    optimization for the sake of simplicity.  It is not hard to
    incorporate other ways of simplifying expressions; the definitions
    and proofs just get longer. *)

Example fold_aexp_ex2 :
    fold_constants_aexp
      (AMinus (AId X) (APlus (AMult (ANum 0) (ANum 6))
                             (AId Y)))
  = AMinus (AId X) (APlus (ANum 0) (AId Y)).
Proof. reflexivity. Qed.

(** Not only can we lift [fold_constants_aexp] to [bexp]s (in the
    [BEq] and [BLe] cases); we can also look for constant _boolean_
    expressions and evaluate them in-place. *)

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | BTrue        => BTrue
  | BFalse       => BFalse
  | BEq a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if beq_nat n1 n2 then BTrue else BFalse
      | (a1', a2') =>
          BEq a1' a2'
      end
  | BLe a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if leb n1 n2 then BTrue else BFalse
      | (a1', a2') =>
          BLe a1' a2'
      end
  | BNot b1  =>
      match (fold_constants_bexp b1) with
      | BTrue => BFalse
      | BFalse => BTrue
      | b1' => BNot b1'
      end
  | BAnd b1 b2  =>
      match (fold_constants_bexp b1, fold_constants_bexp b2) with
      | (BTrue, BTrue) => BTrue
      | (BTrue, BFalse) => BFalse
      | (BFalse, BTrue) => BFalse
      | (BFalse, BFalse) => BFalse
      | (b1', b2') => BAnd b1' b2'
      end
  end.

Example fold_bexp_ex1 :
    fold_constants_bexp (BAnd BTrue (BNot (BAnd BFalse BTrue)))
  = BTrue.
Proof. reflexivity. Qed.

Example fold_bexp_ex2 :
    fold_constants_bexp
      (BAnd (BEq (AId X) (AId Y))
            (BEq (ANum 0)
                 (AMinus (ANum 2) (APlus (ANum 1)
                                         (ANum 1)))))
  = BAnd (BEq (AId X) (AId Y)) BTrue.
Proof. reflexivity. Qed.

(** To fold constants in a command, we apply the appropriate folding
    functions on all embedded expressions. *)

Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | SKIP      =>
      SKIP
  | i ::= a  =>
      CAss i (fold_constants_aexp a)
  | c1 ;; c2  =>
      (fold_constants_com c1) ;; (fold_constants_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      match fold_constants_bexp b with
      | BTrue => fold_constants_com c1
      | BFalse => fold_constants_com c2
      | b' => IFB b' THEN fold_constants_com c1
                     ELSE fold_constants_com c2 FI
      end
  | WHILE b DO c END =>
      match fold_constants_bexp b with
      | BTrue => WHILE BTrue DO SKIP END
      | BFalse => SKIP
      | b' => WHILE b' DO (fold_constants_com c) END
      end
  end.

Example fold_com_ex1 :
  fold_constants_com
    (* Original program: *)
    (X ::= APlus (ANum 4) (ANum 5);;
     Y ::= AMinus (AId X) (ANum 3);;
     IFB BEq (AMinus (AId X) (AId Y))
             (APlus (ANum 2) (ANum 4)) THEN
       SKIP
     ELSE
       Y ::= ANum 0
     FI;;
     IFB BLe (ANum 0)
             (AMinus (ANum 4) (APlus (ANum 2) (ANum 1)))
     THEN
       Y ::= ANum 0
     ELSE
       SKIP
     FI;;
     WHILE BEq (AId Y) (ANum 0) DO
       X ::= APlus (AId X) (ANum 1)
     END)
  = (* After constant folding: *)
    (X ::= ANum 9;;
     Y ::= AMinus (AId X) (ANum 3);;
     IFB BEq (AMinus (AId X) (AId Y)) (ANum 6) THEN
       SKIP
     ELSE
       (Y ::= ANum 0)
     FI;;
     Y ::= ANum 0;;
     WHILE BEq (AId Y) (ANum 0) DO
       X ::= APlus (AId X) (ANum 1)
     END).
Proof. reflexivity. Qed.

(* ================================================================= *)
(** ** Soundness of Constant Folding *)

(** Now we need to show that what we've done is correct. *)

(** Here's the proof for arithmetic expressions: *)

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  unfold atrans_sound. intros a. unfold aequiv. intros st.
  induction a; simpl;
    (* ANum and AId follow immediately *)
    try reflexivity;
    (* APlus, AMinus, and AMult follow from the IH
       and the observation that
              aeval st (APlus a1 a2)
            = ANum ((aeval st a1) + (aeval st a2))
            = aeval st (ANum ((aeval st a1) + (aeval st a2)))
       (and similarly for AMinus/minus and AMult/mult) *)
    try (destruct (fold_constants_aexp a1);
         destruct (fold_constants_aexp a2);
         rewrite IHa1; rewrite IHa2; reflexivity). Qed.

(** **** Exercise: 3 stars, optional (fold_bexp_Eq_informal)  *)
(** Here is an informal proof of the [BEq] case of the soundness
    argument for boolean expression constant folding.  Read it
    carefully and compare it to the formal proof that follows.  Then
    fill in the [BLe] case of the formal proof (without looking at the
    [BEq] case, if possible).

   _Theorem_: The constant folding function for booleans,
   [fold_constants_bexp], is sound.

   _Proof_: We must show that [b] is equivalent to [fold_constants_bexp],
   for all boolean expressions [b].  Proceed by induction on [b].  We
   show just the case where [b] has the form [BEq a1 a2].

   In this case, we must show

       beval st (BEq a1 a2)
     = beval st (fold_constants_bexp (BEq a1 a2)).

   There are two cases to consider:

     - First, suppose [fold_constants_aexp a1 = ANum n1] and
       [fold_constants_aexp a2 = ANum n2] for some [n1] and [n2].

       In this case, we have

           fold_constants_bexp (BEq a1 a2)
         = if beq_nat n1 n2 then BTrue else BFalse

       and

           beval st (BEq a1 a2)
         = beq_nat (aeval st a1) (aeval st a2).

       By the soundness of constant folding for arithmetic
       expressions (Lemma [fold_constants_aexp_sound]), we know

           aeval st a1
         = aeval st (fold_constants_aexp a1)
         = aeval st (ANum n1)
         = n1

       and

           aeval st a2
         = aeval st (fold_constants_aexp a2)
         = aeval st (ANum n2)
         = n2,

       so

           beval st (BEq a1 a2)
         = beq_nat (aeval a1) (aeval a2)
         = beq_nat n1 n2.

       Also, it is easy to see (by considering the cases [n1 = n2] and
       [n1 <> n2] separately) that

           beval st (if beq_nat n1 n2 then BTrue else BFalse)
         = if beq_nat n1 n2 then beval st BTrue else beval st BFalse
         = if beq_nat n1 n2 then true else false
         = beq_nat n1 n2.

       So

           beval st (BEq a1 a2)
         = beq_nat n1 n2.
         = beval st (if beq_nat n1 n2 then BTrue else BFalse),

       as required.

     - Otherwise, one of [fold_constants_aexp a1] and
       [fold_constants_aexp a2] is not a constant.  In this case, we
       must show

           beval st (BEq a1 a2)
         = beval st (BEq (fold_constants_aexp a1)
                         (fold_constants_aexp a2)),

       which, by the definition of [beval], is the same as showing

           beq_nat (aeval st a1) (aeval st a2)
         = beq_nat (aeval st (fold_constants_aexp a1))
                   (aeval st (fold_constants_aexp a2)).

       But the soundness of constant folding for arithmetic
       expressions ([fold_constants_aexp_sound]) gives us

         aeval st a1 = aeval st (fold_constants_aexp a1)
         aeval st a2 = aeval st (fold_constants_aexp a2),

       completing the case.  []
*)

Theorem fold_constants_bexp_sound:
  btrans_sound fold_constants_bexp.
Proof.
  unfold btrans_sound. intros b. unfold bequiv. intros st.
  induction b;
    (* BTrue and BFalse are immediate *)
    try reflexivity.
  - (* BEq *)
    rename a into a1. rename a0 into a2. simpl.

(** (Doing induction when there are a lot of constructors makes
    specifying variable names a chore, but Coq doesn't always
    choose nice variable names.  We can rename entries in the
    context with the [rename] tactic: [rename a into a1] will
    change [a] to [a1] in the current goal and context.) *)

    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1') by
       (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
       (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; try reflexivity.

    (* The only interesting case is when both a1 and a2
       become constants after folding *)
      simpl. destruct (beq_nat n n0); reflexivity.
  - (* BLe *)
    (* FILL IN HERE *) admit.
  - (* BNot *)
    simpl. remember (fold_constants_bexp b) as b' eqn:Heqb'.
    rewrite IHb.
    destruct b'; reflexivity.
  - (* BAnd *)
    simpl.
    remember (fold_constants_bexp b1) as b1' eqn:Heqb1'.
    remember (fold_constants_bexp b2) as b2' eqn:Heqb2'.
    rewrite IHb1. rewrite IHb2.
    destruct b1'; destruct b2'; reflexivity.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (fold_constants_com_sound)  *)
(** Complete the [WHILE] case of the following proof. *)

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound. intros c.
  induction c; simpl.
  - (* SKIP *) apply refl_cequiv.
  - (* ::= *) apply CAss_congruence.
              apply fold_constants_aexp_sound.
  - (* ;; *) apply CSeq_congruence; assumption.
  - (* IFB *)
    assert (bequiv b (fold_constants_bexp b)). {
      apply fold_constants_bexp_sound. }
    destruct (fold_constants_bexp b) eqn:Heqb;
      try (apply CIf_congruence; assumption).
      (* (If the optimization doesn't eliminate the if, then the
          result is easy to prove from the IH and
          [fold_constants_bexp_sound].) *)
    + (* b always true *)
      apply trans_cequiv with c1; try assumption.
      apply IFB_true; assumption.
    + (* b always false *)
      apply trans_cequiv with c2; try assumption.
      apply IFB_false; assumption.
  - (* WHILE *)
    (* FILL IN HERE *) Admitted.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Soundness of (0 + n) Elimination, Redux *)

(** **** Exercise: 4 stars, advanced, optional (optimize_0plus)  *)
(** Recall the definition [optimize_0plus] from the [Imp] chapter:

    Fixpoint optimize_0plus (e:aexp) : aexp :=
      match e with
      | ANum n =>
          ANum n
      | APlus (ANum 0) e2 =>
          optimize_0plus e2
      | APlus e1 e2 =>
          APlus (optimize_0plus e1) (optimize_0plus e2)
      | AMinus e1 e2 =>
          AMinus (optimize_0plus e1) (optimize_0plus e2)
      | AMult e1 e2 =>
          AMult (optimize_0plus e1) (optimize_0plus e2)
      end.

   Note that this function is defined over the old [aexp]s,
   without states.

   Write a new version of this function that accounts for variables,
   plus analogous ones for [bexp]s and commands:

     optimize_0plus_aexp
     optimize_0plus_bexp
     optimize_0plus_com

   Prove that these three functions are sound, as we did for
   [fold_constants_*].  Make sure you use the congruence lemmas in
   the proof of [optimize_0plus_com] -- otherwise it will be _long_!

   Then define an optimizer on commands that first folds
   constants (using [fold_constants_com]) and then eliminates [0 + n]
   terms (using [optimize_0plus_com]).

   - Give a meaningful example of this optimizer's output.

   - Prove that the optimizer is sound.  (This part should be _very_
     easy.)  *)

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

(* ################################################################# *)
(** * Proving That Programs Are _Not_ Equivalent *)

(** Suppose that [c1] is a command of the form [X ::= a1;; Y ::= a2]
    and [c2] is the command [X ::= a1;; Y ::= a2'], where [a2'] is
    formed by substituting [a1] for all occurrences of [X] in [a2].
    For example, [c1] and [c2] might be:

       c1  =  (X ::= 42 + 53;;
               Y ::= Y + X)
       c2  =  (X ::= 42 + 53;;
               Y ::= Y + (42 + 53))

    Clearly, this _particular_ [c1] and [c2] are equivalent.  Is this
    true in general? *)

(** We will see in a moment that it is not, but it is worthwhile
    to pause, now, and see if you can find a counter-example on your
    own. *)

(** More formally, here is the function that substitutes an arithmetic
    expression for each occurrence of a given variable in another
    expression: *)

Fixpoint subst_aexp (i : id) (u : aexp) (a : aexp) : aexp :=
  match a with
  | ANum n       =>
      ANum n
  | AId i'       =>
      if beq_id i i' then u else AId i'
  | APlus a1 a2  =>
      APlus (subst_aexp i u a1) (subst_aexp i u a2)
  | AMinus a1 a2 =>
      AMinus (subst_aexp i u a1) (subst_aexp i u a2)
  | AMult a1 a2  =>
      AMult (subst_aexp i u a1) (subst_aexp i u a2)
  end.

Example subst_aexp_ex :
  subst_aexp X (APlus (ANum 42) (ANum 53))
             (APlus (AId Y) (AId X))
= (APlus (AId Y) (APlus (ANum 42) (ANum 53))).
Proof. reflexivity.  Qed.

(** And here is the property we are interested in, expressing the
    claim that commands [c1] and [c2] as described above are
    always equivalent.  *)

Definition subst_equiv_property := forall i1 i2 a1 a2,
  cequiv (i1 ::= a1;; i2 ::= a2)
         (i1 ::= a1;; i2 ::= subst_aexp i1 a1 a2).

(** Sadly, the property does _not_ always hold -- i.e., it is not the
    case that, for all [i1], [i2], [a1], and [a2],

      cequiv (i1 ::= a1;; i2 ::= a2)
             (i1 ::= a1;; i2 ::= subst_aexp i1 a1 a2).

    To see this, suppose (for a contradiction) that for all [i1], [i2],
    [a1], and [a2], we have

      cequiv (i1 ::= a1;; i2 ::= a2)
             (i1 ::= a1;; i2 ::= subst_aexp i1 a1 a2).

    Consider the following program:

       X ::= APlus (AId X) (ANum 1);; Y ::= AId X

    Note that

       (X ::= APlus (AId X) (ANum 1);; Y ::= AId X)
       / empty_state \\ st1,

    where [st1 = { X |-> 1, Y |-> 1 }].

    By assumption, we know that

      cequiv (X ::= APlus (AId X) (ANum 1);;
              Y ::= AId X)
             (X ::= APlus (AId X) (ANum 1);;
              Y ::= APlus (AId X) (ANum 1))

    so, by the definition of [cequiv], we have

      (X ::= APlus (AId X) (ANum 1);; Y ::= APlus (AId X) (ANum 1))
      / empty_state \\ st1.

    But we can also derive

      (X ::= APlus (AId X) (ANum 1);; Y ::= APlus (AId X) (ANum 1))
      / empty_state \\ st2,

    where [st2 = { X |-> 1, Y |-> 2 }].  But [st1 <> st2], which is a
    contradiction, since [ceval] is deterministic!  [] *)

Theorem subst_inequiv :
  ~ subst_equiv_property.
Admitted.

Inductive var_not_used_in_aexp : id -> aexp -> Prop :=
  | VNUNum: forall X n, var_not_used_in_aexp X (ANum n)
  | VNUId: forall X Y, X <> Y -> var_not_used_in_aexp X (AId Y)
  | VNUPlus: forall X a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (APlus a1 a2)
  | VNUMinus: forall X a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (AMinus a1 a2)
  | VNUMult: forall X a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (AMult a1 a2).

(* Leo: TODO
Lemma aeval_weakening : forall i st a ni,
  var_not_used_in_aexp i a ->
  aeval (t_update st i ni) a = aeval st a.
*)