 (*****************************************************************************************)
(*****************************************************************************************)
(*This file gives the SN proof after embedding the theory*)
(*There are two main steps to prove SN :*)
(*1. Soundness of the first order theory*)
(*2. New proof of the conversion rule*)
(*To prove 2, just need to prove eq_fotrm can be embedded in eq_typ*)
(*****************************************************************************************)
(*****************************************************************************************)

Require Import AbsTheoryIntp.

Import AbsTheorySyn AbsTheorySem.
Import Esub GenLemmas.
Import SN_CC_Real.
Import ZF SN CCSN.

(*SN for the abstract theory*)
Module Abs_SN_Theory (Msyn : TheorySyn) (Msem : TheorySem) (Mintp : TheoryIntp Msyn Msem).

Import Msyn Msem Mintp.
Import MAI MSI.

Lemma intp_sound : forall hyp P, deriv hyp P ->
  exists p, typ ((intp_hyp hyp)) p (intp_fofml P).
induction 1; simpl.
(*hyp*)
 exists (Ref n); red; simpl; intros. unfold val_ok in H1.
 rewrite <- lift_intp_lift_fml. apply H1. apply intp_hyp_nth_fml; trivial.

(*ax_intro*)
 apply intp_ax; trivial.

(*true_intro*)
 apply True_symb_intro.

(*false_elim*)
 destruct IHderiv. exists (App x (intp_fofml f)).
 apply False_symb_elim; [|apply intp_fofml_prop]; trivial.

(*neg_intro*)
 destruct IHderiv as (p, IH). exists p.
 apply Neg_intro; trivial.

(*neg_elim*)
 destruct IHderiv. exists x.
 apply Neg_elim; trivial.

(*conj_intro*)
 destruct IHderiv1 as (x, IH1).
 destruct IHderiv2 as (x', IH2).
 apply Conj_intro with (u:=x) (v:=x'); [apply intp_fofml_prop; apply deriv_well_typed
   |apply intp_fofml_prop; apply deriv_well_typed|split]; trivial.

(*conj_elim1*)
 destruct IHderiv as (t, IH). apply deriv_well_typed in H. simpl in IH.
 apply Conj_elim1 with (B:=(intp_fofml f2)) (t:=t);
   [apply intp_fofml_prop|apply intp_fofml_prop|trivial];
   unfold wf_fml, fv_fml in H |- *; simpl in H |- *; intros; apply H;
     rewrite in_app_iff; [left|right]; trivial.

(*conj_elim2*)
 destruct IHderiv as (t, IH). apply deriv_well_typed in H.
 apply Conj_elim2 with (A:=(intp_fofml f1)) (t:=t);
   [apply intp_fofml_prop|apply intp_fofml_prop|trivial];
   unfold wf_fml, fv_fml in H |- *; simpl in H; intros; apply H;
     rewrite in_app_iff; [left|right]; trivial.

(*disj_intro1*)
 destruct IHderiv.
 apply Disj_intro1 with (t:=x); [apply intp_fofml_prop; apply deriv_well_typed
   |apply intp_fofml_prop|]; trivial.

(*disj_intro2*)
 destruct IHderiv.
 apply Disj_intro2 with (t:=x); [apply intp_fofml_prop
   |apply intp_fofml_prop; apply deriv_well_typed|]; trivial.

(*disj_elim*)
 destruct IHderiv1, IHderiv2, IHderiv3. simpl in H3, H4.
 apply deriv_well_typed in H. apply deriv_well_typed in H0.
 apply wf_weakening in H0.
 apply Disj_elim with (t:=x) (t1:=x0) (t2:=x1) (A:=intp_fofml f1) (B:=intp_fofml f2);
   [apply intp_fofml_prop|apply intp_fofml_prop|apply intp_fofml_prop
     | |rewrite lift_intp_lift_fml|rewrite lift_intp_lift_fml]; trivial;
   unfold wf_fml, fv_fml in H |- *; intros; apply H; simpl;
     rewrite in_app_iff; [left|right]; trivial.

(*impl_intro*)
 destruct IHderiv as (p, IH). simpl in IH.
 rewrite <- lift_intp_lift_fml in IH.
 exists (Abs (intp_fofml f1) p).
 apply Impl_intro; [apply intp_fofml_prop|destruct f2; simpl; discriminate|]; trivial.

(*impl_elim*)
 destruct IHderiv1, IHderiv2. exists (App x x0).
 apply Impl_elim with (A:=intp_fofml f1); trivial; [destruct f1 | destruct f2];
   simpl; discriminate.

(*fall_intro*)
 destruct IHderiv. simpl in H0. exists ((Abs sort x)).
 apply Fall_intro; trivial.
  replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)); trivial.
  apply intp_fofml_prop. apply deriv_well_typed; trivial.

(*fall_elim*)
 destruct IHderiv. exists (App x (intp_fotrm u)).
 rewrite <- subst_intp_subst_fml.
 apply Fall_elim; [| |apply intp_fotrm_sort]; trivial.
  replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)); trivial.
  apply intp_fofml_prop. apply deriv_well_typed in H0.
  unfold wf_fml, fv_fml in H0 |- *; intros.
  destruct n; simpl; trivial.
   apply H0. apply in_S_fv_fml; trivial.

(*exst_intro*)
 destruct IHderiv. apply intp_fotrm_sort in H.
 rewrite <- subst_intp_subst_fml in H1.
 apply Exst_intro with (a:=(intp_fotrm N)) (p:=x); trivial.
  replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)); trivial.
  apply intp_fofml_prop. apply deriv_well_typed in H0.
  unfold wf_fml, fv_fml in H0 |- *; intros.
  destruct n; simpl; trivial.
   apply H0. unfold fv_fml, subst_fml in H2 |- *.
   apply (in_fv_fml_subst _ n N 0 0); trivial.

(*exst_elim*)
 destruct IHderiv1, IHderiv2.
 rewrite <- lift_intp_lift_fml in H2. simpl in H2.
 unfold lift_fml in H0; rewrite lift_fml_split in H0.
 fold (lift_fml f1 1) in H0. fold (lift_fml (lift_fml f1 1) 1) in H0.
 apply deriv_well_typed in H0.
 do 2 apply wf_weakening in H0.
 apply Exst_elim with (t1:=x) (t2:=x0) (A:=intp_fofml f); trivial;
   [replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)) by trivial|];
   apply intp_fofml_prop; trivial.
  apply deriv_well_typed in H. unfold wf_fml, fv_fml in H |- *; intros.
  destruct n; simpl; trivial.
   apply H; apply in_S_fv_fml; trivial.
Qed.

Lemma SN_T : forall e x y,
  (exists hyp a b es,
    x = app_esub es (intp_fotrm a) /\
    y = app_esub es (intp_fotrm b) /\
    wf_clsd_env (intp_hyp hyp) /\
    typ_esub e es (intp_hyp hyp) /\
    deriv hyp (eq_fotrm a b)) ->
  eq_typ e x y.
intros e x y Hyp.
destruct Hyp as (hyp, (a, (b, (es, (Hx, (Hy, (Hclsd, (He, Hderiv)))))))).
(*a and b are well typed in theory syntax*)
specialize deriv_well_typed with (1:=Hderiv); intro Hwf.
assert (wf_trm hyp a /\ wf_trm hyp b) as Hwfab.
 unfold wf_fml, fv_fml in Hwf; simpl in Hwf.
 unfold wf_trm; split; intros; apply Hwf; rewrite in_app_iff; [left|right]; trivial.

destruct Hwfab as (Hwfa, Hwfb); clear Hwf.
(*Therefore they have type sort in semantic*)
apply intp_fotrm_sort in Hwfa.
apply intp_fotrm_sort in Hwfb.

(*EQ_trm (intp_trm a) (intp_trm b) can be proved*)
specialize intp_sound with (1:=Hderiv); clear Hderiv; intro HEQ.
destruct HEQ as (p, HEQ); simpl in HEQ.

(*EQ_trm can be embedded in eq_typ*)
apply EQ_trm_elim in HEQ; [|exact Hclsd|exact Hwfa|exact Hwfb].

(*eq_typ relation maintains after variable recocation*)
subst x y.
apply explicit_sub_eq_typ with (3:=He);
  [apply intp_fotrm_not_kind|apply intp_fotrm_not_kind|exact HEQ].
Qed.

End Abs_SN_Theory.


(*
    Properties of to_N and to_C.
    Ideally we wnat (to_N (to_C G)) = G, but that is not the case;
    the actual theorems are slightly different (G_subset_toN_toC_G and toN_toC_G_subset_G).
*)
From mathcomp Require Import all_ssreflect.
Require Import Coq.Strings.String Coq.Bool.Bool Coq.Lists.List.
Import ListNotations.
From Coq.Arith Require Import Arith EqNat.
Open Scope string_scope.
Open Scope list_scope.
From Taxiway Require Import To_complete To_naive Types.
From Hammer Require Import Hammer.
Set Hammer ReconstrLimit 20.

Require Import Coq.Program.Equality.
Require Import Arith.
Require Import Setoid.
Require Import Relations.
Require Import Compare_dec.
Require Import ArithRing.
Require Import Omega.
Require Import Coq.Program.Tactics.

(* ============= partial identity   ================*)

(* outputs in (previous_edges ne bg) are in bg *)
Lemma prev_edge_in_bi_G: forall G ne prev_ne,
    In ne G ->
    In prev_ne (previous_edges ne (undirect_to_bidirect G)) ->
    In prev_ne (undirect_to_bidirect G).
Proof.
intros.
unfold previous_edges in H0.
remember (undirect_to_bidirect G) as bg.
apply filter_In in H0. destruct H0. assumption.
Qed.

Lemma prev_edge_prop: forall prev_ne ne G,
    In ne G ->
    In prev_ne (previous_edges ne (undirect_to_bidirect G)) ->
    prev_ne.1.1 =v= ne.1.2 /\ prev_ne.1.2 >v< ne.1.1.
Proof.
intros. unfold previous_edges in H0. apply filter_In in H0. destruct H0. apply andb_true_iff in H1. easy.
Qed.

(* undirect_to_bidirect preserve original edges *)
Lemma undirect_edge_in_bi_G: forall G undir_e,
    In undir_e G ->
    undir_e.1.1 >v< input ->
    In undir_e (undirect_to_bidirect G).
Proof. intros. unfold undirect_to_bidirect. apply filter_In. split.
- apply in_flat_map. exists undir_e. split. intuition. intuition.
- intuition.
Qed.

Definition no_self_loop (G: N_Graph_type) : Prop :=  (forall ne, In ne G -> ne.1.1 <> ne.1.2).

(* A spec on graph, ensuring that no self-looping *)
Lemma no_self_loop_in_bg:
    forall G,
    no_self_loop G -> no_self_loop (undirect_to_bidirect G).
Proof.
intros G H. unfold no_self_loop. intros. unfold undirect_to_bidirect in *.
apply filter_In in H0. destruct H0. apply in_flat_map in H0. destruct H0 as [e hyp]; destruct hyp.
unfold no_self_loop in H.
simpl in H2. destruct H2.
- hammer.
- hammer.
Qed.

(* Check if there's "input" vertex *)
Definition no_input_vertex (G: N_Graph_type) : Prop :=
    (forall ne, In ne G -> (ne.1.1 >v< input) /\ (ne.1.2 >v< input)).

(* a lemma to ensure there's no input vertices left *)
Lemma no_input_vertex_in_bg:
    forall G,
    no_input_vertex G -> no_input_vertex (undirect_to_bidirect G).
Proof. intros. unfold no_input_vertex. intros. unfold undirect_to_bidirect in H0.
apply filter_In in H0. destruct H0. apply in_flat_map in H0. destruct H0 as [e hyp]; destruct hyp.
unfold no_self_loop in H.
simpl in H2. destruct H2.
- hammer.
- hammer.
Qed.

(* vertices in the naive graph, ARB *)
Example AA3 : Vertex := index 1.
Example AB := index 2.
Example AC := index 3.
Example AA1 := index 4.
Example Ch := index 5.
Example BC := index 6.
Example A3r := index 7.
Example A2r := index 8.
Example A1r := index 9.

(* taxiway name *)
Example A : Taxiway_type := "A".
Example B := "B".
Example C := "C".
Example A1 := "A1".
Example A2 := "A2".
Example A3 := "A3".

(* input edges have taxiway name "" *)
Example naive_ann_arbor : N_Graph_type :=[
    ((Ch, input), "");
    ((A1r, input), "");
    ((A2r, input), "");
    ((A3r, input), "");
    ((BC, input), "");
    ((Ch, BC), C);
    ((BC, AB), B);
    ((AB, AA3), A);
    ((AA3, A3r), A3);
    ((AB, A2r), A2);
    ((BC, AC), C);
    ((AB, AC), A);
    ((AC, AA1), A);
    ((AA1, A1r), A1)
].

 (* Example G1 : N_Graph_type := [
    ((AA1, AC), A);
    ((AA1, A1r), A)
    ].

Theorem toC_toN_id : forall (ne: Edge_type) ,
    no_self_loop G1 -> (* no self loop *)
    In ne G1 ->
    (exists prev_ne, In prev_ne (previous_edges ne (undirect_to_bidirect G1))) -> (* ne has a previous edge in the bidirect graph *)
    (forall ne, In ne G1 ->
        (ne.1.1 >v< input) /\ (ne.1.2 >v< input)) -> (* input vertex should not appear in any naive graph *)
        In ne (to_N (to_C G1)) \/ In (Edge_inv ne) (to_N (to_C G1)).
Proof. intros. simpl in H0. destruct H0.
hammer. hammer. Qed.  *)

(* TODO o put it in types.v *)
Lemma negb_eqv_refl: forall v1 v2, v1 >v< v2 <-> v2 >v< v1.
Proof. intros. split.
- hammer.
- hammer.
Qed.

Lemma negb_eqv_false_equiv: forall v1 v2, (v1 =v= v2) = false -> (v2 =v= v1) = false.
Proof. intros.
apply eqv_rewrite_2. apply negb_eqv_refl. hammer.
Qed.

Lemma bidirected_graph_no_edge_end_with_input:
    forall ne G,
    In ne (undirect_to_bidirect G) ->
    ne.1.1 >v< input.
Proof. intros. unfold undirect_to_bidirect in H.
apply filter_In in H. destruct H. assumption. Qed.

(*  Here we prove "most" of the edges in G are in (to_N (to_C G)).
    Specifically, an edge ne in undirected graph G is also in (to_N (to_C G)) if:
    1. there's no self-loop in G
    2. ne is not an input edge
    3. there exists a previous edge of ne in the bidirected graph.
      Because our undirect graph uses an ordered pair [A,B] (a directed edge) to represent {[A,B],[B,A]},
      this is equivalent to say that there is an edge e in the undirect graph, s.t. e or reverse_e is ne's previous edge, under condition 2
*)
Theorem G_subset_toN_toC_G : forall (ne: Edge_type) (G: N_Graph_type),
    no_self_loop G -> (* no self loop *)
    In ne G ->
    (exists prev_ne,
        (* ne has a previous edge in the bidirect graph *)
        (In prev_ne (previous_edges ne (undirect_to_bidirect G)))
    ) ->
    (ne.1.2 >v< input /\ ne.1.1 >v< input) -> (* ne is not an input edge *)
    In ne (to_N (to_C G)).

Proof. intros ne G Hno_self_loop Hne_in_G Hexist_prev H_ne_not_input.
destruct H_ne_not_input as [H_ne_not_input1 H_ne_not_input2].
unfold to_C.
remember (undirect_to_bidirect G) as bg.
unfold generate_edges.
destruct Hexist_prev as [prev_ne Hprev_ne].

remember (to_N (to_C [ne; prev_ne] )) as G''.
destruct ne as [neEndStart neTaxi] eqn:Hne1.
destruct neEndStart as [neEnd neStart] eqn:Hne2.
simpl in H_ne_not_input1, H_ne_not_input2.
assert (Hne3: neStart >v< neEnd). {
    apply Hno_self_loop in Hne_in_G; simpl in Hne_in_G.
    apply eqv_inv. hammer.
}
assert(Hne4: (neEnd >v< neStart)). {
    apply negb_eqv_refl. assumption.
}
assert(Hne5: (neEnd =v= neStart) = false). {
    hammer.
}
assert(Hne5_2: (neStart =v= neEnd) = false). {
    apply negb_eqv_false_equiv. assumption.
}
(* properties about ne and prev_ne *)

assert(Hprev_ne_in_bg: In prev_ne bg). {
    rewrite -> Heqbg.
    apply prev_edge_in_bi_G with (ne:= ne). hammer.
    hammer.
}

assert (Hprev_ne1: (prev_ne.1.1 >v< input) ) by hammer.
assert (Hprev_ne3: prev_ne.1.1 =v= ne.1.2 /\ prev_ne.1.2 >v< ne.1.1). {
    apply prev_edge_prop with (G:=G). hammer. hammer.
}
rewrite -> Hne1 in Hprev_ne3; simpl in Hprev_ne3.
destruct Hprev_ne3 as [Hprev_ne3 Hprev_ne4].
assert (Hprev_ne5: (prev_ne.1.1 >v< prev_ne.1.2)). {
    rewrite -> Heqbg in Hprev_ne_in_bg.
    apply no_self_loop_in_bg in Hprev_ne_in_bg.
    apply eqv_inv.
    assumption.
    assumption.
}

assert  (Hprev_ne6: (prev_ne.1.2 =v= neStart) = false). {
    apply eqv_eq in Hprev_ne3. rewrite Hprev_ne3 in Hprev_ne5.
    clear - Hprev_ne5. apply eqv_rewrite_2 in Hprev_ne5.
    destruct (prev_ne.1.2 =v= neStart) eqn: Htemp.
    - apply eqv_eq in Htemp. symmetry in Htemp. apply eqv_eq in Htemp. rewrite Hprev_ne5 in Htemp. intuition.
    - intuition.
}

assert (lemma: In ne G'' ). {
    (* 4 situations, whether ne_start/end ?= Types.input *)
        rewrite -> HeqG''. rewrite <- Hne1. unfold to_C.
        remember (undirect_to_bidirect [ne; prev_ne ]) as b_G' eqn: Hbg_ne. (* bidirected graph from [ne] *)
        rewrite -> Hne1 in Hbg_ne.
        (* eval bg_ne *)
        unfold undirect_to_bidirect in Hbg_ne. simpl in Hbg_ne.
        rewrite -> H_ne_not_input1 in Hbg_ne; rewrite -> H_ne_not_input2 in Hbg_ne.
        rewrite -> Hprev_ne1 in Hbg_ne.
        destruct (prev_ne.1.2 >v< input) eqn: Hprev_ne2.
        -  simpl in Hbg_ne.
            unfold Edge_inv in Hbg_ne; simpl in Hbg_ne.
            (* eval (generate_edges bg_ne) *)
            unfold generate_edges, previous_edges.
            rewrite -> Hbg_ne. simpl.

            Ltac choose_branch term hyp :=
                assert (hyp: term) by hammer; rewrite hyp; simpl.
            choose_branch ((neEnd =v= neStart) && (neStart >v< neEnd) = false) branch1.
            choose_branch ((neStart =v= neStart) && (neEnd >v< neEnd) = false) branch2.
            choose_branch ((prev_ne.1.1 =v= neStart) && (prev_ne.1.2 >v< neEnd) = true) branch3.
            left. unfold c_to_n; simpl. easy.
        -  rewrite Hbg_ne. simpl. unfold Edge_inv, generate_edges. simpl.
        choose_branch ((neEnd =v= neStart) && (neStart >v< neEnd) = false) branch1.
        choose_branch ((neStart =v= neStart) && (neEnd >v< neEnd) = false) branch2.
        choose_branch ((prev_ne.1.1 =v= neStart) && (prev_ne.1.2 >v< neEnd) = true) branch3.
        left. unfold c_to_n; simpl. easy.
}

assert(Hne8: (neStart =v= neStart)) by hammer.
assert(Hne9: (neEnd =v= neEnd)) by hammer.
assert (Hprev_ne7: (prev_ne.1.1 =v= neEnd) = false). {
    apply eqv_rewrite_2. apply eqv_inv. apply eqv_eq in Hprev_ne3. rewrite Hprev_ne3.
    apply eqv_inv. assumption.
}

(* eval G''*)
unfold In, to_N, to_C, undirect_to_bidirect, generate_edges, previous_edges in HeqG''; simpl in HeqG''.

Ltac unfold_undir_to_bidir Hprev_ne1  Hne7 H :=
    unfold undirect_to_bidirect in H; simpl in H;
    rewrite -> Hprev_ne1, Hne7 in H; simpl.

Ltac choose_branch_2 term hyp H:=
    assert (hyp: term) by first [apply negb_eqv_false_equiv; easy |  hammer];
    rewrite -> hyp in H; simpl in H.

unfold Edge_inv in HeqG''. simpl in HeqG''.
apply eqv_rewrite_2 in Hprev_ne4.
apply eqv_rewrite_2 in Hne3.
apply eqv_rewrite_2 in Hprev_ne1.
apply eqv_rewrite_2 in Hprev_ne5.

destruct (prev_ne.1.2 >v< input) eqn:Hprev_ne_not_input.
-   repeat (
            try rewrite -> Hne3 in HeqG'';
            try rewrite -> Hne4 in HeqG'';
            try rewrite -> Hne5 in HeqG'';
            try rewrite -> Hne5_2 in HeqG'';
            try rewrite -> Hne8 in HeqG'';
            try rewrite -> Hne9 in HeqG'';
            try rewrite -> H_ne_not_input1 in HeqG'';
            try rewrite -> H_ne_not_input2 in HeqG'';
            try rewrite -> Hprev_ne_in_bg in HeqG'';
            try rewrite -> Hprev_ne1 in HeqG'';
            try rewrite -> Hprev_ne3 in HeqG'';
            try rewrite -> Hprev_ne4 in HeqG'';
            try rewrite -> Hprev_ne5 in HeqG'';
            try rewrite -> Hprev_ne6 in HeqG'';

            try rewrite -> Hprev_ne7 in HeqG'';
            try rewrite -> Hne1 in HeqG'';
            try unfold Edge_inv in HeqG'';
            try simpl in HeqG'';
            try unfold c_to_n in HeqG''
    ).

    choose_branch_2 ((neEnd =v= prev_ne.1.2) = false) hyp1 HeqG''.
    choose_branch_2 ((neStart =v= prev_ne.1.2) = false) hyp2 HeqG''.
    choose_branch_2 ((prev_ne.1.2 =v= prev_ne.1.2)) hyp3 HeqG''.
    choose_branch_2 ((prev_ne.1.1 =v= prev_ne.1.1)) hyp4 HeqG''.
    choose_branch_2 ((neEnd =v= prev_ne.1.1) = false) hyp5 HeqG''.
    choose_branch_2 (((neStart =v= prev_ne.1.1))) hyp6 HeqG''.
    choose_branch_2 ((prev_ne.1.2 =v= prev_ne.1.1) = false) hyp7 HeqG''.

    assert(lemma2: In ne (to_N (to_C G))). {
        (* destruct Hprev_ne0 as [L Hprev_ne0].
        rewrite <- Hprev_ne0. *)
        unfold to_C. rewrite <- Heqbg.
        simpl.
        (* evaluate the first generate_edges *)
        Ltac temp Hne1 Hne3 Hne4 Hne5 Hne5_2 Hne6 Hne7 Hne8 Hne9
        Hprev_ne1 Hprev_ne2 Hprev_ne3 Hprev_ne4 Hprev_ne5 Hprev_ne6 Hprev_ne7 Hprev_ne
        hyp1 hyp2 hyp3 hyp4 hyp5 hyp6 hyp7 hyp8 hyp9:=
            unfold generate_edges at 1; simpl;
            repeat (
                try rewrite -> Hne1;
                try rewrite -> Hne3;
                try rewrite -> Hne4;
                try rewrite -> Hne5;
                try rewrite -> Hne5_2;
                try rewrite -> Hne6;
                try rewrite -> Hne7;
                try rewrite -> Hne8;
                try rewrite -> Hne9;
                try rewrite -> Hprev_ne1;
                try rewrite -> Hprev_ne2;
                try rewrite -> Hprev_ne3;
                try rewrite -> Hprev_ne4;
                try rewrite -> Hprev_ne5;
                try rewrite -> Hprev_ne6;
                try rewrite -> Hprev_ne7;
                try rewrite -> hyp1;
                try rewrite -> hyp2;
                try rewrite -> hyp3;
                try rewrite -> hyp4;
                try rewrite -> hyp5;
                try rewrite -> hyp6;
                try rewrite -> hyp7;
                try rewrite -> hyp8;
                try rewrite -> hyp9;
                try unfold Edge_inv;
                try simpl
            );
            unfold c_to_n; simpl.
        temp Hne1 Hne3 Hne4 Hne5 Hne5_2 Hne6 Hne7 Hne8 Hne9
            Hprev_ne1 Hprev_ne2 Hprev_ne3 Hprev_ne4 Hprev_ne5 Hprev_ne6 Hprev_ne7 Hprev_ne
            hyp1 hyp2 hyp3 hyp4 hyp5 hyp6 hyp7 hyp8 hyp9.
        unfold to_N. apply in_map_iff.
        exists (prev_ne.1, (neEnd, neStart), neTaxi).
        split.
        - easy.
        - apply in_flat_map. exists ne. split.
            + rewrite Heqbg. apply undirect_edge_in_bi_G.
                * hammer. * hammer.
            + apply in_map_iff. exists prev_ne. split. hammer. hammer.
    }
    hammer.
(* the proof for this case is kind of redundant with the previous one *)
- repeat (
        try rewrite -> Hne3 in HeqG'';
        try rewrite -> Hne4 in HeqG'';
        try rewrite -> Hne5 in HeqG'';
        try rewrite -> Hne5_2 in HeqG'';
        try rewrite -> Hne8 in HeqG'';
        try rewrite -> Hne9 in HeqG'';
        try rewrite -> H_ne_not_input1 in HeqG'';
        try rewrite -> H_ne_not_input2 in HeqG'';
        try rewrite -> Hprev_ne_in_bg in HeqG'';
        try rewrite -> Hprev_ne1 in HeqG'';
        try rewrite -> Hprev_ne3 in HeqG'';
        try rewrite -> Hprev_ne4 in HeqG'';
        try rewrite -> Hprev_ne5 in HeqG'';
        try rewrite -> Hprev_ne6 in HeqG'';

        try rewrite -> Hprev_ne7 in HeqG'';
        try rewrite -> Hne1 in HeqG'';
        try unfold Edge_inv in HeqG'';
        try simpl in HeqG'';
        try unfold c_to_n in HeqG''
    ).
    choose_branch_2 ((neEnd =v= prev_ne.1.2) = false) hyp1 HeqG''.
    choose_branch_2 ((neStart =v= prev_ne.1.2) = false) hyp2 HeqG''.
    assert(lemma2: In ne (to_N (to_C G))). {
    unfold to_C. rewrite <- Heqbg.
    simpl.
        unfold c_to_n; simpl.
    temp Hne1 Hne3 Hne4 Hne5 Hne5_2 Hne6 Hne7 Hne8 Hne9
        Hprev_ne1 Hprev_ne2 Hprev_ne3 Hprev_ne4 Hprev_ne5 Hprev_ne6 Hprev_ne7 Hprev_ne
        hyp1 hyp2 hyp3 hyp4 hyp5 hyp6 hyp7 hyp8 hyp9.
        unfold to_N. apply in_map_iff.
        exists (prev_ne.1, (neEnd, neStart), neTaxi).
        split.
        - easy.
        - apply in_flat_map. exists ne. split.
            + rewrite Heqbg. apply undirect_edge_in_bi_G.
                * hammer. * hammer.
            + apply in_map_iff. exists prev_ne. split. hammer. hammer.
    }
    hammer.
Qed.

(*  (to_N (to_C G)) \subset  (undirect_to_bidirect G) *)
Theorem toN_toC_G_subset_G : forall (G: N_Graph_type),
    incl (to_N (to_C G)) (undirect_to_bidirect G).
Proof. intros. unfold incl. intro ne. intros.
unfold to_N, to_C in H.
remember (undirect_to_bidirect G) as bg.
apply in_map_iff in H. destruct H as [A H]. destruct H.
apply in_flat_map in H0. destruct H0 as [e H1]. destruct H1 as [H1 H2].
unfold generate_edges in H2. apply in_map_iff in H2. destruct H2 as [V H2]. destruct H2 as [H2 H3].
assert (e = ne) by hammer.
rewrite <- H0. assumption.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C Bprime : Universe, ((wd_ O E /\ (wd_ A Eprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Bprime Eprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O A Eprime /\ (col_ E A Eprime /\ col_ Bprime O Eprime)))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*****************************************************)
(*****************************************************)
(****                                             ****)
(****   The category of categories and functors   ****)
(****                                             ****)
(*****************************************************)
(*****************************************************)

Require Import Main.CategoryTheory.Category.
Require Import Main.CategoryTheory.Functor.

Definition catCategory : category := newCategory
  category
  (functor)
  (fun _ _ _ => compFunctor)
  (fun _ => idFunctor)
  (@compFunctorAssoc)
  (@compFunctorIdentLeft)
  (@compFunctorIdentRight).


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lia.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
Import ListNotations.
From QE Require Import Maps.

Inductive expr : Type :=
| Tru
| Fls
| If (e0 : expr) (e1 : expr) (e2 : expr)
| Raise (γ : string)
| Handle (e1 : expr) (γ : string) (e2 : expr).

(* bool is the only type here *)
Inductive ty : Type :=
| TBool : ty.

Inductive eval : expr -> expr -> Prop :=
| E_If_t : forall e2 e3, eval (If Tru e2 e3) e2
| E_If_f : forall e2 e3, eval (If Fls e2 e3) e3
| E_If_g : forall e1 e1' e2 e3,
    eval e1 e1' ->
    eval (If e1 e2 e3) (If e1' e2 e3)
| E_If_r : forall e2 e3 γ,
    eval (If (Raise γ) e2 e3) (Raise γ)
| E_handle_t : forall γ e2, eval (Handle Tru γ e2) Tru
| E_handle_f : forall γ e2, eval (Handle Fls γ e2) Fls
| E_handle_r : forall γ e2, eval (Handle (Raise γ) γ e2) e2
| E_handle_e : forall e1 e1' γ e2,
    eval e1 e1' ->
    eval (Handle e1 γ e2) (Handle e1' γ e2)
| E_handle_h : forall γ γ' e2,
    γ <> γ' ->
    eval (Handle (Raise γ) γ' e2) (Raise γ).

Definition context := total_map nat.

Inductive value : expr -> Prop :=
| v_t : value Tru
| v_f : value Fls.

Inductive has_type : context -> expr -> ty -> Prop :=
| T_Tru : forall Γ, has_type Γ Tru TBool
| T_Fls : forall Γ, has_type Γ Fls TBool
| T_Raise : forall Γ γ, (Γ γ) = 1 -> has_type Γ (Raise γ) TBool
| T_If : forall Γ e1 e2 e3,
    has_type Γ e1 TBool ->
    has_type Γ e2 TBool ->
    has_type Γ e3 TBool ->
    has_type Γ (If e1 e2 e3) TBool
| T_Handle : forall Γ γ e1 e2,
    (Γ γ) = 0 ->
    has_type (γ !-> 1 ; Γ) e1 TBool ->
    has_type Γ e2 TBool ->
    has_type Γ (Handle e1 γ e2) TBool.

Hint Constructors eval : core.
Hint Constructors has_type : core.
Hint Constructors value : core.

Local Open Scope string_scope.

Theorem e_progress : forall e T Γ,
    has_type Γ e T ->
    value e \/ (exists γ, (Γ γ) = 1 -> e = Raise γ) \/ exists e', eval e e'.
Proof with eauto.
  intros.
  induction H...
  - inversion H; subst...
    destruct IHhas_type1. inversion H5.
    destruct H5. destruct H5.
    right. left. exists x. intros. apply H5 in H6. discriminate H6.
    right. right. destruct H5...
    destruct IHhas_type1. inversion H5.
    destruct H5. destruct H5.
    right. left. exists x. intros. apply H5 in H6. discriminate H6.
    right. right. destruct H5...
  - inversion H0; subst...
    destruct IHhas_type1. inversion H3.
    destruct H3. destruct H3.
    (* need some related to string eqb *)
    Admitted.

(* Theorem e_progress : forall e T Γ, *)
(*     has_type Γ e T -> *)
(*     value e \/ (exists γ, e = Raise γ) \/ exists e', eval e e'. *)
(* Proof with eauto. *)
(*   intros. *)
(*   induction H... *)
(*   - right. right. *)
(*     destruct IHhas_type1. *)
(*     inversion H2... *)
(*     destruct H2. destruct H2. *)
(*     inversion H; subst... *)
(*     discriminate H7. *)
(*     discriminate H7. *)
(*     destruct H2... *)
(*   - right. right. *)
(*     destruct IHhas_type1. *)
(*     inversion H2; subst... *)
(*     destruct H2. *)
(*     destruct H2. *)
(*     inversion H0; subst... *)
(*     rewrite <- H5 in H0. *)
(*     exists (Raise γ0). constructor. *)


From Equations Require Import Equations.

Axiom P : nat -> Type.

Inductive foo : nat -> Type :=
| foo_let n (j := n) (k : P n) : nat -> let m := n + j + 2 in P m -> foo m.

Equations bar (n : nat) (x : foo n) : nat :=
  bar _ (foo_let x k n y) := n.


(************************************************************************)
(* Copyright (c) 2010, Martijn Vermaat <martijn@vermaat.name>           *)
(*                     Dimitri Hendriks <diem@cs.vu.nl>                 *)
(*                                                                      *)
(* Licensed under the MIT license, see the LICENSE file or              *)
(* http://en.wikipedia.org/wiki/Mit_license                             *)
(************************************************************************)

(** This library defines some preliminaries, mostly used in the [Vector]
   library. *)

Set Implicit Arguments.

Notation "!" := (False_rect _).

Definition S_eq : forall (n m : nat), n = m -> S n = S m :=
  fun n m H => f_equal S H.

(*
Definition S_eq_inv : forall (n m : nat), S n = S m -> n = m :=
  fun n m H => eq_add_S n m H.
*)

Definition S_eq_inv : forall (n m : nat), S n = S m -> n = m :=
  fun (n m : nat) (H : S n = S m) =>
  match (sym_eq H) in (_ = Sn) return pred Sn = pred (S m) with
  | refl_equal => refl_equal (pred (S m))
end.

Definition disc_O_S : forall (n : nat), O <> S n :=
  fun n H =>
  let P := (fun q : nat => match q with 0 => (False -> False) | S q => False end) in
  match H in (_ = q) return P q with refl_equal => (fun a => a) end.

Definition disc_S_O : forall (n : nat), S n <> O :=
  fun n H => disc_O_S (sym_eq H).


(** * Partial: Triples for Partial Correctness *)

Set Implicit Arguments.
From SLF Require Export Nondet.

Implicit Types f : var.
Implicit Types b : bool.
Implicit Types s : state.
Implicit Types t : trm.
Implicit Types v : val.
Implicit Types n : int.
Implicit Types p : loc.
Implicit Types h : heap.
Implicit Types P : Prop.
Implicit Types H : hprop.
Implicit Types Q : val->hprop.

(* ################################################################# *)
(** * First Pass *)

(** In this chapter, we investigate definitions of Hoare triples and Separation
    Logic triples with respect to partial correctness, that is, without imposing
    termination.

    Partial correctness is a weaker property than total correctness. However,
    it may be suited for reasoning about programs that are not meant to
    terminate, and may be interesting to consider as an intermediate target
    when reasoning about programs for which termination is much harder to
    establish than correctness.

    This chapter is organized as follows:

    - Partial correctness with respect to big-step semantics.
    - Bonus contents: partial correctness with respect to small-step semantics.

    This chapter, like the previous chapter [Nondet], omits sequences and
    non-recursive functions, as these features can be encoded. *)

(* ================================================================= *)
(** ** Big-Step Characterization of Partial Correctness *)

(** For total correctness, the judgment [evals s t Q] asserts that any
    execution of the program [(s,t)] terminates on an output satisfying [Q].
    In contrast, the partial correctness judgment [evalnp s t Q] asserts that
    any execution of the program [(s,t)] either terminates on an output
    satisfying [Q], or diverges (that is, executes for ever).

    The definition of the predicate [evalnp] is obtained by taking the
    constructors from the inductive definition of [evals], and considering
    the coinductive interpretation of these constructors. The coinductive
    interpretation allows for infinite derivation. It thereby introduces the
    possibility of diverging executions. Importantly, the predicate [evalnp]
    still disallows executions that get stuck. *)

CoInductive evalnp : state -> trm -> (val->state->Prop) -> Prop :=
  | evalnp_val : forall s v Q,
      Q v s ->
      evalnp s (trm_val v) Q
  | evalnp_fix : forall s f x t1 Q,
      Q (val_fix f x t1) s ->
      evalnp s (trm_fix f x t1) Q
  | evalnp_app_fix : forall s1 v1 v2 f x t1 Q,
      v1 = val_fix f x t1 ->
      evalnp s1 (subst x v2 (subst f v1 t1)) Q ->
      evalnp s1 (trm_app v1 v2) Q
  | evalnp_let : forall Q1 s1 x t1 t2 Q,
      evalnp s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalnp s2 (subst x v1 t2) Q) ->
      evalnp s1 (trm_let x t1 t2) Q
  | evalnp_if : forall s1 b t1 t2 Q,
      evalnp s1 (if b then t1 else t2) Q ->
      evalnp s1 (trm_if (val_bool b) t1 t2) Q
  | evalnp_add : forall s n1 n2 Q,
      Q (val_int (n1 + n2)) s ->
      evalnp s (val_add (val_int n1) (val_int n2)) Q
  | evalnp_rand : forall s n Q,
      n > 0 ->
      (forall n1, 0 <= n1 < n -> Q n1 s) ->
      evalnp s (val_rand (val_int n)) Q
  | evalnp_ref : forall s v Q,
      (forall p, ~ Fmap.indom s p ->
         Q (val_loc p) (Fmap.update s p v)) ->
      evalnp s (val_ref v) Q
  | evalnp_get : forall s p Q,
      Fmap.indom s p ->
      Q (Fmap.read s p) s ->
      evalnp s (val_get (val_loc p)) Q
  | evalnp_set : forall s p v Q,
      Fmap.indom s p ->
      Q val_unit (Fmap.update s p v) ->
      evalnp s (val_set (val_loc p) v) Q
  | evalnp_free : forall s p Q,
      Fmap.indom s p ->
      Q val_unit (Fmap.remove s p) ->
      evalnp s (val_free (val_loc p)) Q.

(** The judgment [hoarenp t H Q] captures partial correctness, in terms of
    [evalnp]. It is defined through the usual pattern for Hoare triples. *)

Definition hoarenp (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
  forall s, H s -> evalnp s t Q.

(** One key property is the covariance of [evalnp], which induces the rule
    of consequence for [hoarenp]. An interesting about the proof of covariance
    is that it is not carried out by induction, like [evaln_conseq], but by
    coinduction. Observe carefully the details of that proof. *)

Lemma evalnp_conseq : forall s t Q1 Q2,
  evalnp s t Q1 ->
  Q1 ===> Q2 ->
  evalnp s t Q2.
Proof using.
  introv M W. unfolds qimpl, himpl.
  gen s t Q1 Q2. cofix IH. intros. inverts M; try solve [ constructors* ].
Qed.

(* ================================================================= *)
(** ** From Total to Partial Correctness *)

(** Total correctness is a stronger property than partial correctness:
    [hoaren t H Q] entails [hoarenp t H Q]. To formalize this result, we first
    establish that [evaln s t Q], which is defined inductively, entails
    [evalnp s t Q], which is defined coinductively.

    The proof is a straightforward induction, reflecting on the fact that a
    coinductive interpretation of a set of rules is always derivable from an
    inductive interpretation of a same set of derivation rules. *)

Lemma evalnp_of_evaln : forall s t Q,
  evaln s t Q ->
  evalnp s t Q.
Proof using. introv M. induction M; try solve [ constructors* ]. Qed.

Lemma hoaren_of_cohoare : forall t H Q,
  hoaren t H Q ->
  hoarenp t H Q.
Proof using.
  introv M. intros s K. specializes M K. applys evalnp_of_evaln M.
Qed.

(* ================================================================= *)
(** ** Characterization of Divergence *)

(** The judgment partial correctness judgment [evalnp s t Q] asserts that
    any execution of the program [(s,t)] either terminates on an output
    satisfying [Q], or diverge. By instantiating [Q] as the predicate that is
    always false, we are thus able to assert that "every possible execution of
    the program [(s,t)] diverges".

    Let us name [Empty] this "empty" postcondition, which characterizes an
    empty set of output configurations. *)

Definition Empty : val->state->Prop :=
  fun v s => False.

(** The judgment [divn s t], defined as [evalnp s t Empty], asserts that every
    possible execution of the program [(s,t)] diverges. *)

Definition divn (s:state) (t:trm) : Prop :=
  evalnp s t Empty.

(* ================================================================= *)
(** ** Big-Step-Based Reasoning Rules *)

(** For the partial correctness triple ([hoarenp]), we can derive all the usual
    reasoning rules. The proofs are the same as for the reasoning rules for
    deriving total correctness triples ([hoaren]). *)

(** Structural rules *)

Lemma hoarenp_conseq : forall t H' Q' H Q,
  hoarenp t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  hoarenp t H Q.
Proof using.
  unfolds hoarenp. introv M MH MQ HF. applys* evalnp_conseq.
Qed.

Lemma hoarenp_hexists : forall t (A:Type) (J:A->hprop) Q,
  (forall x, hoarenp t (J x) Q) ->
  hoarenp t (hexists J) Q.
Proof using. introv M. intros h (x&Hh). applys M Hh. Qed.

Lemma hoarenp_hpure : forall t (P:Prop) H Q,
  (P -> hoarenp t H Q) ->
  hoarenp t (\[P] \* H) Q.
Proof using.
  introv M. intros h (h1&h2&M1&M2&D&U). destruct M1 as (M1&HP).
  lets E: hempty_inv HP. subst. rewrite Fmap.union_empty_l. applys~ M.
Qed.

(** Rules for term constructs *)

Lemma hoarenp_val : forall v H Q,
  H ==> Q v ->
  hoarenp (trm_val v) H Q.
Proof using. introv M. intros h K. applys* evalnp_val. Qed.

Lemma hoarenp_fix : forall f x t1 H Q,
  H ==> Q (val_fix f x t1) ->
  hoarenp (trm_fix f x t1) H Q.
Proof using. introv M. intros h K. applys* evalnp_fix. Qed.

Lemma hoarenp_app_fix : forall v1 v2 f x t1 H Q,
  v1 = val_fix f x t1 ->
  hoarenp (subst x v2 (subst f v1 t1)) H Q ->
  hoarenp (trm_app v1 v2) H Q.
Proof using. introv E M. intros h K. applys* evalnp_app_fix. Qed.

Lemma hoarenp_let : forall x t1 t2 H Q Q1,
  hoarenp t1 H Q1 ->
  (forall v1, hoarenp (subst x v1 t2) (Q1 v1) Q) ->
  hoarenp (trm_let x t1 t2) H Q.
Proof using. introv M1 M2. intros h K. applys* evalnp_let. Qed.

Lemma hoarenp_if : forall (b:bool) t1 t2 H Q,
  hoarenp (if b then t1 else t2) H Q ->
  hoarenp (trm_if b t1 t2) H Q.
Proof using. introv M. intros h K. applys* evalnp_if. Qed.

(** Rules for primitive operations *)

Lemma hoarenp_add : forall H n1 n2,
  hoarenp (val_add n1 n2)
    H
    (fun r => \[r = val_int (n1 + n2)] \* H).
Proof using.
  intros. intros h K. applys* evalnp_add. rewrite* hstar_hpure_l.
Qed.

Lemma hoarenp_rand : forall n,
  n > 0 ->
  hoarenp (val_rand n)
    \[]
    (fun r => \exists n1, \[0 <= n1 < n] \* \[r = val_int n1]).
Proof using.
  introv N. intros h K. applys* evalnp_rand.
  lets ->: hempty_inv K.
  intros n1 H1. applys* hexists_intro n1. rewrite* hstar_hpure_l.
  split*. applys* hpure_intro.
Qed.

Lemma hoarenp_ref : forall H v,
  hoarenp (val_ref v)
    H
    (fun r => (\exists p, \[r = val_loc p] \* p ~~> v) \* H).
Proof using.
  intros. intros s1 K. applys evalnp_ref. intros p D.
  unfolds update. applys hstar_intro K.
  { applys hexists_intro p. rewrite hstar_hpure_l.
    split*. applys hsingle_intro. }
  { applys* disjoint_single_of_not_indom. }
Qed.

Lemma hoarenp_get : forall H v p,
  hoarenp (val_get p)
    ((p ~~> v) \* H)
    (fun r => \[r = v] \* (p ~~> v) \* H).
Proof using.
  intros. intros s K.
  lets (h1&h2&P1&P2&D&->): hstar_inv (rm K).
  lets E1: hsingle_inv P1. lets I1: indom_single p v.
  applys evalnp_get.
  { applys* Fmap.indom_union_l. subst. applys indom_single. }
  { rewrite hstar_hpure_l. split.
    { subst h1. rewrite* Fmap.read_union_l. rewrite* Fmap.read_single. }
    { applys* hstar_intro. } }
Qed.

Lemma hoarenp_set : forall H w p v,
  hoarenp (val_set (val_loc p) v)
    ((p ~~> w) \* H)
    (fun r => \[r = val_unit] \* (p ~~> v) \* H).
Proof using.
  intros. intros s1 K.
  lets (h1&h2&P1&P2&D&->): hstar_inv (rm K).
  lets E1: hsingle_inv P1. lets I1: indom_single p v.
  applys evalnp_set.
  { applys* Fmap.indom_union_l. subst. applys indom_single. }
  { rewrite hstar_hpure_l. split*.
    { subst h1. rewrite Fmap.update_union_l.
      2:{ applys indom_single. }
      rewrite update_single. applys hstar_intro.
      { applys hsingle_intro. }
      { applys P2. }
      { applys Fmap.disjoint_single_set D. } } }
Qed.

Lemma hoarenp_free : forall H p v,
  hoarenp (val_free (val_loc p))
    ((p ~~> v) \* H)
    (fun r => \[r = val_unit] \* H).
Proof using.
  intros. intros s1 K.
  lets (h1&h2&P1&P2&D&->): hstar_inv (rm K).
  lets E1: hsingle_inv P1. lets I1: indom_single p v.
  applys evalnp_free.
  { applys* Fmap.indom_union_l. subst. applys indom_single. }
  { rewrite hstar_hpure_l. split*.
    { subst h1. rewrite* Fmap.remove_union_single_l.
      { intros Dl. applys* Fmap.disjoint_inv_not_indom_both D Dl. } } }
Qed.

(* ================================================================= *)
(** ** Big-Step-Based Reasoning Rules for Divergence *)

(** In a partial correctness setting, it is also interesting to derive
    reasoning rules for establishing that a program diverges. These rules
    are stated and proved next. *)

Lemma divn_app_fix : forall s1 v1 v2 f x t1,
  v1 = val_fix f x t1 ->
  divn s1 (subst x v2 (subst f v1 t1)) ->
  divn s1 (trm_app v1 v2).
Proof using. introv E M. unfolds divn. applys* evalnp_app_fix. Qed.

(** **** Exercise: 2 stars, standard, especially useful (divn_let_ctx)

    Prove the divergence rule for a let-binding covering the case where the
    first subterm diverges. *)

Lemma divn_let_ctx : forall s1 x t1 t2,
  divn s1 t1 ->
  divn s1 (trm_let x t1 t2).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

Lemma divn_let : forall s1 x t1 t2 Q1,
  evalnp s1 t1 Q1 ->
  (forall s2 v1, divn s2 (subst x v1 t2)) ->
  divn s1 (trm_let x t1 t2).
Proof using. introv M1 M2. unfolds divn. applys* evalnp_let M1. Qed.

Lemma divn_if : forall s1 b t1 t2,
  divn s1 (if b then t1 else t2) ->
  divn s1 (trm_if (val_bool b) t1 t2).
Proof using. introv M. unfolds divn. applys* evalnp_if. Qed.

(* ################################################################# *)
(** * Optional Material *)

(** So far, this chapter has focused on handling partial correctness using
    a big-step semantics. In this bonus section, we investigate the treatment
    of partial correctness using a small-step semantics. *)

(** Before we get started, let us state and prove a basic lemma asserting
    that values cannot take a step. It will useful throughout the section. *)

Lemma exists_step_val_inv : forall s v,
  (exists s' t', step s v s' t') ->
  False.
Proof using. introv (s'&t'&S). inverts S. Qed.

(* ================================================================= *)
(** ** Small-Step Characterization of Partial Correctness *)

(** In the chapter [Nondet], we presented a definition named
    [evals_attempt_3] that defined a small-step characterization of partial
    correctness. Let us rename this definition to [evalnps].

    The judgment [evalnps s t Q] asserts that, for any configuration
    [(s',t')] that can be reached from [(s',t')], either [t'] is a value that,
    together with [s'], satisfy the postcondition [Q]; or the configuration
    [(s',t')] can take a step, that is, it is not a stuck configuration. *)

Definition evalnps (s:state) (t:trm) (Q:val->state->Prop) : Prop :=
  forall s' t', evals s t s' t' ->
       (exists v, t' = trm_val v /\ Q v s')
    \/ (exists s'' t'', step s' t' s'' t'').

(** On top of [evalnps], we define a partial correctness Hoare triple
    judgment [hoarenps] in the usual way. *)

Definition hoarenps (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
  forall s, H s -> evalnps s t Q.

(** The property [evalnps s t Q] may be viewed as a form of typing:
    the configuration [(s,t)] admits the "type" [Q].

    - Base case: if [t] is a value, we assert that a configuration [(s,v)] has
      type [Q] iff [Q v s] holds.

    - Preservation property: if the configuration [(s,t)] has type [Q] and
      reduces to [(s',t')], then the configuration [(s',t')] also admits the
      same type [Q].

    - Progress property: if the configuration [(s,t)] has type [Q], then
      either [t] is of the form [trm_val v] and [(s,v)] admits type [Q],
      or the configuration [(s,t)] can take a reduction step to some
      configuration [(s',t')].

    The progress property is, in essence, a partial correctness
    property. Indeed, it ensures that programs never get stuck, yet without
    imposing termination.

    In what follows, we formally state and prove the three properties
    associated with the judgment [evalnps s t Q]: the characterization of the
    base case, the preservation property, and the progress property. *)

(** First, let's prove an introduction lemma and an inversion lemma for the
    base case, that is, the characteriation of values. *)

Lemma evalnps_val : forall s v Q,
  Q v s ->
  evalnps s v Q.
Proof using.
  introv M R. inverts R as.
  { left*. }
  { intros s1 t1 R1 R2. false. inverts R1. }
Qed.

Lemma evalnps_val_inv : forall s v Q,
  evalnps s v Q ->
  Q v s.
Proof using.
  introv M. forwards N: M s v. { applys evals_refl. }
  destruct N as [(v1&E1&P1)|(s2&t2&R)].
  { inverts* E1. }
  { inverts R. }
Qed.

(** Second, let's prove the preservation property. *)

(** **** Exercise: 3 stars, standard, especially useful (evalnps_inv_step)

    Prove that the property [evalnps] for a given postcondition [Q] is
    preserved when a program takes a reduction step. *)

Lemma evalnps_inv_step : forall s1 t1 s2 t2 Q,
  evalnps s1 t1 Q ->
  step s1 t1 s2 t2 ->
  evalnps s2 t2 Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** Third, let's prove the progress property. *)

(** **** Exercise: 4 stars, standard, especially useful (evalnps_not_val_inv)

    Prove that if the property [evalnps] holds for a given postcondition [Q],
    and for a configuration that has not already reached a value, and this
    configuration can take a step. Moreover, the configuration reached also
    satisfies the property [evalnps] for that same [Q]. *)

Lemma evalnps_not_val_inv : forall s1 t1 Q,
  evalnps s1 t1 Q ->
  (forall v, t1 <> trm_val v) ->
  exists s2 t2, step s1 t1 s2 t2 /\ evalnps s2 t2 Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Reasoning Rules w.r.t. Small-Step Characterization *)

(** We present two proofs of reasoning rules established with respect to the
    judgment [hoarenps]. The first proof targets the rule of consequence. This
    result leverages the covariance property for [evalnps]. *)

Lemma evalnps_conseq : forall s t Q Q',
  evalnps s t Q' ->
  Q' ===> Q ->
  evalnps s t Q.
Proof using.
  introv M WQ. introv R. lets [(v&E&P)|N]: M R.
  { left. exists v. split~. applys* WQ. }
  { right*. }
Qed.

Lemma hoarenps_conseq : forall t H' Q' H Q,
  hoarenps t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  hoarenps t H Q.
Proof using.
  introv M WH WQ. intros h K. applys evalnps_conseq WQ.
  applys M. applys WH K.
Qed.

(** The second proof targets the reasoning rule for let-bindings, stated
    for the judgment [hoarenps]. This result leverages as key intermediate
    lemma an introduction rule for let-bindings with respect to [evalnps]. *)

(** **** Exercise: 5 stars, standard, especially useful (evalnps_let)

    Prove the reasoning rule for let-bindings for [evalnps]. *)

Lemma evalnps_let : forall s x t1 t2 Q1 Q,
  evalnps s t1 Q1 ->
  (forall s1 v1, Q1 v1 s1 -> evalnps s1 (subst x v1 t2) Q) ->
  evalnps s (trm_let x t1 t2) Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

Lemma hoarenps_let : forall x t1 t2 H Q Q1,
  hoarenps t1 H Q1 ->
  (forall v1, hoarenps (subst x v1 t2) (Q1 v1) Q) ->
  hoarenps (trm_let x t1 t2) H Q.
Proof using.
  introv M1 M2. intros h K. applys* evalnps_let.
  { introv K'. applys* M2. }
Qed.

(* ================================================================= *)
(** ** Small-Step Characterization of Divergence *)

(** Recall the definition of [evalnps].

    Definition evalnps (s:state) (t:trm) (Q:val->state->Prop) : Prop :=
      forall s' t', evals s t s' t' ->
           (exists v, t' = trm_val v /\ Q v s')
        \/ (exists s'' t'', step s' t' s'' t'').

    The judgment [evalnps s t Q] can be specialized with the empty post-
    condition [Q := Empty] to express divergence, just like we did earlier on
    for setting up the definition of [divn].

    Recall that [Empty v s] is equivalent to [False]. Thus, let's take the
    definition of [evalnps s t Q] and replace [Q v s'] with [False]. The
    first clause of the disjunction, [exists v, t' = trm_val v /\ Q v s']
    is never satisfiable and thus may be removed. What remains is a simpler,
    direct characterization of the property that "all executions diverge".

    The corresponding predicate, named [divns s t] below, asserts that any
    execution prefix can be extended by at least one step. *)

Definition divns (s:state) (t:trm) : Prop :=
  forall s' t', evals s t s' t' ->
  exists s'' t'', step s' t' s'' t''.

(** **** Exercise: 3 stars, standard, optional (divns_iff_evalnps_Empty)

    Prove the equivalence between [divns] and the specialization
    of [evalnps] to [Empty]. *)

Lemma divns_iff_evalnps_Empty : forall s t,
  divns s t <-> evalnps s t Empty.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 2 stars, standard, optional (divns_inv_step)

    Prove that if a diverging configuration takes a step, then it reaches a
    configuration that also diverges. *)

Lemma divns_inv_step : forall s1 t1 s2 t2,
  divns s1 t1 ->
  step s1 t1 s2 t2 ->
  divns s2 t2.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 2 stars, standard, optional (divns_val_inv)

    Prove that the execution of a value does not diverge. *)

Lemma divns_val_inv : forall s v,
  ~ divns s v.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 5 stars, standard, optional (divns_let_ctx)

    Prove the divergence rule for a let-binding covering the case where the
    first subterm diverges, with respect to the definition [divns]. *)

Lemma divns_let_ctx : forall s1 x t1 t2,
  divns s1 t1 ->
  divns s1 (trm_let x t1 t2).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Coinductive, Small-Step Characterization of Partial Correctness *)

(** In the previous section, we characterized partial correctness using the
    judgment [evalnps], which is defined in terms of the transitive closure
    of the small-step relation [evals]. In this section, we present an
    alternative definition, based on a coinductive definition.

    Concretely, we start from the inductively defined judgment [evalns],
    which characterizes total correctness, and we consider the coinductive
    intrepretation of the same rules. The resulting judgment is written
    [evalnpz s t Q]. This coinductive definition, because it allows for
    infinite derivations, covers the case of diverging computations that
    take involve infinitely many reduction steps. *)

CoInductive evalnpz : state->trm->(val->hprop)->Prop :=
  | evalnpz_val : forall s v Q,
      Q v s ->
      evalnpz s v Q
  | evalnpz_step : forall s t Q,
      (exists s' t', step s t s' t') ->
      (forall s' t', step s t s' t' -> evalnpz s' t' Q) ->
      evalnpz s t Q.

(** We name [hoarenpz] the associated Hoare triple definition. *)

Definition hoarenpz (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
  forall s, H s -> evalnpz s t Q.

(** Here again, we focus on the proofs of two particular reasoning rules,
    established with respect to [evalnpz]. *)

(** Firstly, let's prove the rule of consequence. The key intermediate result is
    to establish the covariance of [evalnpz]. Observe that this proof is to
    be conducted by coinduction. *)

Lemma evalnpz_conseq : forall s t Q Q',
  evalnpz s t Q' ->
  Q' ===> Q ->
  evalnpz s t Q.
Proof using.
  introv M WQ. gen s t Q'. cofix IH; intros. destruct M.
  { applys evalnpz_val. applys* WQ. }
  { applys evalnpz_step.
    { eauto. }
    { introv R'. lets M': H0 R'. applys IH M' WQ. } }
Qed.

Lemma hoarenpz_conseq : forall t H' Q' H Q,
  hoarenpz t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  hoarenpz t H Q.
Proof using.
  introv M WH WQ. intros h K. applys evalnpz_conseq WQ.
  applys M. applys WH K.
Qed.

(** Secondly, we let's prove the reasoning rule for let-bindings. Here again,
    the key intermediate result is to establish a rule for [evalnpz]. *)

(** **** Exercise: 5 stars, standard, especially useful (hoarenpz_let)

    Prove the reasoning rule for let-bindings stated for [evalnpz].
    Hint: to set up the coinductive proof, follow the template that appears
    at the beginning of the proof of [evalnpz_conseq]. *)

Lemma evalnpz_let : forall s x t1 t2 Q1 Q,
  evalnpz s t1 Q1 ->
  (forall s1 v1, Q1 v1 s1 -> evalnpz s1 (subst x v1 t2) Q) ->
  evalnpz s (trm_let x t1 t2) Q.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

Lemma hoarenpz_let : forall x t1 t2 H Q Q1,
  hoarenpz t1 H Q1 ->
  (forall v1, hoarenpz (subst x v1 t2) (Q1 v1) Q) ->
  hoarenpz (trm_let x t1 t2) H Q.
Proof using.
  introv M1 M2. intros h K. applys* evalnpz_let.
  { introv K'. applys* M2. }
Qed.

(** To express diverge, the judgment [evalnp s t Q] may be specialized with
    the postcondition [Q := Empty]. Starting from the definition of
    [evalnpz], replacing [Q v s] with [False] is equivalent to removing
    the constructor [evalnpz_val] altogether. Thus, divergence of a
    configuration [(s,t)] may be characterized directly by the coinductive
    judgment [divnz s t] defined below, featuring a single constructor. *)

CoInductive divnz : state -> trm -> Prop :=
  | divnz_step : forall s1 t1,
      (exists s2 t2, step s1 t1 s2 t2) ->
      (forall s2 t2, step s1 t1 s2 t2 -> divnz s2 t2) ->
      divnz s1 t1.

(** **** Exercise: 4 stars, standard, optional (divnz_iff_evalnpz_Empty)

    Prove the equivalence between [divnz] and the specialization of the
    judgment [evalnp] to [Empty]. *)

Lemma divnz_iff_evalnpz_Empty : forall s t,
  divnz s t <-> evalnpz s t Empty.
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Equivalence Between the Two Small-Step Characterizations of Partial Correctness *)

(** This section establishes that [hoarenpz] is equivalent to [hoarenps].
    The key result is to prove [evalnpz] equivalent to [evalnps]. *)

Lemma evalnpz_eq_evalnps :
  evalnpz = evalnps.
Proof using.
  extens. intros s t Q. iff M.
  { introv R. gen M. induction R; intros.
    { inverts M as M1 M2.
      { left*. }
      { right. applys M1. } }
    { rename H into R1, R into R2. inverts M as M1 M2.
      { false. inverts R1. }
      { applys IHR. applys M2 R1. } } }
  { gen s t Q. cofix IH. intros.
    tests C: (exists v, t = trm_val v).
    { destruct C as (v&->). applys evalnpz_val. applys evalnps_val_inv M. }
    { lets (s2&t2&R2&RS): evalnps_not_val_inv M C. applys evalnpz_step.
      { exists* s2 t2. }
      { intros s' t' R'. applys IH. applys evalnps_inv_step M R'. } } }
Qed.

Lemma hoarenpz_eq_hoarenps :
  hoarenpz = hoarenps.
Proof using. unfold hoarenps, hoarenpz. rewrite* evalnpz_eq_evalnps. Qed.

(** As a corollary, we can establish the equivalence between the two small-step
    characterization of divergence. Indeed, both characterizations are obtained
    by specializing the postcondition of their underlying evaluation jugment to
    the empty postcondition, namely [Empty]. *)

Lemma divnz_eq_divns :
  divnz = divns.
Proof using.
  extens. intros s t.
  rewrite divns_iff_evalnps_Empty.
  rewrite divnz_iff_evalnpz_Empty.
  rewrite* evalnpz_eq_evalnps.
Qed.

(** ** Equivalence Between Small-Step and Big-Step Partial Correctness
       Semantics *)

(** We end this chapter with the proof of equivalence between [hoarenps] and
    [hoarenp], establishing a formal relationship between partial correctness
    triples defined with respect to a small-step semantics and those defined
    with respect to a big-step semantics.

    The first step of the proof is to formally relate [evalnpz] and [evalnp],
    which are both defined coinductively. Then, we can derive the equality
    between [hoarenpz] and [hoarenp], and conclude using the equality
    [hoarenpz_eq_hoarenps], which was established earlier on. *)

(** The first direction is from [evalnpz] to [evalnp]. To establish it, we
    need 3 inversion lemmas for let-bindings. *)

Lemma evalnpz_let_inv_ctx : forall x s1 t1 t2 Q Q1,
  evalnpz s1 (trm_let x t1 t2) Q ->
  (fun v s => evals s1 t1 s v) ===> Q1 ->
  evalnpz s1 t1 Q1.
Proof using.
  cofix IH. introv M WQ. inverts M as M0 M'.
  tests C: (exists v1, t1 = trm_val v1).
  { destruct C as (v1&->). applys evalnpz_val.
    applys WQ. applys evals_refl. }
  { applys evalnpz_step.
    { destruct M0 as (s'&t'&S). inverts S as. 2:{ false* C. }
      intros S. exists. applys S. }
    { intros s2 t1' S. applys IH.
      { applys M'. applys step_let_ctx S. }
      { intros v s R. applys WQ. applys evals_step S R. } } }
Qed.

Lemma evalnpz_let_inv_cont : forall s1 s2 v1 x t1 t2 Q,
  evalnpz s1 (trm_let x t1 t2) Q ->
  evals s1 t1 s2 v1 ->
  evalnpz s2 (subst x v1 t2) Q.
Proof using.
  introv M R. gen_eq t1': (trm_val v1). induction R; intros; subst.
  { inverts M as _ M'. applys M'. applys step_let. }
  { rename H into S, R into R', t0 into t1'.
    inverts M as _ M'. applys* IHR. applys M'.
    applys step_let_ctx S. }
Qed.

Lemma evalnpz_let_inv : forall s1 x t1 t2 Q,
  evalnpz s1 (trm_let x t1 t2) Q ->
  exists Q1, evalnpz s1 t1 Q1
          /\ (forall v1 s2, Q1 v1 s2 -> evalnpz s2 (subst x v1 t2) Q).
Proof using.
  introv M. exists (fun v s => evals s1 t1 s (trm_val v)). split.
  { applys* evalnpz_let_inv_ctx M. }
  { introv K. applys* evalnpz_let_inv_cont M K. }
Qed.

(** Using these inversion lemmas, we can prove by induction the first
    direction, from [evalnpz] to [evalnp]. *)

Lemma evalnp_of_evalnpz : forall s t Q,
  evalnpz s t Q ->
  evalnp s t Q.
Proof using.
  cofix IH. introv M. destruct t; try solve [ inverts M; false_invert ].
  { inverts M as.
    { intros R. applys evalnp_val R. }
    { intros (s'&t'&S) _. inverts S. } }
  { inverts M as.
    { intros (s'&t'&S) _. inverts S. } }
  { inverts M as (s'&t'&S) M'. inverts S. } (* not included in semantics *)
  { rename v into f, v0 into x, t into t1.
    inverts M as (s'&t'&S) M1. inverts S.
    applys evalnp_fix.
    forwards M1': M1. { applys step_fix. }
    inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
  { inverts M as (s'&t'&S) M1. inverts S as.
    { applys evalnp_app_fix. { reflexivity. } applys IH.
      applys M1. applys* step_app_fix. }
    { applys evalnp_add.
      forwards M1': M1. { applys step_add. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv N. applys* evalnp_rand. { math. }
      intros n1' N1.
      forwards M1': M1. { applys* step_rand n1'. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_ref. intros p' D'.
      forwards M1': M1. { applys* step_ref p'. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_get.
      forwards M1': M1. { applys* step_get. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_set.
      forwards M1': M1. { applys* step_set. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } }
    { introv D. applys* evalnp_free.
      forwards M1': M1. { applys* step_free. }
      inverts M1' as. { auto. } { intros. false* exists_step_val_inv. } } }
  { inverts M as (s'&t'&S) M'. inverts S. } (* not included in semantics *)
  { lets (Q1&M1&M2): evalnpz_let_inv M. applys evalnp_let.
    { applys IH. applys M1. }
    { introv R. applys IH. applys M2 R. } }
  { inverts M as (s'&t'&S) M1. inverts S. applys evalnp_if.
    applys IH. applys M1. applys step_if. }
Qed.

(** For the reciprocal direction, we also need one key inversion lemma. It
    is stated below. Its hypothesis is [evalnp s t Q], and its conclusion
    corresponds to the disjunction of the constructors of the inductive
    definition of [evalnpz s t Q]. *)

Lemma evalnp_inv_step : forall s t Q,
  evalnp s t Q ->
     (exists v, t = trm_val v /\ Q v s)
  \/ ((exists s' t', step s t s' t' /\ evalnp s' t' Q)
      /\ (forall s' t', step s t s' t' -> evalnp s' t' Q)).
Proof using.
  introv M. gen s Q. induction t; intros; inverts M as.
  { introv R. left. eauto. }
  { introv R. right. split.
    { exists. split. { applys step_fix. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S. applys* evalnp_val. } }
  { introv M1. right. split.
    { exists. split. { applys* step_app_fix. } { auto. } }
    { intros s' t' S. inverts S as E. inverts E. auto. } }
  { introv R. right. split.
    { exists. split. { applys step_add. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S. applys* evalnp_val. } }
  { introv N R. right. split.
    { exists. split. { applys* step_rand 0. math. }
       { applys* evalnp_val. applys R. math. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv R. right. split.
    { forwards~ (p&D&N): (exists_fresh null s).
      exists. split. { applys* step_ref. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv D R. right. split.
    { exists. split. { applys* step_get. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv D R. right. split.
    { exists. split. { applys* step_set. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv D R. right. split.
    { exists. split. { applys* step_free. } { applys* evalnp_val. } }
    { intros s' t' S. inverts S; tryfalse. applys* evalnp_val. } }
  { introv M1 M2. rename v into x. right. split.
    { forwards [(v1&->&HQ1)|((s'&t'&S'&M')&_)]: IHt1 M1.
      { exists. split. { applys step_let. } { applys* M2. } }
      { exists. split.
        { applys step_let_ctx S'. }
        { applys evalnp_let M'. applys M2. } } }
    { intros s' t' S. inverts S as S.
      { forwards [(v1&->&HQ1)|(_&M3)]: IHt1 M1.
        { inverts S. }
        { specializes M3 S. applys evalnp_let M3 M2. } }
      { inverts M1 as R. applys* M2. } } }
  { introv M1. right. split.
    { exists. split. { applys step_if. } { auto. } }
    { intros s' t' S. inverts S. auto. } }
Qed.

(** Using this inversion lemma, it is straightforward to derive the
    implication from [evalnp] to [evalnpz]. *)

Lemma evalnpz_of_coeval : forall s t Q,
  evalnp s t Q ->
  evalnpz s t Q.
Proof.
  cofix IH. introv M. lets C: evalnp_inv_step M.
  destruct C as [(v&->&HQ)|((s'&t'&S&M1)&M2)].
  { applys evalnpz_val HQ. }
  { applys evalnpz_step.
    { exists. applys S. }
    { intros s1 t1 S'. applys IH. applys M2 S'. } }
Qed.

(** Combining the two directions yields the equality between [evalnpz] and
    [evalnp], and that between [evalnps] and [evalnp]. *)

Lemma evalnpz_eq_evalnp :
   evalnpz = evalnp.
Proof using.
  extens. intros s t Q. iff M.
  { applys* evalnp_of_evalnpz. }
  { applys* evalnpz_of_coeval. }
Qed.

Lemma hoarenpcso_eq_hoarenp :
  hoarenpz = hoarenp.
Proof using. unfold hoarenp, hoarenpz. rewrite* evalnpz_eq_evalnp. Qed.

Lemma hoarenps_eq_hoarenp :
   hoarenps = hoarenp.
Proof using.
  rewrite <- hoarenpz_eq_hoarenps. rewrite* hoarenpcso_eq_hoarenp.
Qed.

(** As another corollary, we can establish the equivalence between the big-step
    and the small-step characterization of divergence. Indeed, both are
    obtained by specializing the postcondition to [Empty]. *)

Lemma divns_eq_divn :
  divns = divn.
Proof using.
  extens. intros s t. unfold divn.
  rewrite divns_iff_evalnps_Empty.
  rewrite <- evalnpz_eq_evalnp.
  rewrite* evalnpz_eq_evalnps.
Qed.

(* ================================================================= *)
(** ** Historical Notes *)

(** Many program verification tools target partial correctness only, or provide
    separate tooling for justifying termination.

    The soundness of program logics delivering partial correctness is nearly
    always justified with respect to a small-step semantics of the programming
    language. Partial correctness is generally chosen because it appears better
    suited for reasoning about programs that involve some amount of
    concurrency, and for programs that are not meant to terminate (e.g., system
    kernels).

    Capturing partial correctness using a coinductive big-step judgment, as done
    in this chapter with the predicate [evalnp], appears to be novel as of Jan.
    2021. *)

(* 2021-01-25 13:22 *)


Require Import List. Import ListNotations.
Require Import Rules.
Require Import Instructions.
Require Import Machine.

Set Implicit Arguments.

Fixpoint break_expr n (e : rule_expr n) : list (rule_expr n) :=
  match e with
  | L_Bot => []
  | L_Var m => [L_Var m]
  | L_Join e1 e2 => break_expr e1 ++ break_expr e2
  end.

Fixpoint join_exprs n (es : list (rule_expr n)) : rule_expr n :=
  match es with
  | nil => L_Bot
  | e :: nil => e
  | e :: es' => L_Join e (join_exprs es')
  end.

Fixpoint break_scond n (c : rule_scond n) : list (rule_scond n) :=
  match c with
  | A_True => []
  | A_LE e1 e2 => List.map (fun e1' => A_LE e1' e2) (break_expr e1)
  | A_And c1 c2 => break_scond c1 ++ break_scond c2
  | A_Or c1 c2 => [c]
  end.

Fixpoint and_sconds n (cs : list (rule_scond n)) : rule_scond n :=
  match cs with
  | nil => A_True
  | c :: nil => c
  | c :: cs' => A_And c (and_sconds cs')
  end.

Fixpoint drop_each X (xs : list X) : list (list X) :=
  match xs with
  | nil => []
  | x :: xs' => xs' :: (map (fun xs'' => x :: xs'') (drop_each xs'))
  end.

Example ex_drop_each :
  drop_each [1;2;3;4] = [[2;3;4];[1;3;4];[1;2;4];[1;2;3]].
Proof. reflexivity. Qed.

Definition mutate_expr n (e : rule_expr n) : list (rule_expr n) :=
  let es := (break_expr e) in
  match es with
  | nil => []
  | _ => List.map (@join_exprs n) (drop_each es)
  end.

Definition eL1 : rule_expr 3 := Lab1.
Definition eL2 : rule_expr 3 := Lab2.
Definition eL3 : rule_expr 3 := Lab3.
Definition ePC : rule_expr 3 := LabPC.

Example ex_break_expr :
  break_expr (L_Join (L_Join eL1 eL2) eL3) = [eL1; eL2; eL3].
Proof. reflexivity. Qed.

Example ex_drop_each' :
  drop_each [eL1; eL2; eL3] = [[eL2;eL3]; [eL1;eL3]; [eL1;eL2]].
Proof. reflexivity. Qed.

Example ex_join_exprs :
  join_exprs [eL1; eL2; eL3] = L_Join eL1 (L_Join eL2 eL3).
Proof. reflexivity. Qed.

Example ex_mutate_expr :
  mutate_expr (L_Join (L_Join eL1 eL2) eL3) =
    [L_Join eL2 eL3; L_Join eL1 eL3; L_Join eL1 eL2].
Proof. reflexivity. Qed.

Example ex_mutate_expr_var : mutate_expr eL1 = [@L_Bot 3].
Proof. reflexivity. Qed.

Example ex_mutate_expr_bot : mutate_expr (@L_Bot 3) = [].
Proof. compute. reflexivity. Qed.

(* For the pc we move disjuncts to the result label;
   to prevent useless mutants we never move the pc label,
   but we do try to remove it if there is no result label *)
Fixpoint drop_each_but_not_lpc n (es : list (rule_expr n)) :
    list (rule_expr n * list (rule_expr n)) :=
  let f x xs'' := (fst xs'', x :: snd xs'') in
  match es with
  | nil => []
  | (L_Var labpc) :: xs' =>
      map (f (L_Var (@labpc n))) (drop_each_but_not_lpc xs')
  | x :: xs' =>
      (x, xs') :: (map (f x) (drop_each_but_not_lpc xs'))
  end.

Example ex_drop_each_but_not_lpc_1 :
  drop_each_but_not_lpc [eL1; ePC] = [(Lab1, [LabPC])].
Proof. reflexivity. Qed.

Example ex_drop_each_but_not_lpc_1' :
  drop_each_but_not_lpc [ePC; eL1] = [(Lab1, [LabPC])].
Proof. reflexivity. Qed.

Example ex_drop_each_but_not_lpc_2 :
  drop_each_but_not_lpc [eL1; eL2; ePC] =
    [(Lab1, [Lab2; LabPC]); (Lab2, [Lab1; LabPC])].
Proof. reflexivity. Qed.

Example ex_drop_each_but_not_lpc_2' :
  drop_each_but_not_lpc [eL1; ePC; eL2] =
    [(Lab1, [LabPC; Lab2]); (Lab2, [Lab1; LabPC])].
Proof. reflexivity. Qed.

Example ex_drop_each_but_not_lpc_2'' :
  drop_each_but_not_lpc [ePC; eL1; eL2] =
    [(Lab1, [LabPC; Lab2]); (Lab2, [LabPC; Lab1])].
Proof. reflexivity. Qed.

Definition mutate_pc n (ores : option (rule_expr n)) (epc : rule_expr n)
    : list (option (rule_expr n) * (rule_expr n)) :=
  let es := (break_expr epc) in
  match es with
  | nil => []
  | _ =>
      match ores with
      | Some eres =>
          let f xxs := (Some (L_Join eres (fst xxs)), join_exprs (snd xxs)) in
          List.map f (drop_each_but_not_lpc es)
      | None =>
          (* we just drop each pc disjunct as before *)
          let f xs := (None, join_exprs xs) in
          List.map f (drop_each es)
      end
  end.

Example ex_mutate_pc_1 :
  mutate_pc (Some eL2) (L_Join eL1 ePC) = [(Some (JOIN Lab2 Lab1), LabPC)].
Proof. reflexivity. Qed.

Example ex_mutate_pc_1' :
  mutate_pc (Some eL2) (L_Join ePC eL1) = [(Some (JOIN Lab2 Lab1), LabPC)].
Proof. reflexivity. Qed.

Example ex_mutate_pc_2 :
  mutate_pc (Some eL3) (L_Join (L_Join ePC eL1) eL2) =
    [(Some (JOIN Lab3 Lab1), JOIN LabPC Lab2);
     (Some (JOIN Lab3 Lab2), JOIN LabPC Lab1)].
Proof. reflexivity. Qed.

Definition mutate_scond n (c : rule_scond n) : list (rule_scond n) :=
  let cs := (break_scond c) in
  match cs with
  | nil => []
  | _ => List.map (@and_sconds n) (drop_each cs)
  end.

Definition c123 := A_LE (L_Join eL1 eL2) eL3.
Definition c321 := A_LE eL3 (L_Join eL1 eL2).
Definition c13 := A_LE eL1 eL3.
Definition c23 := A_LE eL2 eL3.

Example ex_break_scond :
  break_scond (A_And c123 c321) = [c13; c23; c321].
Proof. reflexivity. Qed.

Example ex_and_sconds :
  and_sconds [c13; c23; c321] = A_And c13 (A_And c23 c321).
Proof. reflexivity. Qed.

Example ex_mutate_scond :
  mutate_scond (A_And c123 c321) = [A_And c23 c321;
                                    A_And c13 c321;
                                    A_And c13 c23].
Proof. reflexivity. Qed.

Example ex_mutate_scond_true : mutate_scond (@A_True 3) = [].
Proof. reflexivity. Qed.

Definition mutate_rule n (r : AllowModify n) : list (AllowModify n) :=
  let a := allow r in
  let res := labRes r in
  let pc := labResPC r in
  (List.map (fun a' => almod a' res pc) (mutate_scond a)) ++
  (match res with
   | Some lres =>
      List.map (fun lres' => almod a (Some lres') pc) (mutate_expr lres)
   | None => []
   end) ++
  (List.map (fun respc => almod a (fst respc) (snd respc)) (mutate_pc res pc)).

(* Printing
Eval cbv in (mutate_rule
  (≪ AND (LE Lab2 LabPC) (LE (JOIN LabPC (JOIN Lab1 Lab2)) Lab3),
     JOIN Lab1 Lab2, LabPC ≫)).
*)

(* This displays bad
Definition mutate_table (t : table) : list table :=
  fold_left (@List.app table)
    (List.map (fun (o : OpCode) =>
      (List.map (fun (mr : AllowModify (labelCount o)) (o' : OpCode) =>
        match opCode_eq_dec o o' with
        | left H => eq_rec_r _ (fun x => x) H mr
        | right _ => t o'
        end
      ) (mutate_rule (t o)))
    ) opCodes) [].
*)

(* Breaking this out gives more control on the evaluation *)
Definition helper o (mr : AllowModify (labelCount o)) o'
  (orig : AllowModify (labelCount o')) : AllowModify (labelCount o') :=
  match opCode_eq_dec o o' with
  | left H => eq_rec_r _ (fun x => x) H mr
  | right _ => orig
  end.

(* The dummy argument t' will be the same as t,
    just that I wanted more control on evaluation *)
Definition mutate_table' (t t' : table) : list table :=
  fold_left (@List.app table)
    (List.map (fun (o : OpCode) =>
      (List.map (fun (mr : AllowModify (labelCount o)) (o' : OpCode)
        => helper o mr o' (t' o')
      ) (mutate_rule (t o)))
    ) opCodes) [].
Definition mutate_table t := mutate_table' t t.

(* Printing
Definition copy_table := default_table.
Eval lazy -[labelCount helper copy_table] in
  (mutate_table' default_table copy_table).

Eval simpl in nth 21 (mutate_table default_table).
(* can achieve the same with partial application *)
Eval lazy -[labelCount helper] in
  (mutate_table' default_table).

Eval lazy in (List.length (mutate_table default_table)).
*)


From stdpp Require Import tactics.
From stdpp Require Import options.
Local Set Universe Polymorphism.

(* Not using [list Type] in order to avoid universe inconsistencies *)
Inductive tlist := tnil : tlist | tcons : Type → tlist → tlist.

Inductive hlist : tlist → Type :=
  | hnil : hlist tnil
  | hcons {A As} : A → hlist As → hlist (tcons A As).

Fixpoint tapp (As Bs : tlist) : tlist :=
  match As with tnil => Bs | tcons A As => tcons A (tapp As Bs) end.
Fixpoint happ {As Bs} (xs : hlist As) (ys : hlist Bs) : hlist (tapp As Bs) :=
  match xs with hnil => ys | hcons x xs => hcons x (happ xs ys) end.

Definition hhead {A As} (xs : hlist (tcons A As)) : A :=
  match xs with hnil => () | hcons x _ => x end.
Definition htail {A As} (xs : hlist (tcons A As)) : hlist As :=
  match xs with hnil => () | hcons _ xs => xs end.

Fixpoint hheads {As Bs} : hlist (tapp As Bs) → hlist As :=
  match As with
  | tnil => λ _, hnil
  | tcons _ _ => λ xs, hcons (hhead xs) (hheads (htail xs))
  end.
Fixpoint htails {As Bs} : hlist (tapp As Bs) → hlist Bs :=
  match As with
  | tnil => id
  | tcons _ _ => λ xs, htails (htail xs)
  end.

Fixpoint himpl (As : tlist) (B : Type) : Type :=
  match As with tnil => B | tcons A As => A → himpl As B end.

Definition hinit {B} (y : B) : himpl tnil B := y.
Definition hlam {A As B} (f : A → himpl As B) : himpl (tcons A As) B := f.
Arguments hlam _ _ _ _ _ / : assert.

Definition hcurry {As B} (f : himpl As B) (xs : hlist As) : B :=
  (fix go {As} xs :=
    match xs in hlist As return himpl As B → B with
    | hnil => λ f, f
    | hcons x xs => λ f, go xs (f x)
    end) _ xs f.
Coercion hcurry : himpl >-> Funclass.

Fixpoint huncurry {As B} : (hlist As → B) → himpl As B :=
  match As with
  | tnil => λ f, f hnil
  | tcons x xs => λ f, hlam (λ x, huncurry (f ∘ hcons x))
  end.

Lemma hcurry_uncurry {As B} (f : hlist As → B) xs : huncurry f xs = f xs.
Proof. by induction xs as [|A As x xs IH]; simpl; rewrite ?IH. Qed.

Fixpoint hcompose {As B C} (f : B → C) {struct As} : himpl As B → himpl As C :=
  match As with
  | tnil => f
  | tcons A As => λ g, hlam (λ x, hcompose f (g x))
  end.


From Coq Require Import Program Program.Tactics Arith List.
From mathcomp Require Import ssreflect ssrnat.
From ssrlib Require Import Lists.

(** * Formalization of heterogeneous lists.

  This formalization is based on the following paper.
  - Paolo Herms, Claude Marché, Benjamin Monate:
    A Certified Multi-prover Verification Condition Generator.
    VSTTE 2012: 2-17
 *)

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

Declare Scope hlist_scope.
Delimit Scope hlist_scope with hlist.

Reserved Notation "x '=i' y" (at level 70, no associativity).
Reserved Notation "x '<>i' y" (at level 70, no associativity).
Reserved Notation "x '=v' y" (at level 70, no associativity).
Reserved Notation "x '<>v' y" (at level 70, no associativity).

Section HList.

  Variable S : Type.

  Variable T : S -> Type.

  (* A lidx is an index of a hlist. *)
  Inductive lidx A : list S -> Type :=
  | HI0 E : lidx A (A :: E)
  | HIS B E : lidx A E -> lidx A (B :: E).

  (* Heterogeneous lists. *)
  Inductive hlist : list S -> Type :=
  | Hnil : hlist nil
  | Hcons A E : T A -> hlist E -> hlist (A :: E).

  Definition hnil : hlist nil := Hnil.

  (* Equalities *)

  Local Open Scope hlist_scope.

  Definition xdil E A := lidx A E.

  (** Equality of lidx. *)

  Definition lidx_eq A B E (i : lidx A E) (j : lidx B E) :=
    EqdepFacts.eq_dep S (xdil E) A i B j.

  Notation "x '=i' y" := (lidx_eq x y) (at level 70, no associativity) : hlist_scope.
  Notation "x '<>i' y" := (~ (lidx_eq x y)) (at level 70, no associativity) : hlist_scope.

  (* Given that i : lidx A E, j : lidx B E, and H : lidx_eq i j, produce
   i = j and change B to A. *)
  Ltac lidx_eq_eq H :=
    match goal with
    | i : lidx ?A ?E, j : lidx ?B ?E, H : lidx_eq ?i ?j |- _ =>
      let Hab := fresh in
      let Hab' := fresh in
      let Heq := fresh in
      inversion H as [Hab [Hab' Heq]];
        clear Hab';
        move: i j Heq H;
        rewrite -Hab => {Hab};
        move=> i j Heq H;
        move: (EqdepFacts.eq_sigT_snd Heq);
        rewrite -{1}eq_rect_eq => {Heq}
    | H : lidx_eq ?i ?j |- _ =>
      let Hab := fresh in
      let Heq := fresh in
      inversion H as [Hab Heq];
        clear Hab;
        move: (EqdepFacts.eq_sigT_snd Heq);
        rewrite -{1}eq_rect_eq => {Heq}
    end.

  Lemma lidx_eq_ty_eq A B E (i : lidx A E) (j : lidx B E) :
    i =i j -> A = B.
  Proof.
    move=> H.
    inversion H as [H1 [H2 H3]].
    reflexivity.
  Qed.

  Lemma lidx_eq_eq A E (i j : lidx A E) :
    i =i j -> i = j.
  Proof.
    move=> H.
    lidx_eq_eq H => Heq.
    exact: Heq.
  Qed.

  Lemma eq_lidx_eq A E (i j : lidx A E) :
    i = j -> i =i j.
  Proof.
    move=> Heq; rewrite Heq.
    exact: EqdepFacts.eq_dep_intro.
  Qed.

  Lemma lidx_neq_neq A E (x y : lidx A E) :
    x <>i y -> x <> y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    apply: eq_lidx_eq.
    exact: Hxy.
  Qed.

  Lemma neq_lidx_neq A E (x y : lidx A E) :
    x <> y -> x <>i y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    apply: lidx_eq_eq.
    exact: Hxy.
  Qed.

  Lemma ty_neq_lidx_neq A B E (x : lidx A E) (y : lidx B E) :
    A <> B -> x <>i y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    inversion Hxy.
    reflexivity.
  Qed.

  Lemma lidx_eq_his_eq A B E (x : lidx A E) (y : lidx B E) ty :
    x =i y -> HIS ty x =i HIS ty y.
  Proof.
    move=> Hxy; rewrite Hxy.
    reflexivity.
  Qed.

  Lemma his_eq_lidx_eq A B E (x : lidx A E) (y : lidx B E) ty :
    HIS ty x =i HIS ty y -> x =i y.
  Proof.
    move=> Hxy.
    dependent destruction Hxy.
    reflexivity.
  Qed.

  (** Equality of values. *)

  Definition value_eq A B (x : T A) (y : T B) :=
    EqdepFacts.eq_dep S T A x B y.

  Notation "x '=v' y" := (value_eq x y) (at level 70, no associativity) : hlist_scope.
  Notation "x '<>v' y" := (~ (value_eq x y)) (at level 70, no associativity) : hlist_scope.

  Ltac value_eq_eq H :=
    match goal with
    | i : T ?A, j : T ?B, H : value_eq ?i ?j |- _ =>
      let Hab := fresh in
      let Hab' := fresh in
      let Heq := fresh in
      inversion H as [Hab [Hab' Heq]];
        clear Hab';
        move: i j Heq H;
        rewrite -Hab => {Hab};
        move=> i j Heq H;
        move: (EqdepFacts.eq_sigT_snd Heq);
        rewrite -{1}eq_rect_eq => {Heq}
    | H : value_eq ?i ?j |- _ =>
      let Hab := fresh in
      let Heq := fresh in
      inversion H as [Hab Heq];
        clear Hab;
        move: (EqdepFacts.eq_sigT_snd Heq);
        rewrite -{1}eq_rect_eq => {Heq}
    end.

  Lemma value_eq_ty_eq A B (x : T A) (y : T B) :
    x =v y -> A = B.
  Proof.
    move=> H.
    inversion H as [H1 [H2 H3]].
    reflexivity.
  Qed.

  Lemma value_eq_eq A (x : T A) (y : T A) :
    x =v y -> x = y.
  Proof.
    move=> H.
    value_eq_eq H => Heq.
    exact: Heq.
  Qed.

  Lemma eq_value_eq A (x y : T A) :
    x = y -> x =v y.
  Proof.
    move=> Heq; rewrite Heq.
    exact: EqdepFacts.eq_dep_intro.
  Qed.

  Lemma value_neq_neq A (x y : T A) :
    x <>v y -> x <> y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    apply: eq_value_eq.
    exact: Hxy.
  Qed.

  Lemma neq_value_neq A (x y : T A) :
    x <> y -> x <>v y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    apply: value_eq_eq.
    exact: Hxy.
  Qed.

  Lemma ty_neq_value_neq A B (x : T A) (y : T B) :
    A <> B -> x <>v y.
  Proof.
    move=> Hne Hxy; apply: Hne.
    inversion Hxy.
    reflexivity.
  Qed.

  (** Access and update a heterogeneous list. *)

  (* Access an index of a heterogeneous list. *)
  Program Fixpoint acclidx A E (i : lidx A E) (l : hlist E) : T A :=
    match l with
    | Hnil => !
    | Hcons _ _ h q =>
      match i with
      | HI0 _ => h
      | HIS _ _ i1 => acclidx i1 q
      end
    end.
  Next Obligation.
      by inversion i.
  Qed.

  (* Update an index of a heterogeneous list. *)
  Program Fixpoint updlidx A E (i : lidx A E) (v : T A) (l : hlist E) : hlist E :=
    match l with
    | Hnil => !
    | Hcons _ _ h q =>
      match i with
      | HI0 _ => Hcons v q
      | HIS _ _ i1 => Hcons h (updlidx i1 v q)
      end
    end.
  Next Obligation.
      by inversion i.
  Qed.

  Lemma acclidx_updlidx_heq A B E :
    forall (i : lidx A E) (j : lidx B E) (v : T B) (l : hlist E),
      i =i j ->
      acclidx i (updlidx j v l) =v v.
  Proof.
    move=> i j v l Heq.
    rewrite Heq => {A i Heq}.
    elim: l B j v => {E}.
    - move=> A i v.
      by inversion i.
    - move=> A E va l Hind B i vb.
      move: va vb.
      dependent destruction i => /=.
      + move=> _ vb.
        exact: EqdepFacts.eq_dep_intro.
      + move=> _ vb.
        exact: (Hind B i vb).
  Qed.

  Lemma acclidx_updlidx_eq A E :
    forall (i : lidx A E) (j : lidx A E) (v : T A) (l : hlist E),
      i = j ->
      acclidx i (updlidx j v l) = v.
  Proof.
    move=> i j v l Heq.
    move: (eq_lidx_eq Heq) => {Heq} Heq.
    move: (acclidx_updlidx_heq v l Heq) => Hveq.
    value_eq_eq Hveq => {Hveq} Hveq.
    exact: Hveq.
  Qed.

  Lemma acclidx_updlidx_hneq A B E :
    forall (i : lidx A E) (j : lidx B E) (v : T B) (l : hlist E),
      i <>i j ->
      acclidx i (updlidx j v l) = acclidx i l.
  Proof.
    move=> i j v l Hne.
    elim: l A B i j Hne v => {E}.
    - move=> A B i j Hne v.
      by inversion i.
    - move=> A E va l Hind A' B i j Hne vb.
      dependent destruction j => /=.
      + dependent destruction i => /=.
        * apply: False_ind.
          apply: Hne.
          reflexivity.
        * reflexivity.
      + dependent destruction i => /=.
        * reflexivity.
        * apply: Hind => Heq.
          apply: Hne.
          rewrite Heq.
          reflexivity.
  Qed.

  Lemma acclidx_updlidx_neq A E :
    forall (i : lidx A E) (j : lidx A E) (v : T A) (l : hlist E),
      i <> j ->
      acclidx i (updlidx j v l) = acclidx i l.
  Proof.
    move=> i j v l Hne.
    move: (neq_lidx_neq Hne) => {Hne} Hne.
    apply: acclidx_updlidx_hneq.
    exact: Hne.
  Qed.

  Lemma acclidx_updlidx_ty_neq A B E :
    forall (i : lidx A E) (j : lidx B E) (v : T B) (l : hlist E),
      A <> B ->
      acclidx i (updlidx j v l) = acclidx i l.
  Proof.
    move=> i j v l Hne.
    apply: acclidx_updlidx_hneq.
    apply: ty_neq_lidx_neq.
    exact: Hne.
  Qed.

  (** Other operations *)

  Fixpoint length E (l : hlist E) : nat :=
    match l with
    | Hnil => 0
    | Hcons _ _ hd tl => (length tl).+1
    end.

  Program Definition hd (E : nonempty_list S) (l : hlist E) : T (nonempty_hd E) :=
    match l with
    | Hnil => !
    | Hcons _ _ hd _ => hd
    end.
  Next Obligation.
    move: Heq_anonymous => {l Heq_l}.
    elim: E.
    discriminate.
  Qed.
  Next Obligation.
    move=> {l wildcard'1 Heq_l hd}.
    move: wildcard' wildcard'0 Heq_anonymous.
    elim: E => /=.
    move=> hd tl hd' tl' [] Hhd _.
    assumption.
  Qed.

  Definition tl E (l : hlist E) : hlist (List.tl E) :=
    match l with
    | Hnil => Hnil
    | Hcons _ _ _ tl => tl
    end.

End HList.

Notation "x '=i' y" := (lidx_eq x y) (at level 70, no associativity) : hlist_scope.
Notation "x '<>i' y" := (~ (lidx_eq x y)) (at level 70, no associativity) : hlist_scope.
Notation "x '=v' y" := (value_eq x y) (at level 70, no associativity) : hlist_scope.
Notation "x '<>v' y" := (~ (value_eq x y)) (at level 70, no associativity) : hlist_scope.


(* --------------------------------------------------------------------
 * (c) Copyright 2011--2012 Microsoft Corporation and Inria.
 * (c) Copyright 2012--2014 Inria.
 * (c) Copyright 2012--2014 IMDEA Software Institute.
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect eqtype ssrbool ssrnat ssrfun seq.
From mathcomp Require Import choice ssralg bigop.
From CoqWord Require Export ssrZ.

Import GRing.Theory.

Local Open Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.

Local Notation simpm := Monoid.simpm.

Require Import NArith ZArith BinPos Ring_polynom Field_theory.

(* -------------------------------------------------------------------- *)
Reserved Notation "x %:S" (at level 2, left associativity, format "x %:S").

Notation "c %:S"   := (PEc c)     : ssring.
Notation "''X_' i" := (PEX _ i)   : ssring.
Notation "x + y"   := (PEadd x y) : ssring.
Notation "x - y"   := (PEsub x y) : ssring.
Notation "- x"     := (PEopp x  ) : ssring.
Notation "x * y"   := (PEmul x y) : ssring.
Notation "x ^+ n"  := (PEpow x n) : ssring.

Notation "0" := PEO : ssring.
Notation "1" := PEI : ssring.

Delimit Scope ssring with S.

(* -------------------------------------------------------------------- *)
Notation "c %:S"   := (FEc c)     : ssfield.
Notation "''X_' i" := (FEX _ i)   : ssfield.
Notation "x + y"   := (FEadd x y) : ssfield.
Notation "x - y"   := (FEsub x y) : ssfield.
Notation "- x"     := (FEopp x  ) : ssfield.
Notation "x * y"   := (FEmul x y) : ssfield.
Notation "x ^-1"   := (FEinv x)   : ssfield.
Notation "x / y"   := (FEdiv x y) : ssfield.
Notation "x ^+ n"  := (FEpow x n) : ssfield.

Notation "0" := FEO : ssfield.
Notation "1" := FEI : ssfield.

Delimit Scope ssfield with F.

(* -------------------------------------------------------------------- *)
Local Coercion Z_of_nat      : nat >-> Z.
Local Coercion N_of_nat      : nat >-> N.
Local Coercion P_of_succ_nat : nat >-> positive.
Local Coercion Z.pos         : positive >-> Z.

(* -------------------------------------------------------------------- *)
Class find (T : Type) (x : T) (xs : seq T) (i:nat).

Instance find0 (T : Type) (x : T) (xs : seq T)
 : find x (x :: xs) 0
 := { }.

Instance findS (T : Type) (x : T) (y : T) (ys :  seq T) i
 {_: find x ys i}
 : find x (y :: ys) i.+1 | 1
 := { }.

(* -------------------------------------------------------------------- *)
Class closed (T : Type) (xs : seq T).

Instance closed_nil T
 : closed (T:=T) nil
 := { }.

Instance closed_cons T (x : T) (xs : seq T)
 {_: closed xs}
 : closed (x :: xs)
 := { }.

(* -------------------------------------------------------------------- *)
Class reify (R : ringType) (a : R) (t : PExpr Z) (e : seq R).

Instance reify_zero (R : ringType) e : @reify R 0 0%S e := { }.
Instance reify_one  (R : ringType) e : @reify R 1 1%S e := { }.

Instance reify_natconst (R : ringType) n e
  : @reify R n%:R ((n : Z)%:S)%S e
  := { }.

Instance reify_add (R : ringType) a1 a2 t1 t2 e
  {_: @reify R a1 t1 e}
  {_: @reify R a2 t2 e}
  : reify (a1 + a2) (t1 + t2)%S e
  := { }.

Instance reify_opp (R : ringType) a t e
  {_: @reify R a t e}
  : reify (-a) (-t)%S e
  := { }.

Instance reify_natmul (R : ringType) a n t e
  {_: @reify R a t e}
  : reify (a *+ n) (t * (n : Z)%:S)%S e
  := { }.

Instance reify_mul (R : ringType) a1 a2 t1 t2 e
  {_: @reify R a1 t1 e}
  {_: @reify R a2 t2 e}
  : reify (a1 * a2) (t1 * t2)%S e
  := { }.

Instance reify_exp (R : ringType) a n t e
  {_: @reify R a t e}
  : reify (a ^+ n) (t ^+ n)%S e | 1
  := { }.

Instance reify_var (R : ringType) a i e
  `{find R a e i}
  : reify a ('X_i)%S e
  | 100
  := { }.

Definition reifyl (R : ringType) a t e
  {_: @reify R a t e}
  `{closed (T := R) e}
  := (t, e).

(* -------------------------------------------------------------------- *)
Ltac reify xt xe :=
  match goal with
  |- ?a = 0 =>
     match eval red in (reifyl (a := a)) with
     | (?t, ?e) => pose xt := t; pose xe := e
     end
  end.

(* -------------------------------------------------------------------- *)
Class freify (F : fieldType) (a : F) (t : FExpr Z) (e : seq F).

Instance freify_zero (F : fieldType) e : @freify F 0 0%F e := { }.
Instance freify_one  (F : fieldType) e : @freify F 1 1%F e := { }.

Instance freify_natconst (F : fieldType) n e
  : @freify F n%:R ((n : Z)%:S)%F e
  := { }.

Instance freify_add (F : fieldType) a1 a2 t1 t2 e
  {_: @freify F a1 t1 e}
  {_: @freify F a2 t2 e}
  : freify (a1 + a2) (t1 + t2)%F e
  := { }.

Instance freify_opp (F : fieldType) a t e
  {_: @freify F a t e}
  : freify (-a) (-t)%F e
  := { }.

Instance freify_natmul (F : fieldType) a n t e
  {_: @freify F a t e}
  : freify (a *+ n) (t * (n : Z)%:S)%F e
  := { }.

Instance freify_mul (F : fieldType) a1 a2 t1 t2 e
  {_: @freify F a1 t1 e}
  {_: @freify F a2 t2 e}
  : freify (a1 * a2) (t1 * t2)%F e
  := { }.

Instance freify_inv (F : fieldType) a t e
  {_: @freify F a t e}
  : freify (a^-1) (t^-1)%F e
  := { }.

Instance freify_exp (F : fieldType) a n t e
  {_: @freify F a t e}
  : freify (a ^+ n) (t ^+ n)%F e | 1
  := { }.

Instance freify_var (F : fieldType) a i e
  `{find F a e i}
  : freify a ('X_i)%F e
  | 100
  := { }.

Definition freifyl (F : fieldType) a t e
  {_: @freify F a t e}
  `{closed (T := F) e}
  := (t, e).

(* -------------------------------------------------------------------- *)
Ltac freify xt xe :=
  match goal with
  |- ?a = 0 =>
     match eval red in (freifyl (a := a)) with
     | (?t, ?e) => pose xt := t; pose xe := e
     end
  end.

(* -------------------------------------------------------------------- *)
Definition R_of_Z (R : ringType) (z : Z) : R :=
  match z with
  | Z0     => 0
  | Zpos n =>   (nat_of_P n)%:R
  | Zneg n => - (nat_of_P n)%:R
  end.

Arguments R_of_Z [R].

Lemma z0E: 0%Z = 0.
Proof. by []. Qed.

Lemma zaddE (z1 z2 : Z): (z1 + z2)%Z = z1 + z2.
Proof. by []. Qed.

Lemma zoppE (z : Z): (-z)%Z = -z.
Proof. by []. Qed.

Lemma zmulE (z1 z2 : Z): (z1 * z2)%Z = z1 * z2.
Proof. by []. Qed.

Definition zE := (z0E, zaddE, zoppE).

Lemma R_of_Z_is_additive (R : ringType): additive (R_of_Z (R := R)).
Proof.
  have oppm: {morph (R_of_Z (R := R)) : x / -x >-> -x}.
    by case=> [|n|n] //=; rewrite ?(oppr0, opprK).
  have addm z1 z2: R_of_Z (z1 + z2) = R_of_Z z1 + R_of_Z z2 :> R.
    wlog: z1 z2 / (z1 <=? z2)%Z; first move=> wlog.
    + case: (boolP (z1 <=? z2))%Z; first by move/wlog.
    + move/negbTE/Z.leb_gt/Z.lt_le_incl/Z.leb_le.
      by move/wlog; rewrite Z.add_comm addrC.
    case: z1 z2=> [|n1|n1] [|n2|n2] //= _; rewrite ?(addr0, add0r) //.
    + by rewrite Pos2Nat.inj_add natrD.
    + case: (Z.compare_spec n1 n2) => [[->]||].
      * by rewrite Z.pos_sub_diag addrC subrr.
      * move=> lt; rewrite (Z.pos_sub_gt _ _ lt) /=.
        rewrite (Pos2Nat.inj_sub _ _ lt) natrB 1?addrC //.
        apply/leP/Pos2Nat.inj_le/Pos.lt_le_incl/Pos.ltb_lt.
        by rewrite Pos2Z.inj_ltb; apply/Pos.ltb_lt.
      * move=> lt; rewrite (Z.pos_sub_lt _ _ lt) /=.
        rewrite (Pos2Nat.inj_sub _ _ lt) natrB ?opprB 1?addrC //.
        apply/leP/Pos2Nat.inj_le/Pos.lt_le_incl/Pos.ltb_lt.
        by rewrite Pos2Z.inj_ltb; apply/Pos.ltb_lt.
    + by rewrite Pos2Nat.inj_add natrD opprD.
  by move=> z1 z2 /=; rewrite addm oppm.
Qed.

Canonical R_of_Z_additive (R : ringType) := Additive (R_of_Z_is_additive R).

Lemma R_of_Z_is_multiplicative (R : ringType): multiplicative (R_of_Z (R := R)).
Proof.
  split=> //=; case=> [|z1|z1] [|z2|z2] //=;
    rewrite ?simpm // ?(mulNr, mulrN, opprK);
    by rewrite nat_of_P_mult_morphism natrM.
Qed.

Canonical R_of_Z_rmorphism (R : ringType) := AddRMorphism (R_of_Z_is_multiplicative R).

Local Notation REeval :=
  (@PEeval _ 0 +%R *%R (fun x y => x - y) -%R Z R_of_Z nat nat_of_N (@GRing.exp _)).

Lemma RE (R : ringType): @ring_eq_ext R +%R *%R -%R (@eq R).
Proof. by split; do! move=> ? _ <-. Qed.

Local Notation "~%R"   := (fun x y => x - y).
Local Notation "/%R"   := (fun x y => x / y).
Local Notation "^-1%R" := (@GRing.inv _) (only parsing).

Lemma RR (R : comRingType): @ring_theory R 0 1 +%R *%R ~%R -%R (@eq R).
Proof.
  split=> //=;
    [ exact: add0r | exact: addrC | exact: addrA  | exact: mul1r
    | exact: mulrC | exact: mulrA | exact: mulrDl | exact: subrr ].
Qed.

Lemma RZ (R : ringType):
  ring_morph (R := R) 0 1 +%R *%R ~%R -%R eq
    0%Z 1%Z Zplus Zmult Zminus Z.opp Zeq_bool (@R_of_Z _).
Proof.
  split=> //=.
  + by move=> x y; rewrite rmorphD.
  + by move=> x y; rewrite rmorphB.
  + by move=> x y; rewrite rmorphM.
  + by move=> x; rewrite raddfN.
  + by move=> x y /Zeq_bool_eq ->.
Qed.

Lemma PN (R : ringType):
  @power_theory R 1 *%R eq nat nat_of_N (@GRing.exp R).
Proof.
  split=> r [|n] //=; elim: n => //= p ih.
  + by rewrite Pos2Nat.inj_xI exprS -!ih -exprD addnn -mul2n.
  + by rewrite Pos2Nat.inj_xO -!ih -exprD addnn -mul2n.
Qed.

Lemma RF (F : fieldType): @field_theory F 0 1 +%R *%R ~%R -%R /%R ^-1%R (@eq F).
Proof.
  split=> //=; first by apply RR.
  + by apply/eqP; rewrite oner_eq0.
  + by move=> x /eqP nz_z; rewrite mulVf.
Qed.

Definition Rcorrect (R : comRingType) :=
  ring_correct (Eqsth R) (RE R)
    (Rth_ARth (Eqsth R) (RE R) (RR R))
    (RZ R) (PN R)
    (triv_div_th
       (Eqsth R) (RE R)
       (Rth_ARth (Eqsth R) (RE R) (RR R)) (RZ R)).

Definition Fcorrect (F : fieldType) :=
  Field_correct
    (Eqsth F) (RE F) (congr1 GRing.inv)
    (F2AF (Eqsth F) (RE F) (RF F)) (RZ F) (PN F)
    (triv_div_th
       (Eqsth F) (RE F)
       (Rth_ARth (Eqsth F) (RE F) (RR F)) (RZ F)).

(* -------------------------------------------------------------------- *)
Fixpoint Reval (R : ringType) (l : seq R) (pe : PExpr Z) :=
  match pe with
  | 0%S           => 0
  | 1%S           => 1
  | (c%:S)%S      => R_of_Z c
  | ('X_j)%S      => BinList.nth 0 j l
  | (pe1 + pe2)%S => (Reval l pe1) + (Reval l pe2)
  | (pe1 - pe2)%S => (Reval l pe1) - (Reval l pe2)
  | (- pe1)%S     => - (Reval l pe1)
  | (pe1 ^+ n)%S  => (Reval l pe1) ^+ (nat_of_N n)
  | (pe1 * pe2)%S =>
      match pe2 with
      | ((Zpos n)%:S)%S => (Reval l pe1) *+ (nat_of_P n)
      | _               => (Reval l pe1) * (Reval l pe2)
      end
  end.

Local Notation RevalC R :=
  (PEeval 0 1 +%R *%R ~%R -%R (R_of_Z (R := R)) nat_of_N (@GRing.exp R)).

Lemma PEReval (R : ringType): RevalC _ =2 @Reval R.
Proof.
  move=> l; elim => //=; try by do? move=> ?->.
  + move=> pe1 -> pe2 ->; case: pe2 => //=.
    by case=> [|c|c] //=; rewrite mulr_natr.
Qed.

(* -------------------------------------------------------------------- *)
Fixpoint Feval (F : fieldType) (l : seq F) (pe : FExpr Z) :=
  match pe with
  | 0%F           => 0
  | 1%F           => 1
  | (c%:S)%F      => R_of_Z c
  | ('X_j)%F      => BinList.nth 0 j l
  | (pe1 + pe2)%F => (Feval l pe1) + (Feval l pe2)
  | (pe1 - pe2)%F => (Feval l pe1) - (Feval l pe2)
  | (- pe1)%F     => - (Feval l pe1)
  | (pe1 ^+ n)%F  => (Feval l pe1) ^+ (nat_of_N n)
  | (pe^-1)%F     => (Feval l pe)^-1
  | (pe1 / pe2)%F => (Feval l pe1) / (Feval l pe2)
  | (pe1 * pe2)%F =>
      match pe2 with
      | ((Zpos n)%:S)%F => (Feval l pe1) *+ (nat_of_P n)
      | _               => (Feval l pe1) * (Feval l pe2)
      end
  end.

Local Notation FevalC R :=
  (FEeval 0 1 +%R *%R ~%R -%R /%R ^-1%R
          (R_of_Z (R := R)) nat_of_N (@GRing.exp R)).

Lemma PEFeval (F : fieldType): FevalC _ =2 @Feval F.
Proof.
  move=> l; elim => //=; try by do? move=> ?->.
  + move=> pe1 -> pe2 ->; case: pe2 => //=.
    by case=> [|c|c] //=; rewrite mulr_natr.
Qed.

(* -------------------------------------------------------------------- *)
Ltac ssring :=
  let xt := fresh "xt" in
  let xe := fresh "xe" in
    apply/eqP; rewrite -subr_eq0; apply/eqP;
    reify xt xe;
    apply (@Rcorrect _ 100 xe [::] xt (Coq.setoid_ring.Ring_polynom.PEc 0%Z) I);
    vm_compute;exact (erefl true).

(* -------------------------------------------------------------------- *)
Ltac ssfield :=
  let xt := fresh "xt" in
  let xe := fresh "xe" in
    apply/eqP; rewrite -subr_eq0; apply/eqP;
      (* rewrite ?(mulr0, mul0r, mulr1, mul1r); *) freify xt xe;
      move: (@Fcorrect _ 100 xe [::] xt (Field_theory.FEc 0) I [::] (erefl [::]));
      move/(_ _ (erefl _) _ (erefl _) (erefl true)); rewrite !PEFeval;
      apply=> /=; do? split; cbv delta[BinPos.Pos.to_nat] => /= {xt xe};
      try (exact I || apply/eqP).