(**
Rainbow, a termination proof certification tool

See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2011-04-06

* CPF correctness checker top termination - Dependency pair proof

*)

Set Implicit Arguments.

Require Import ATrs SN ZArith EqUtil String List ListDec ListForall
  ListUtil ZUtil LogicUtil BoolUtil VecUtil NArith RelUtil RelMidex
  AMannaNess ARedPair2 ARelation NatUtil ADP ADuplicateSymb AMorphism
  ADecomp ADPUnif ACalls cpf2color cpf color_matrix_nat
  rainbow_top_termin SemiRing2 OrdSemiRing2 Matrix2 AMatrixInt2
  AMatrixBasedInt2_Nat AVarCond cpf_util cpf2color_interpret
  QArith_base NewPositivePolynom2 NewPolynom2 NewMonotonePolynom2
  APolyInt_MAQ2 NewAPolyInt2 poly_rat.

(***********************************************************************)
(** * Check that [is] is a valid termination proof for dependency pair
proof [hd_red_mod R D]. *)

Section Top_Termination.

  (***********************************************************************)
  (** Correctness proof of polynomial interpretation over different
  domain. *)

  Section poly.

    (** Polynomial interpretation over domain rational numbers with
     common proof. *)

    Lemma poly_rationals_dp_common_ok: forall a del (R D D': arules a) is
      (H:match polynomial_rationals_dp a is del with
           | Ok (bsucc_ge, bsucc_gt) =>
             if forallb (brule bsucc_ge) D && forallb (brule bsucc_ge) R
               then Ok (filter (brule (neg bsucc_gt)) D)
               else Ko (list (ATrs.rule (Sig a))) ERuleNotInLargeOrdering_dp
           | Ko e => Ko (list (ATrs.rule (Sig a))) e
         end = Ok D')(wf : WF (hd_red_mod R D')), WF (hd_red_mod R D).

    Proof.
      intros a del R D D' is h wf.
      case_eq (polynomial_rationals_dp a is del);
        intros p H; rewrite H in h; try discr.
      destruct p as [bge bgt].
      case_eq (forallb (brule bge) D && forallb (brule bge) R);
        intros H0; rewrite H0 in h; try discr.
      inversion h. subst D'. clear h.
      unfold polynomial_rationals_dp in H.
      case_eq (map_rev (color_interpret_polyQ a) is);
        intros l H1; rewrite H1 in H; try discr.
      gen H.
      set (b:= forallb (fun x : {f : symbol & Qpoly (a f)} =>
        let (f, p) := x in bcoef_not_neg p) l).
      case_eq b; intros H2 H3; subst b; try discr.
      inversion H3. clear H3.
      set (trsInt := (fun f: (Sig a) => fun_of_pairs_list_q a f l)).
      cut (forall f: (Sig a), Qpweak_monotone (trsInt f)).
      intros trsInt_wm. Focus 2.
      intro f. apply trsInt_wm. hyp.
      apply WF_wp_hd_red_mod with (bwp := poly_wrpQ a l H2 del).

      (** Check that all rules [R] are included in [>=]. *)

      simpl. unfold brule, bsucceq_ma, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge.
      rewrite andb_eq in H0. destruct H0.
      rewrite forallb_forall in H3. ded (H3 x Hx).
      destruct x as [t u]. simpl in *.
      case_eq (succeq'_dec (Sig a) (TPolyIntQ a l H2) t u);
        intros s Hs. auto. unfold abrule, ATrs.brule in H4.
      unfold succeq' in s. rewrite bcoef_not_neg_ok in H4.
      contradiction.

      (** Check that all rules [D = dp R] are included in [>=]. *)

      simpl. unfold brule, bsucceq_ma, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge.
      rewrite andb_eq in H0. destruct H0.
      rewrite forallb_forall in H0. ded (H0 x Hx).
      destruct x as [t u]. simpl in *.
      case_eq (succeq'_dec (Sig a) (TPolyIntQ a l H2) t u);
        intros s Hs. auto. unfold abrule, brule in H4.
      unfold succeq' in s. rewrite bcoef_not_neg_ok in H4.
      contradiction.

      (** Remove all rules [D] that are included in [>]. *)

      apply WF_incl with (S := hd_red_mod R (filter (abrule (neg bgt)) D)).
      unfold inclusion. intros t u H3. redtac.
      Focus 2. hyp. unfold hd_red_mod. unfold compose. exists t0.
      split. hyp.
      unfold hd_red. exists l0. exists r. exists s. intuition.
      apply filter_In. apply filter_In in lr. intuition. unfold brule, neg.
      unfold brule, neg in H7. simpl in *. unfold bsucc_ma, bool_of_rel in H7.
      simpl in *. destruct succ'_dec in H7.
      discr. unfold succ' in n. rewrite <- bcoef_not_neg_ok in n.
      apply eq_true_not_negb in n. subst bgt. apply n.
    Qed.

    (***********************************************************************)
    (** Polynomial interpretation over domain rational numbers. *)

    Lemma poly_rationals_dp_ok: forall a n (R D D': arules a) is
      (h: match type_poly_rationals_dp a n is with
            | Ok (bsucc_ge, bsucc_gt) =>
              if forallb (brule bsucc_ge) D && forallb (brule bsucc_ge) R
                then Ok (filter (brule (neg bsucc_gt)) D)
                else Ko (list (ATrs.rule (Sig a))) ERuleNotInLargeOrdering_dp
            | Ko e => Ko (list (ATrs.rule (Sig a))) e
          end = Ok D') (wf : WF (hd_red_mod R D')), WF (hd_red_mod R D).

    Proof.
      intros a n R D D' is h wf.
      unfold type_poly_rationals_dp in h.
      destruct n; simpl in h; try discr.

      (** In the case of rationals -> natural numbers, where it convert a
       natural number to rational number by divide by 1. *)

      set (del:= inject_Z i).
      fold del in h.
      apply poly_rationals_dp_common_ok with (is:=is)(del:=del)(D':=D').
      hyp. hyp.

      (** In the case of rationals -> rational numbers. *)

      set (t := Qmake i p). fold t in h.
      apply poly_rationals_dp_common_ok with (is:=is)(del:=t)(D':=D').
      hyp. hyp.
    Qed.

    (***********************************************************************)
    (** Polynomial interpretation over natural numbers. *)

    Require Import Polynom PositivePolynom APolyInt_MA2 poly APolyInt
      MonotonePolynom.

    Lemma poly_naturals_dp_ok : forall a (R D D': arules a) is
      (h:  match polynomial_naturals_dp a is with
             | Ok (bsucc_ge, bsucc_gt) =>
               if forallb (brule bsucc_ge) D && forallb (brule bsucc_ge) R
                 then Ok (filter (brule (neg bsucc_gt)) D)
                 else Ko (list (ATrs.rule (Sig a))) ERuleNotInLargeOrdering_dp
             | Ko e => Ko (list (ATrs.rule (Sig a))) e
           end = Ok D') (wf: WF (hd_red_mod R D')), WF (hd_red_mod R D).

    Proof.
      intros a R D D' is h wf.
      case_eq (polynomial_naturals_dp a is);
        intros p H; rewrite H in h; try discr.
      destruct p as [bge bgt].
      case_eq (forallb (ATrs.brule bge) D && forallb (ATrs.brule bge) R);
        intros H0; rewrite H0 in h; try discr.
      inversion h. subst D'. clear h.
      unfold polynomial_naturals_dp in H.
      case_eq (map_rev (color_interpret_poly a) is);
        intros l H1; rewrite H1 in H; try discr.
      gen H. set (b := forallb (fun x : {f : symbol & poly (a f)} =>
      let (f, p) := x in bcoef_pos p) l).
      case_eq b; intros H2 H3; subst b; try discr.
      inversion H3. clear H3.
      set (trsInt := (fun f: (Sig a) => fun_of_pairs_list a f l)).
      cut (forall f: (Sig a), pweak_monotone (trsInt f)).
      intros trsInt_wm. Focus 2.
      intro f. apply trsInt_wm. hyp.
      apply WF_wp_hd_red_mod with (bwp := poly_wrp a l H2).

      (** Check that all rules [R] are included in [>=]. *)

      simpl. unfold ATrs.brule, bsucceq_ma, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge.
      rewrite andb_eq in H0. destruct H0.
      rewrite forallb_forall in H3. ded (H3 x Hx).
      destruct x as [t u]. simpl in *.
      case_eq (APolyInt_MA2.succeq'_dec (Sig a) (TPolyInt a l H2) t u);
        intros s Hs. auto. unfold abrule, ATrs.brule in H4.
      unfold APolyInt_MA2.succeq' in s. rewrite bcoef_pos_ok in H4.
      contradiction.

      (** Check that all rules [D = dp R] are included in [>=]. *)

      simpl. unfold ATrs.brule, bsucceq_ma, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge. rewrite andb_eq in H0.
      destruct H0. rewrite forallb_forall in H0. ded (H0 x Hx).
      destruct x as [t u]. simpl in *.
      case_eq (APolyInt_MA2.succeq'_dec (Sig a) (TPolyInt a l H2) t u);
        intros s Hs. auto. unfold abrule, ATrs.brule in H4.
      unfold APolyInt_MA2.succeq' in s. rewrite bcoef_pos_ok in H4.
      contradiction.

      (** Remove all rules [D] that are included in [>]. *)

      apply WF_incl with (S := hd_red_mod R (filter (abrule (neg bgt)) D)).
      unfold inclusion. intros t u H3. redtac.
      Focus 2. hyp. unfold hd_red_mod. unfold compose. exists t0.
      split. hyp.
      unfold hd_red. exists l0. exists r. exists s. intuition.
      apply filter_In. apply filter_In in lr. intuition. unfold ATrs.brule, neg.
      unfold ATrs.brule, neg in H7. simpl in *. unfold bsucc_ma, bool_of_rel in H7.
      simpl in *. destruct (APolyInt_MA2.succ'_dec) in H7.
      discr. unfold APolyInt_MA2.succ' in n. rewrite <- bcoef_pos_ok in n.
      apply eq_true_not_negb in n. subst bgt. apply n.
    Qed.

    (***********************************************************************)
    (** Polynomial interpretation over natural numbers and rational
     numbers. *)

    Lemma polynomial_interpretation_dp_ok: forall a (R D D': arules a)
      is (d:domain) (h: polynomial_interpretation_dp R D is d = Ok
        D') (wf : WF (hd_red_mod R D')), WF (hd_red_mod R D).

    Proof.
      intros a R D D' is d h wf.
      unfold polynomial_interpretation_dp in h. destruct d; simpl in h;
      try discr.

      (** Polynomial interpretation over natural numbers. *)

      apply poly_naturals_dp_ok with (D':=D')(is:=is).
      apply h. apply wf.

      (** Polynomial interpretation over rational numbers. *)

      apply poly_rationals_dp_ok with (n:=n)(D':=D')(is:=is).
      apply h. apply wf.
    Qed.

  End poly.

  (***********************************************************************)
  (** Matrix interpretation over different domains. *)

  Section matrix.

    (** Matrix interpretation over natural numbers. *)

    Lemma matrix_interpretation_nat_dp_ok : forall a (R D D': arules a)
      (d:dimension) is (h: matrix_interpretation_dp R D is Domain_naturals
        (Pos.to_nat d) = Ok D') (wf : WF (hd_red_mod R D')), WF
      (hd_red_mod R D).

    Proof.
      intros a R D D' d is h wf.
      unfold matrix_interpretation_dp in h.
      destruct Domain_naturals; simpl in h; try discr.
      case_eq (type_matrix_naturals_dp a is (Pos.to_nat d));
        intros p H; rewrite H in h; try discr.
      destruct p as [bge bgt].
      case_eq (forallb (abrule bge) D && forallb (abrule bge) R);
        intro H0; rewrite H0 in h; try discr.
      inversion h. subst D'. clear h. unfold type_matrix_naturals_dp in H.
      case_eq (map_rev (color_interpret_matrix a (Pos.to_nat d)) is);
        intros l H1; rewrite H1 in H; try discr. gen H.
      set (b := forallb (fun x : {f : symbol &
        matrixInt matrix (Pos.to_nat d) (a f)} =>
      let (f, mi) := x in bVforall (fun m : matrix (Pos.to_nat
        d) (Pos.to_nat d) => bge_nat (get_elem m (dim_pos (Pos.to_nat
          d)) (dim_pos (Pos.to_nat d))) 0) (args mi)) l). case_eq b;
      intros H2 H3; subst b; try discr.
      inversion H3. clear H3.
      apply WF_wp_hd_red_mod with (bwp := matrix_wrp a l).

      (** Check that rules [R] is included in [>=]. *)

      unfold ATrs.brule, bsucceq, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge.
      rewrite andb_eq in H0. destruct H0.
      rewrite forallb_forall in H3.
      ded (H3 x Hx). destruct x as [t u]. simpl in *.
      unfold bsucceq_ma, bool_of_rel.
      case_eq (AMonAlg2.succeq'_dec (Sig a) (Matrix_MonoAlgType a l) t u);
        intros ss Hs; auto. unfold abrule, ATrs.brule in H4. simpl in *.
      unfold AMatrixInt2.succeq', succeq', term_ge, term_ord, mint_ge in ss.
      apply bmint_ge_ok in H4. contradiction.

      (** Check that rules [D = dp R] is included in [>=]. *)

      unfold ATrs.brule, bsucceq, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge.
      rewrite andb_eq in H0. destruct H0.
      rewrite forallb_forall in H0.
      ded (H0 x Hx). destruct x as [t u]. simpl in *.
      unfold bsucceq_ma, bool_of_rel.
      case_eq (AMonAlg2.succeq'_dec (Sig a) (Matrix_MonoAlgType a l) t u);
        intros ss Hs; auto. unfold abrule, ATrs.brule in H4.
      simpl in *. unfold AMatrixInt2.succeq', succeq',
      term_ge, term_ord, mint_ge in ss.
      apply bmint_ge_ok in H4. contradiction.

      (** Remove all rules [>] in [D]. *)

      apply WF_incl with (S := hd_red_mod R (filter (abrule (neg bgt)) D)).
      unfold inclusion. intros t u H3. redtac.
      unfold hd_red_mod. unfold compose. exists t0. split. hyp.
      unfold hd_red. exists l0. exists r. exists s.
      intuition. apply filter_In. apply filter_In in lr. intuition.
      unfold ATrs.brule, neg. unfold ATrs.brule, neg in H7. simpl in *.
      unfold bsucc_ma, bool_of_rel in H7.
      destruct AMonAlg2.succ'_dec in H7; try discr.
      simpl in *. unfold AMatrixInt2.succ' in n.
      unfold AMatrixInt2.term_gt, term_gt, term_ord in n.
      simpl in *. unfold mint_gt in n.
      rewrite <- bmint_gt_ok in n. apply eq_true_not_negb in n.
      subst bgt. apply n. hyp.
    Qed.

    (***********************************************************************)
    (** Matrix interpretation over arctic natural numbers. *)

    Require Import color_matrix_arctic_nat AMatrixBasedInt2_ArcticNat.

    (* FIXME: is there something wrong with the [map] function? *)

    Lemma matrix_interpretation_arcnat_dp_ok : forall a (R D D': arules
      a) (d:dimension) is (h: matrix_arc_interpretation_dp R D is
        Domain_naturals (Pos.to_nat d) = Ok D') (wf : WF (hd_red_mod R D')),
      WF (hd_red_mod R D).

    Proof.
      intros a R D D' d is h wf.
      unfold matrix_arc_interpretation_dp in h.
      destruct Domain_naturals; simpl in h; try discr.
      case_eq (type_matrix_arc_naturals_dp a is (Pos.to_nat d)); intros p H;
        rewrite H in h; try discr.
      destruct p as [bge bgt].
      case_eq (forallb (abrule bge) D && forallb (abrule bge) R);
        intro H0; rewrite H0 in h; try discr.
      inversion h. subst D'. clear h.
      unfold type_matrix_arc_naturals_dp in H.
      case_eq (map_rev (color_matrix_arc_interpret a (Pos.to_nat d)) is);
        intros l H1; rewrite H1 in H; try discr. gen H.
      set (b := forallb (fun x : {f : symbol & matrixInt_arcnat
        matrix_arcnat (Pos.to_nat d) (a f)} => let (f, mi) := x in
      bVexists (fun m : matrix_arcnat (Pos.to_nat d) (Pos.to_nat
        d) => is_finite (get_elem_arcnat m (dim_pos (Pos.to_nat d))
          (dim_pos (Pos.to_nat d)))) (args_arcnat mi) || is_finite
      (Vnth (const_arcnat mi) (dim_pos (Pos.to_nat d)))) l).
      case_eq b; intros H2 H3; subst b; try discr. inversion H3.
      clear H3.
      apply WF_wp_hd_red_mod with (bwp := matrix_arcnat_wrp a l).

      (** Check that rules [R] is included in [>=]. *)

      unfold ATrs.brule, bsucceq, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge.
      rewrite andb_eq in H0. destruct H0.
      rewrite forallb_forall in H3.
      ded (H3 x Hx). destruct x as [t u]. simpl in *.
      unfold bsucceq_ma, bool_of_rel.
      case_eq (AMonAlg2.succeq'_dec (Sig a)(MatrixArcnat_MonoAlgType a l) t u);
      intros ss Hs; auto.
      unfold abrule, ATrs.brule in H4.
      simpl in *. unfold AArcticInt2.succeq', succeq_arcnat',
      term_ge_arcnat, term_ord_arcnat, mint_ge_arcnat in ss.
      apply bmint_arc_ge_ok in H4. contradiction.

      (** Check that rules [D = dp R] is included in [>=]. *)

      unfold ATrs.brule, bsucceq, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge.
      rewrite andb_eq in H0. destruct H0.
      rewrite forallb_forall in H0.
      ded (H0 x Hx). destruct x as [t u]. simpl in *.
      unfold bsucceq_ma, bool_of_rel.
      case_eq (AMonAlg2.succeq'_dec (Sig a)
        (MatrixArcnat_MonoAlgType a l) t u);
      intros ss Hs; auto. unfold abrule, ATrs.brule in H4.
      simpl in *. unfold AArcticInt2.succeq', succeq_arcnat',
      term_ge_arcnat, term_ord_arcnat, mint_ge_arcnat in ss.
      apply bmint_arc_ge_ok in H4. contradiction.

      (** Remove all rules [>] in [D]. *)

      apply WF_incl with (S := hd_red_mod R (filter (abrule (neg bgt)) D)).
      unfold inclusion. intros t u H3. redtac.
      unfold hd_red_mod. unfold compose. exists t0. split. hyp.
      unfold hd_red. exists l0. exists r. exists s. intuition.
      apply filter_In. apply filter_In in lr. intuition.
      unfold ATrs.brule, neg. unfold ATrs.brule, neg in H7. simpl in *.
      unfold bsucc_ma, bool_of_rel in H7.
      destruct AMonAlg2.succ'_dec in H7; try discr.
      simpl in *. unfold AArcticInt2.succ' in n.
      unfold AArcticBasedInt2.succ', AArcticBasedInt2.term_gt,
        term_ord_arcnat in n.
      simpl in *. unfold AArcticBasedInt2.mint_gt in n.
      rewrite <- bmint_arc_gt_ok in n. apply eq_true_not_negb in n.
      subst bgt. apply n. hyp.
    Qed.

    (***********************************************************************)
    (* REMARK: Relative matrix interpretation over arctic natural
    numbers. There is no arctic domains (natural and integer) in matrix
    interpretation of relative relation.*)

    (** REMARK: By Lemma 2.17 in Adam's thesis, Every arctic linear f
    over A is monotone with respect to [>=]. *)

   (***********************************************************************)
    (** Matrix interpretation over arctic integer numbers (below-zero). *)

    Require Import color_matrix_arctic_below_zero AMatrixBasedInt2_ArcticBZ.

    Lemma matrix_interpretation_arcbz_dp_ok : forall a (R D D': arules
      a) (d: dimension) is (h: matrix_arcbz_interpretation_dp R D is
        Domain_integers (Pos.to_nat d) = Ok D') (wf: WF (hd_red_mod R
          D')), WF (hd_red_mod R D).

    Proof.
      intros a R D D' d is h wf.
      unfold matrix_arcbz_interpretation_dp in h.
      destruct Domain_integers; simpl in h; try discr.
      case_eq (type_matrix_arcbz_integers_dp a is (Pos.to_nat d));
        intros p H;
          rewrite H in h; try discr.
      destruct p as [bge bgt].
      case_eq (forallb (abrule bge) D && forallb (abrule bge) R);
        intro H0; rewrite H0 in h; try discr.
      inversion h. subst D'. clear h.
      unfold type_matrix_arcbz_integers_dp in H.
      case_eq (map_rev (color_matrix_arcbz_interpret a (Pos.to_nat d)) is);
        intros l H1; rewrite H1 in H; try discr. gen H.
      set (b := forallb (fun x : {f : symbol & matrixInt_arcbz
        matrix_arcbz (Pos.to_nat d) (a f)} => let (f, mi) := x in
      is_above_zero (Vnth (const_arcbz mi) (dim_pos (Pos.to_nat d))))
      l). case_eq b; intros H2 H3; subst b; try discr. inversion H3.
      clear H3.
      apply WF_wp_hd_red_mod with (bwp := matrix_arcbz_wrp a l).

      (** Check that rules [R] is included in [>=]. *)

      unfold ATrs.brule, bsucceq, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge.
      rewrite andb_eq in H0. destruct H0.
      rewrite forallb_forall in H3.
      ded (H3 x Hx). destruct x as [t u]. simpl in *.
      unfold bsucceq_ma, bool_of_rel.
      case_eq (AMonAlg2.succeq'_dec (Sig a)
        (MatrixArcbz_MonoAlgType a l) t u);
      intros ss Hs; auto.
      unfold abrule, ATrs.brule in H4.
      simpl in *. unfold succeq', succeq_arcbz',
      term_ge_arcbz, term_ord_arcbz, mint_ge_arcbz in ss.
      apply bmint_arc_bz_ge_ok in H4. contradiction.

      (** Check that rules [D = dp R] is included in [>=]. *)

      unfold ATrs.brule, bsucceq, bool_of_rel; simpl.
      rewrite forallb_forall. intros x Hx. subst bge.
      rewrite andb_eq in H0. destruct H0.
      rewrite forallb_forall in H0.
      ded (H0 x Hx). destruct x as [t u]. simpl in *.
      unfold bsucceq_ma, bool_of_rel.
      case_eq (AMonAlg2.succeq'_dec (Sig a)
        (MatrixArcbz_MonoAlgType a l) t u);
      intros ss Hs; auto. unfold abrule, ATrs.brule in H4.
      simpl in *. unfold succeq', succeq_arcbz',
      term_ge_arcbz, term_ord_arcbz, mint_ge_arcbz in ss.
      apply bmint_arc_bz_ge_ok in H4. contradiction.

      (** Remove all rules [>] in [D]. *)

      apply WF_incl with (S := hd_red_mod R (filter (abrule (neg bgt)) D)).
      unfold inclusion. intros t u H3. redtac.
      unfold hd_red_mod. unfold compose. exists t0. split. hyp.
      unfold hd_red. exists l0. exists r. exists s.
      intuition. apply filter_In. apply filter_In in lr. intuition.
      unfold ATrs.brule, neg. unfold ATrs.brule, neg in H7. simpl in *.
      unfold bsucc_ma, bool_of_rel in H7.
      destruct AMonAlg2.succ'_dec in H7; try discr.
      simpl in *. unfold AArcticBZInt2.succ' in n.
      unfold AArcticBasedInt2.succ'bz, AArcticBasedInt2.term_gtbz,
        term_ord_arcbz in n.
      simpl in *. unfold AArcticBasedInt2.mint_gtbz in n.
      rewrite <- bmint_arc_bz_gt_ok in n. apply eq_true_not_negb in n.
      subst bgt. apply n. hyp.
    Qed.

    (* REMARK: There is no arctic domains (natural and integer) in
        matrix interpretation of relative relation. *)

  End matrix.

  (***********************************************************************)
  (** Correctness proof of reduction pair interpretation in the case of
  top termination problems. *)

  Lemma redPair_interpretation_dp_ok : forall a (R D D' : arules a) t is,
    redPair_interpretation_dp R D t is = Ok D' -> WF (hd_red_mod R D')
    -> WF (hd_red_mod R D).

  Proof.
    intros a R D D' t is h wf. destruct t; simpl in h; try discr.

    (** Polynomial interpretation over natural numbers and rational
    numbers. *)

    apply polynomial_interpretation_dp_ok with (D':=D')(is:=is)(d:=d).
    apply h. apply wf.

    (** Matrix interpretation over natural numbers. *)

    destruct d; simpl in h; try discr.
    apply matrix_interpretation_nat_dp_ok with (D':=D')(d:=d0)(is:=is).
    apply h. apply wf.

    (** Matrix interpretation over arctic natural numbers.  *)

    destruct d; simpl in h; try discr.
    apply matrix_interpretation_arcnat_dp_ok with (D':=D')(d:=d0)(is:=is).
    apply h. apply wf.

    (** Matrix interpretation over arctic integer numbers. *)

    apply matrix_interpretation_arcbz_dp_ok with (D':=D')(d:=d0)(is:=is).
    apply h. apply wf.
  Qed.

  (***********************************************************************)
  (** Correctness proof of path ordering the case of top termination
  problems. *)

  Variable bb : nat.

  Require Import Coccinelle2 ordered_set rpo2 cpf2color_rpo.

  (* RPO without Argument filtering method. *)

  Lemma rpo_without_af_dp_ok: forall a (R D D': arules a) l
      (h: match pathOrder_term_dp bb a l with
      | Ok (bsucc_ge, bsucc_gt) =>
          if forallb (abrule bsucc_ge) D && forallb (abrule bsucc_ge) R
          then Ok (filter (abrule (neg bsucc_gt)) D)
          else Ko (arules a) ENotpathOrder_dp
      | Ko e => Ko (arules a) e
      end = Ok D')(wf : WF(hd_red_mod R D')), WF(hd_red_mod R D).

  Proof.
    intros a R D D' l h wf.
    case_eq (pathOrder_term_dp bb a l); intros p H;
      rewrite H in h; try discr.
    destruct p as [bge bgt].
    case_eq (forallb (abrule bge) D && forallb (abrule bge) R);
      intros H1; rewrite H1 in h; try discr.
    inversion h. subst D'. clear h.
    unfold pathOrder_term_dp in H.
    gen H.
    set (b:= forallb (fun f : Sig a =>
      forallb (fun g : Sig a => bprec_eq_status_symb l f g) (list_sig l))
    (list_sig l)).
    case_eq b; intros; subst b; try discr.
    inversion H2. clear H2.

    apply WF_wp_hd_red_mod2 with (bwp := bwrp_rpo bb (P a l bb)).

    (** Check that all rules [R] are included in [>=] *)

    simpl. unfold brule, bsucceq_rpo; simpl.
    rewrite forallb_forall. intros x Hx. subst bge.
    rewrite andb_eq in H1. destruct H1.
    rewrite forallb_forall in H2.
    ded (H2 x Hx).
    destruct x as [t u]. simpl in *.
    unfold abrule in H3. apply H3.

    (** Check that all rules in [D = dp R] are included in [>=]. *)

    simpl. unfold brule, bsucceq_rpo; simpl.
    rewrite forallb_forall. intros x Hx. subst bge.
    rewrite andb_eq in H1. destruct H1.
    rewrite forallb_forall in H1.
    ded (H1 x Hx).
    destruct x as [t u].
    simpl in *.
    unfold brule in H3. apply H3.

    (** Remove all rules [D] that are included in [>]. *)

    apply WF_incl with (S:= hd_red_mod R (filter (brule (neg bgt)) D)).
    unfold inclusion. intros t u H3. redtac.
    Focus 2. hyp.
    unfold hd_red_mod. unfold compose.
    exists t0. split. hyp.
    unfold hd_red. exists l0. exists r.
    exists s. intuition.
    apply filter_In. apply filter_In in lr. intuition.
    unfold brule, neg. unfold brule, neg in H6.
    simpl in *. subst bgt.
    apply H6.
  Qed.

  (***********************************************************************)
  (** RPO with argument filtering method. *)

  Require Import cpf2color_argfilter.

  Lemma rpo_with_af_dp_ok: forall a (R D D': arules a) l o
    (h:match pathOrder_term_rpo_af_dp bb a l o with
         | Ok (bsucc_ge, bsucc_gt) =>
           if forallb (abrule bsucc_ge) D && forallb (abrule bsucc_ge) R
             then Ok (filter (abrule (neg bsucc_gt)) D)
             else Ko (arules a) ENotpathOrder_AF_dp
         | Ko e => Ko (arules a) e
       end = Ok D') (wf: WF (hd_red_mod R D')), WF (hd_red_mod R D).

  Proof.
    intros a R D D' l oaf h wf.
    case_eq (pathOrder_term_rpo_af_dp bb a l oaf);
      intros p H; rewrite H in h; try discr.
    destruct p as [bge bgt].
    case_eq (forallb (abrule bge) D && (forallb (abrule bge) R));
      intros H1; rewrite H1 in h; try discr.
    inversion h. subst D'. clear h.
    unfold pathOrder_term_rpo_af_dp in H.
    destruct oaf; try discr.

    destruct p; try discr.
    destruct p; try discr.

    (** Argument filtering method. *)

    case_eq (is_col_noncol t); intros H2; rewrite H2 in H; try discr.
    set (ls:=(s,a0,t)::oaf). fold ls in H.
    case_eq (pathOrder_rpo_proj_filter_dp bb a l ls); intros p H3;
      rewrite H3 in H; try discr.
    inversion H. clear H. subst p.
    unfold pathOrder_rpo_proj_filter_dp in H3.
    gen H3.
    set (b:=forallb
      (fun f : Sig a =>
        forallb (fun g : Sig a => bprec_eq_status_symb l f g) (list_sig l))
      (list_sig l)).
    case_eq b; intros; subst b; try discr.
    inversion H0. clear H0.

    apply WF_wp_hd_red_mod with (bwp:= @bwrp_perm2 (Sig a)
    (color_Perm ls a)
    (@bwrp_proj (Sig (@ASignature.arity (color_Sig_perm ls a)))
    (@color_Proj ls (@ASignature.arity (color_Sig_perm ls a)))
    (Coccinelle2.bwrp_rpo bb (P (@ASignature.arity (color_Sig_perm ls a)) l bb)))).

    (** Check that all rules [R] are included in [>=] *)

    simpl. unfold brule, bsucceq_rpo; simpl.
    rewrite forallb_forall. intros x Hx. subst bge.
    rewrite andb_eq in H1. destruct H1.
    rewrite forallb_forall in H1.
    ded (H1 x Hx).
    destruct x as [u v]. simpl in *.
    unfold abrule in H4. apply H4.

    (** Check that all rules in [D = dp R] are included in [>=]. *)

    simpl. unfold brule, bsucceq_rpo; simpl.
    rewrite forallb_forall. intros x Hx. subst bge.
    rewrite andb_eq in H1. destruct H1.
    rewrite forallb_forall in H0.
    ded (H0 x Hx).
    destruct x as [u v].
    simpl in *.
    unfold brule in H4. apply H4.

    (** Remove all rules [D] that are included in [>]. *)

    apply WF_incl with (S:= hd_red_mod R (List.filter (brule (neg bgt)) D)).
    unfold inclusion. intros u v H7. redtac.
    Focus 2. hyp.
    unfold hd_red_mod. unfold compose.
    exists t0. split. hyp.
    unfold hd_red. exists l0. exists r.
    exists s0. intuition.
    apply filter_In. apply filter_In in lr. intuition.
    unfold brule, neg. unfold brule, neg in H7.
    simpl in *. subst bgt.
    apply H7.
  Qed.

  (***********************************************************************)
  (** Correctness proof of RPO with/without argument filtering method
     in the case of DP.*)

  Lemma pathOrder_dp_ok : forall a (R D D': arules a) l o,
    pathOrder_dp bb R D l o = Ok D' -> WF (hd_red_mod R D') ->
    WF (hd_red_mod R D).

  Proof.
    intros a R D D' l oaf h wf.
    unfold pathOrder_dp in h.
    destruct oaf; try discr.

    (** Path ordering with argument filtering. *)

    apply rpo_with_af_dp_ok with (D':=D')(l:=l)(o:=a0).
    hyp. hyp.

    (** Path ordering without argument filtering. *)

    apply rpo_without_af_dp_ok with (D':=D')(l:=l).
    hyp. hyp.
  Qed.

  (***********************************************************************)
  (** ** Check that [dps] is valid termination proof for dependency
  pair proof [hd_red_mod R D]. *)

  (** [nat_of_string]: convert variable map to natural number *)

  Variable nat_of_string: string -> nat.

  Lemma unit_ok : forall u, Ok u = OK.

  Proof.
    induction u. unfold OK. unfold Zero. refl.
  Qed.

  Lemma dpProof_pIsEmpty_ok : forall a (R D: arules a),
    dpProof_pIsEmpty D = OK -> WF (hd_red_mod R D).

  Proof.
    intros a R D. unfold dpProof_pIsEmpty. destruct D; simpl; intro.
    apply WF_hd_red_mod_empty. discr.
  Qed.

  (***********************************************************************)
  (** Correctness proof of dependency pairs. *)

  Require Import AProj AFilterPerm.

  Lemma dpProof_ok : forall n a (R D: arules a) dps,
    dpProof bb nat_of_string n R D dps = OK -> WF (hd_red_mod R D)
    with
    AF_ok : forall n a (R D : arules a) a0 dps,
     AF_dp bb nat_of_string n R D a0 dps = OK -> WF (hd_red_mod R D)
    with
      dpProof_depGraphProc_ok: forall n a (R D: arules a) cs,
        depGraphProc bb nat_of_string n R D cs = OK -> WF (hd_red_mod R D).

  Proof.
    induction n; try discr; simpl in *.

    (** Correctness proof by using dependency pair. *)

    destruct dps; try discr.

    (** Correctness proof when the dependency pair (D) is empty. *)

    intros H. apply dpProof_pIsEmpty_ok. hyp.

    (** Correctness proof of rule removal in the case of dependency
    pair method. *)

    Focus 2. destruct o; simpl in *; try discr.
    unfold trsTerminationProof_ruleRemoval_dp.
    destruct o0; simpl in *; try discr.
    unfold orderingConstraintProof_redPair_dp.
    destruct r; simpl in *; try discr.
    case_eq (redPair_interpretation_dp R D t l);
      intros l0 H1 H2; try discr.
    apply redPair_interpretation_dp_ok in H1. hyp.
    eapply dpProof_ok.
    apply H2.

    (** Correctness proof of path ordering. *)

    case_eq (pathOrder_dp bb R D l o);
      intros l0 H1 H2; try discr.
    apply pathOrder_dp_ok in H1. hyp.
    eapply dpProof_ok. apply H2.

    (** Decomposition graph. *)

    destruct n; try discr; simpl in *.
    case_eq (forallb (is_notvar_lhs (Sig:=Sig a)) R &&
      forallb (undefined_rhs R) D && brules_preserve_vars D);
    intros H1; try discr.
    case_eq (decomp nat_of_string a l); intros l0 H2; try discr.
    set (l1:= split_list l0).
    case_eq (equiv_rules (flat l1) D); intros H4; try discr.
    set (approx:= dpg_unif_N (S n) R D).
    case_eq (valid_decomp approx l1); intros H5; try discr.
    case_eq (forallb
      (fun ci : arules a * bool * option (list positiveInteger) *
        option cpf.dpProof =>
          match ci with
            | (dps, true, _, Some pi) => bool_of_result
              (dpProof bb nat_of_string n R dps pi)
            | (dps, true, _, None) => false
            | (dps, false, _, _) => co_scc approx dps
          end) l0); intros H6 H7; try discr.

    eapply WF_decomp_co_scc with (approx:=approx)(cs:=l1).

    (** Over graph using a finite number of unification steps. *)

    apply dpg_unif_N_correct.

    (** [hypR: forallb (@is_notvar_lhs Sig) R = true]. *)

    do 2 rewrite andb_eq in H1. intuition.

    (** [hypD: forallb (undefined_rhs R) D = true]. *)

    do 2 rewrite andb_eq in H1. intuition.

    (** [hypD: rules_preserve_vars D]. *)

    do 2 rewrite andb_eq in H1. intuition.
    apply brules_preserve_vars_ok. hyp.

    (** [hyp4: D [= flat cs]. *)

    unfold equiv_rules in H4. rewrite equiv_ok in H4. apply H4.
    intros r1 r2. split. intros.
    rewrite ATrs.beq_rule_ok in H. hyp.
    intros. apply ATrs.beq_rule_ok. hyp.

    (** [hyp1: flat cs [= D] *)

    unfold equiv_rules in H4. apply equiv_ok in H4. apply H4.
    intros r1 r2. split. intros.
    rewrite ATrs.beq_rule_ok in H. hyp. intros.
    apply ATrs.beq_rule_ok. hyp.

    (** [hyp2 : valid_decomp cs = true] *)

    hyp.

    (** [hyp3 : lforall (fun ci => co_scc ci = true \/ WF (hd_red_Mod
    S ci)) cs] *)

    clear H2 H4 H5 H7. induction l0; simpl in *; try auto.
    split. Focus 2.
    apply IHl0. rewrite andb_eq in H6. destruct H6.
    apply H0. rewrite andb_eq in H6.
    destruct H6. destruct a0; try discr; simpl in *.
    do 2 destruct p; try discr. destruct b; try discr.
    destruct o; try discr. right.
    unfold bool_of_result in H.
    case_eq (dpProof bb nat_of_string n R l2 d); intros u Hdp;
      rewrite Hdp in H; try discr.
    eapply dpProof_ok. erewrite <- unit_ok. apply Hdp.
    left. apply H. Focus 4.

    (** Correctness of depGraphProc. *)

    induction n; simpl in *; try discr; auto.
    intros a R D cs.
    case_eq (forallb (is_notvar_lhs (Sig:=Sig a)) R &&
      forallb (undefined_rhs R) D &&
      brules_preserve_vars D); intros H1; try discr.
    case_eq (decomp nat_of_string a cs); intros l H2; try discr.
    case_eq (equiv_rules (flat (split_list l)) D); intros H3; try discr.
    case_eq (valid_decomp (dpg_unif_N (S n) R D) (split_list l));
      intros H4; try discr.
    case_eq (forallb
      (fun
        ci : arules a * bool * option (list positiveInteger) *
        option cpf.dpProof =>
          match ci with
            | (dps, true, _, Some pi) => bool_of_result
                  (dpProof bb nat_of_string n R dps pi)
            | (dps, true, _, None) => false
            | (dps, false, _, _) => co_scc (dpg_unif_N (S n) R D) dps
          end) l); intros H5 H6; try discr.
    clear H6.

    eapply WF_decomp_co_scc.

    (** Over graph using a finite number of unification steps. *)

    apply dpg_unif_N_correct.

    (** [hypR: forallb (@is_notvar_lhs Sig) R = true] *)

    do 2 rewrite andb_eq in H1. intuition.

    (** [hypD: forallb (undefined_rhs R) D = true] *)

    do 2 rewrite andb_eq in H1. intuition.

    (** [hypD: rules_preserve_vars D] *)

    do 2 rewrite andb_eq in H1. intuition.
    apply brules_preserve_vars_ok. hyp.

    (** [hyp4: D [= flat cs] *)

    unfold equiv_rules in H3. rewrite equiv_ok in H3. apply H3.
    intros r1 r2. split. intros.
    rewrite ATrs.beq_rule_ok in H. hyp. intros.
    apply ATrs.beq_rule_ok. hyp.

    (** [hyp1: flat cs [= D] *)

    unfold equiv_rules in H3. apply equiv_ok in H3. apply H3.
    intros r1 r2. split. intros. rewrite ATrs.beq_rule_ok in H. hyp.
    intros. apply ATrs.beq_rule_ok. hyp.

    (** [hyp2 : valid_decomp cs = true] *)

    try apply H4.

    (** [hyp3 : lforall (fun ci => co_scc ci = true
       \/ WF (hd_red_Mod S ci)) cs] *)

    clear H2 H3 H4. induction l; simpl in *; try auto.
    split. Focus 2. apply IHl. rewrite andb_eq in H5.
    destruct H5. apply H0. rewrite andb_eq in H5. destruct H5.
    destruct a0; try discr. do 2 destruct p; try discr.
    destruct b; try discr. destruct o; try discr. right.
    unfold bool_of_result in H.
    case_eq (dpProof bb nat_of_string n R l0 d); intros u Hdp;
      rewrite Hdp in H; try discr.
    eapply dpProof_ok. erewrite <- unit_ok. apply Hdp.
    left. apply H.

    (** monoRedPairProc *)

    destruct o; simpl in *; try discr.
    unfold trsTerminationProof_ruleRemoval_dp.
    destruct o0; simpl in *; try discr.
    unfold orderingConstraintProof_redPair_dp.
    destruct r; simpl in *; try discr.

    (** Reduction pair interpretation in DP. *)

    case_eq (redPair_interpretation_dp R D t0 l);
      intros l0 H1 H2; try discr.
    apply redPair_interpretation_dp_ok in H1. hyp.
    eapply dpProof_ok. apply H2.

    (** Path ordering in DP. *)

    case_eq (pathOrder_dp bb R D l o); intros l0 H1 H2; try discr.
    apply pathOrder_dp_ok in H1. hyp.
    eapply dpProof_ok. apply H2.

    (** Argument filtering in dependency pair. *)

    destruct n; try discr; simpl in *.
    destruct a0; try discr.
    destruct p; try discr.
    destruct p; try discr.

    (** In the case it is a collapsing. *)

    case_eq (is_collapsing t0); intros H H0; try discr.
    eapply WF_hd_red_mod_proj.
    apply dpProof_ok in H0.
    unfold color_proj_rules, color_pi_proj in H0.
    apply H0.

    (** In the case it is not a collapsing. *)

    revert H0.
    case_eq (is_noncollapsing t0 && bnon_dup (Sig a)
         (color_raw_pi_filter a ((s, a1, t0) :: a0))
         (list_split_triple ((s, a1, t0) :: a0)));
      intros H1 H0; try discr.
    rewrite andb_eq in H1. destruct H1.
    apply dpProof_ok in H0.
    unfold color_filter_rules, color_filter_rule, color_build_pi in H0.
    eapply WF_hd_red_mod_filter.
    rewrite bnon_dup_ok in H2.
    apply H2. apply H0. eapply AF_ok. apply H0.

    (* Correctness proof of AF. *)

    induction n; simpl in *; try discr.
    intros a R D af dps.
    destruct af; try discr.
    destruct p; try discr.
    destruct p; try discr.

    (* collapsing is true *)

    case_eq (is_collapsing t); intros H H0; try discr.
    eapply WF_hd_red_mod_proj.
    apply dpProof_ok in H0.
    unfold color_proj_rules, color_pi_proj in H0.
    apply H0.

    (* non-collapsing is true. *)

    revert H0.
    case_eq (is_noncollapsing t && bnon_dup (Sig a)
         (color_raw_pi_filter a ((s, a0, t) :: af))
         (list_split_triple ((s, a0, t) :: af)));
      intros H1 H0; try discr.
    rewrite andb_eq in H1. destruct H1.
    apply dpProof_ok in H0.
    unfold color_filter_rules, color_filter_rule, color_build_pi in H0.
    eapply WF_hd_red_mod_filter.
    rewrite bnon_dup_ok in H2.
    apply H2. apply H0. eapply AF_ok. apply H0.
  Qed. (* REMARK: it takes long time at QED. *)

  (***********************************************************************)
  (** No rule left hand side is a variable in [dp R]. *)

  (*
  Lemma is_notvar_lhs_dp :
    forall a R, forallb (@is_notvar_lhs (Sig a)) (dp R) = true.

  Proof.
    unfold dp. induction R; simpl. refl.
    destruct a0 as [l r]. rewrite forallb_app. rewrite andb_eq. split.
    (* *)
    rewrite forallb_forall. intros.
    destruct (in_map_elim H). destruct H0.
    rewrite forallb_forall in IHR. ded (IHR x). rewrite H2. auto.
    rewrite filter_In in H0. destruct H0. destruct x. injection H1.
    intros. subst x0. subst lhs. clear H1.
    change (In {| lhs := l; rhs := rhs |} (dp R)).
    eapply dp_intro with (r := rhs).
    eapply in_appr in H. eapply in_app in H. destruct H. apply H.
    ded (in_elim H). do 2 destruct H1. Focus 3. apply H3.
  Admitted. *)

  (* REMOVE *)
  (*
  Variables is_notvar_lhs_dp : forall a R, forallb (@is_notvar_lhs
    (Sig a)) (dp R) = true.

  (** No rule right hand side is a variable in [dp R]. *)

  Variables is_notvar_rhs_dp : forall a R, forallb (@is_notvar_rhs
    (Sig a)) (dp R) = true. *)

  (***********************************************************************)
  (** ** Check that [p] is a valid termination proof for [red R]. *)

  (** [n: nat] is an artificial extra argument which purpose is to
     make the function [dpProof] structually recursive with respect to
     this argument. *)

  Variable n : nat.

  (** Prove dependency pair transformation method with mark symbol. *)

  (* FIXME: two conditions [no_lhs_var (R)] and [rules_preserve_vars R]. *)

  Lemma dpTrans_mark_ok : forall a rs dps p (Hm:
    dpTrans_mark bb nat_of_string n rs dps p = OK)
    (H:  forallb (is_notvar_lhs (Sig:=Sig a)) rs &&
      forallb (is_notvar_lhs (Sig:=Sig a)) (dp rs) &&
      forallb (is_notvar_rhs (Sig:=Sig a)) (dp rs) &&
      brules_preserve_vars rs = true), WF (red rs).

  Proof.
    intros a rs dps p Hm H.
    unfold dpTrans_mark in Hm.
    case_eq (color_rules (dp_arity a) nat_of_string dps); intros l H0;
      rewrite H0 in Hm; try discr.
    case_eq (equiv_rules l (Fl (HFSig_of_dup_Sig_eq (arity:=a))
      (dup_hd_rules (dp rs)))); intros H1;
    rewrite H1 in Hm; try discr.

    (* Proving well-founded chain: need to prove two assumptions:
     [no_var_lhs R] and [rules_preserve_vars R]. *)

    apply WF_chain.

    (* No variable at the left hand side of the rules [R]. *)

    do 3 rewrite andb_eq in H. do 3 destruct H. apply H.

    (* Preserve variables of rules [R]. *)

    rewrite andb_eq in H. destruct H.
    apply brules_preserve_vars_ok. apply H2.

    (* Preservation of termination by marking. *)

    apply WF_duplicate_hd_int_red.

    (* No variable on the left hand side of [dp R]. *)

    do 3 rewrite andb_eq in H. do 3 destruct H.
    hyp.

    (* No variable on the right hand side of [dp R]. *)

    do 3 rewrite andb_eq in H. do 3 destruct H.
    hyp.

    (* rs [=] dp rs. *)

    unfold equiv_rules in H1. intuition. apply equiv_ok in H1.
    apply Fhd_red_mod_WF_fin with (HF:= HFSig_of_dup_Sig_eq (arity:=a)).

    apply dpProof_ok in Hm. rewrite <- H1. apply Hm.

    (* beq_rule *)

    intros r1 r2. split. intros. apply ATrs.beq_rule_ok in H2. apply H2.
    intros. rewrite ATrs.beq_rule_ok. apply H2.
  Qed.

  (***********************************************************************)
  (** Prove dependency pair transformation method without mark
  symbol. *)

  Lemma dpTrans_unmark_ok : forall a rs dps p
    (Hm: dpTrans_unmark bb nat_of_string n rs dps p = OK)
    (H:  forallb (is_notvar_lhs (Sig:=Sig a)) rs &&
      forallb (is_notvar_lhs (Sig:=Sig a)) (dp rs) &&
      forallb (is_notvar_rhs (Sig:=Sig a)) (dp rs) &&
      brules_preserve_vars rs = true), WF (red rs).

  Proof.
    intros a rs dps p Hm H.
    unfold dpTrans_unmark in Hm.
    case_eq (color_rules a nat_of_string dps);
      intros l H0; rewrite H0 in Hm; simpl in *; try discr.
    case_eq (equiv_rules l (dp rs)); intros H1;
      rewrite H1 in Hm; simpl in *; try discr.

    (* Using well-founded induction on chain. *)

    apply WF_chain.

    (* No variables at the left hand side of rules [R]. *)

    do 3 rewrite andb_eq in H. do 3 destruct H. hyp.

    (* Preserve variables of rules [R]. *)

    rewrite andb_eq in H. destruct H.

    apply brules_preserve_vars_ok. apply H2.

    (* Change [chain] into [hd_red_mod rs [dp rs]]. *)

    rewrite chain_hd_red_mod.

    (* rs [=] dp rs *)

    unfold equiv_rules in H1. rewrite equiv_ok in H1.
    rewrite <- H1.

    (* Correctness proof of dpProof: WF (hd_red_mod rs l). *)

    eapply dpProof_ok. apply Hm.

    (* beq_rule. *)

    intros r1 r2. split. intro. rewrite ATrs.beq_rule_ok in H2; hyp.
    intro. apply ATrs.beq_rule_ok; hyp.
  Qed.

  (***********************************************************************)
  (** Correcntness proof of dependency pair transformation. *)

  Lemma trsTerminationProof_dpTrans_ok : forall a (R: arules a) dps b p,
    trsTerminationProof_dpTrans bb nat_of_string n R dps b p = OK ->  WF (red R).

  Proof.
    intros a rs dps b p Hm.
    unfold trsTerminationProof_dpTrans in Hm.
    (* Prove the condition do not have variables in the left hand side
       and preverse variables in rules [R]. *)
    case_eq (forallb (is_notvar_lhs (Sig:=Sig a)) rs &&
                     forallb (is_notvar_lhs (Sig:=Sig a)) (dp rs) &&
                     forallb (is_notvar_rhs (Sig:=Sig a)) (dp rs) &&
                     brules_preserve_vars rs); intro H; rewrite H in Hm; try discr.
    destruct b; try discr.
    (* Proving dependency pair where symbols are marked. *)
    apply dpTrans_mark_ok with (dps:=dps)(p:=p).
    apply Hm. apply H.
    (* Proving dependency pair where symbols are not marked. *)
    apply dpTrans_unmark_ok with (dps:=dps)(p:=p).
    apply Hm. hyp.
  Qed.

    (* TODO *)

    (* Prove the condition do not have variables in the left hand side
       and preverse variables in rules [R]. *)
    (*
    case_eq (forallb (is_notvar_lhs (Sig:=Sig a)) rs
      && brules_preserve_vars rs); intros H; rewrite H in Hm; try discr.
    destruct b; try discr.
    apply dpTrans_mark_ok with (dps:=dps)(p:=p).

    apply Hm. apply H.
    apply dpTrans_unmark_ok with (dps:=dps)(p:=p).
    apply Hm. apply H. *)

End Top_Termination.


From Coq Require Import ssreflect ssrfun ssrbool.

Require Import Equations.Prop.Equations.

From Coq Require Import String Ensembles Setoid.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.Classical_Prop.
From Coq.Logic Require Import FunctionalExtensionality Eqdep_dec.
From Coq.Classes Require Import Morphisms_Prop.
From Coq.Unicode Require Import Utf8.
From Coq.micromega Require Import Lia.

From MatchingLogic Require Import Logic.
From MatchingLogic Require Import
  Semantics
  DerivedOperators_Semantics
  PrePredicate
.
Import MatchingLogic.Logic.Notations.
From MatchingLogic.Utils Require Import stdpp_ext.

From stdpp Require Import base fin_sets sets propset proof_irrel option list finite.

Import extralibrary.

Require Import MatchingLogic.Theories.Definedness_Syntax.
Import Definedness_Syntax.Notations.
Import MatchingLogic.Semantics.Notations.
Import MatchingLogic.Syntax.BoundVarSugar.

Section definedness.
  Context
    {Σ : Signature}
    {syntax : Syntax}
  .
  Open Scope ml_scope.

  Let sym (s : Symbols) : Pattern :=
    @patt_sym Σ (inj s).

  Lemma definedness_model_application :
    forall (M : Model) (ρ : Valuation),
      M ⊨ᵀ theory ->
      forall (m: Domain M),
                 (app_ext (eval ρ (sym definedness)) {[m]}) = ⊤.
  Proof.
    intros.
    unfold app_ext.
    rewrite -> set_eq_subseteq.
    split.
    { apply top_subseteq. }
    rewrite -> elem_of_subseteq.
    intros x _.
    unfold theory in H.
    pose proof (H' := proj1 (satisfies_theory_iff_satisfies_named_axioms named_axioms M)).
    specialize (H' H AxDefinedness).
    simpl in H'.
    clear H. rename H' into H.
    unfold satisfies_model in H.
    remember (update_evar_val ev_x m ρ) as ρ'.
    specialize (H ρ').
    rewrite -> set_eq_subseteq in H.
    destruct H as [_ H].
    rewrite -> elem_of_subseteq in H.
    specialize (H x).
    feed specialize H.
    { apply elem_of_top'. }
    unfold patt_defined in H.
    rewrite -> eval_app_simpl in H.
    rewrite -> eval_sym_simpl in H.
    unfold sym.
    unfold p_x in H.
    rewrite -> eval_free_evar_simpl in H.
    rewrite -> Heqρ' in H.
    unfold update_evar_val in H. simpl in H.
    destruct (decide (ev_x = ev_x)).
    2: { contradiction. }
    unfold app_ext in H. unfold In in H.
    destruct H as [m1 [m2 Hm1m2] ].
    destruct Hm1m2. destruct H0.
    inversion H0. clear H0. simpl in H2. subst.
    exists m1. exists m2. split. 2: { split. 2: { apply H1. } constructor. }
    rewrite -> eval_sym_simpl. apply H.
  Qed.

  Lemma definedness_not_empty_1 : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
        (eval ρ ϕ) <> ∅ ->
        (@eval Σ M ρ ⌈ ϕ ⌉ ) = ⊤.
  Proof.
    intros.
    pose (H' := stdpp_ext.Not_Empty_Contains_Elements (eval ρ ϕ) H0).
    destruct H'.
    unfold patt_defined.
    rewrite -> eval_app_simpl.

    pose proof (H'' := definedness_model_application M ρ H x).
    unfold sym in H''.
    rewrite -> set_eq_subseteq in H''.
    destruct H'' as [_ H''].
    assert (Hincl: {[x]} ⊆ (eval ρ ϕ) ).
    { rewrite -> elem_of_subseteq. intros.  inversion H2. subst. assumption. }

    pose proof (Hincl' := app_ext_monotonic_r
                            (eval ρ (patt_sym (inj definedness)))
                            {[x]}
                            (eval ρ ϕ)
                            Hincl
               ).

    rewrite -> set_eq_subseteq.
    split.
    { apply top_subseteq. }
    eapply transitivity.
    apply H''.
    assumption.
  Qed.

  Lemma definedness_empty_1 : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
      eval ρ ϕ = ∅ ->
      @eval Σ M ρ ⌈ ϕ ⌉ = ∅.
  Proof.
    intros M H ϕ ρ H0. unfold patt_defined.
    rewrite -> eval_app_simpl.
    rewrite -> H0.
    apply app_ext_bot_r.
  Qed.

  Theorem modus_tollens: forall (P Q : Prop), (P -> Q) -> ~Q -> ~P.
  Proof. auto. Qed.

  Lemma definedness_empty_2 : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
        eval ρ ⌈ ϕ ⌉ = ∅ ->
        @eval Σ M ρ ϕ = ∅.
  Proof.
    intros M H ϕ ρ H0.
    pose proof (H1 := empty_impl_not_full _ H0).
    pose proof (H2 := modus_tollens _ _ (definedness_not_empty_1 M H ϕ ρ) H1).
    apply NNPP in H2. apply H2.
  Qed.

  Lemma definedness_not_empty_2 : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
        eval ρ ⌈ ϕ ⌉ = ⊤ ->
        @eval Σ M ρ ϕ <> ∅.
  Proof.
    intros M H ϕ ρ H0.
    pose proof (H1 := full_impl_not_empty _ H0).
    exact (modus_tollens _ _ (definedness_empty_1 M H ϕ ρ) H1).
  Qed.

  Lemma definedness_not_empty_iff : forall (M : Model),
    M ⊨ᵀ theory ->
    forall (ϕ : Pattern) (ρ : Valuation),
      (eval ρ ϕ) <> ∅ <->
      (@eval Σ M ρ ⌈ ϕ ⌉ ) = ⊤.
  Proof.
    intros M HM ϕ ρ.
    split; intros H'.
    {
      apply definedness_not_empty_1. exact HM. exact H'.
    }
    {
      apply definedness_not_empty_2. exact HM. exact H'.
    }
  Qed.

  Lemma totality_not_full : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
        eval ρ ϕ <> ⊤ ->
        @eval Σ M ρ ⌊ ϕ ⌋ = ∅.
  Proof.
    intros.
    assert (Hnonempty : eval ρ (patt_not ϕ) <> ∅).
    { unfold not. unfold not in H0. intros. rewrite -> eval_not_simpl in H1.
      apply H0. clear H0.
      rewrite -> set_eq_subseteq.
      split.
      { apply top_subseteq. }
      rewrite -> complement_empty_iff_full in H1.
      rewrite H1.
      apply top_subseteq.
    }
    unfold patt_total. rewrite -> eval_not_simpl.
    rewrite -> complement_empty_iff_full.

    apply definedness_not_empty_1.
    { apply H. }
    apply Hnonempty.
  Qed.

  Lemma totality_full : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
        eval ρ ϕ = ⊤ ->
        @eval Σ M ρ ⌊ ϕ ⌋ = ⊤.
  Proof.
    intros M H ϕ ρ H0.
    unfold patt_total.
    rewrite -> eval_not_simpl.
    assert(H1: eval ρ (patt_not ϕ) = ∅).
    { rewrite -> eval_not_simpl.
      rewrite -> H0.
      clear. set_solver.
    }

    pose proof (H2 := definedness_empty_1 M H (patt_not ϕ) ρ H1).
    rewrite -> H2.
    clear. set_solver.
  Qed.

  Lemma totality_result_empty : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
        eval ρ ⌊ ϕ ⌋ = ∅ ->
        @eval Σ M ρ ϕ <> ⊤.
  Proof.
    intros M H ϕ ρ H0.
    pose proof (H1 := empty_impl_not_full _ H0).
    pose proof (H2 := modus_tollens _ _ (totality_full M H ϕ ρ) H1).
    apply H2.
  Qed.

  Lemma totality_not_full_iff : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
        eval ρ ϕ <> ⊤ <->
        @eval Σ M ρ ⌊ ϕ ⌋ = ∅.
  Proof.
    intros M HM ϕ ρ.
    split; intros H'.
    {
      apply totality_not_full. exact HM. exact H'.
    }
    {
      apply totality_result_empty. exact HM. exact H'.
    }
  Qed.

  Lemma totality_result_nonempty : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
        eval ρ ⌊ ϕ ⌋ <> ∅ ->
        @eval Σ M ρ ϕ = ⊤.
  Proof.
    intros M H ϕ ρ H0.
    pose proof (H2 := modus_tollens _ _ (totality_not_full M H ϕ ρ) H0).
    apply NNPP in H2. apply H2.
  Qed.

  Lemma equal_iff_both_subseteq : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ1 ϕ2 : Pattern) (ρ : Valuation),
        eval ρ (ϕ1 =ml ϕ2) = ⊤ <->
        (
          eval ρ (ϕ1 ⊆ml ϕ2) = ⊤ /\
          @eval Σ M ρ (patt_subseteq ϕ2 ϕ1) = ⊤).
  Proof.
    intros M H ϕ1 ϕ2 ρ.
    split.
    - intros H0.
      unfold patt_equal in H0.
      apply full_impl_not_empty in H0.
      apply (totality_result_nonempty _ H) in H0.
      unfold "<--->" in H0.
      rewrite -> eval_and_simpl in H0.
      rewrite -> intersection_full_iff_both_full in H0.
      destruct H0 as [H1 H2].
      unfold patt_subseteq.
      apply (totality_full _ H) in H1.
      apply (totality_full _ H) in H2.
      split; assumption.
    - intros [H0 H1].
      unfold patt_subseteq.
      apply full_impl_not_empty in H0.
      apply full_impl_not_empty in H1.
      apply (totality_result_nonempty _ H) in H0.
      apply (totality_result_nonempty _ H) in H1.
      unfold patt_equal.
      apply (totality_full _ H).
      unfold "<--->".
      rewrite -> eval_and_simpl.
      rewrite -> H0.
      rewrite -> H1.
      clear. set_solver.
  Qed.

  Lemma subseteq_iff_interpr_subseteq : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ1 ϕ2 : Pattern) (ρ : Valuation),
        eval ρ (ϕ1 ⊆ml ϕ2) = ⊤ <->
        (eval ρ ϕ1)
          ⊆ (@eval Σ M ρ ϕ2).
  Proof.
    intros M H ϕ1 ϕ2 ρ.
    split.
    - intros H0.
      unfold patt_subseteq in H0.
      apply full_impl_not_empty in H0.
      apply (totality_result_nonempty _ H) in H0.
      rewrite -> eval_imp_simpl in H0.
      rewrite -> set_eq_subseteq in H0.
      destruct H0 as [_ H0].
      rewrite -> elem_of_subseteq in H0.
      intros x H1. specialize (H0 x).
      feed specialize H0.
      { apply elem_of_top'. }
      remember (eval ρ ϕ1) as Xϕ1.
      remember (eval ρ ϕ2) as Xϕ2.
      clear -H0 H1.
      set_solver.
    - intros H0.
      unfold patt_subseteq.
      apply (totality_full _ H).
      rewrite -> eval_imp_simpl.
      rewrite -> set_eq_subseteq.
      split.
      { apply top_subseteq. }
      rewrite -> elem_of_subseteq.
      intros x _. specialize (H0 x).
      destruct (classic (x ∈ (eval ρ ϕ1))).
      + right. auto.
      + left. apply elem_of_compl. assumption.
  Qed.

  Lemma equal_iff_interpr_same : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ1 ϕ2 : Pattern) (ρ : Valuation),
        eval ρ (ϕ1 =ml ϕ2) = ⊤ <->
        eval ρ ϕ1
        = @eval Σ M ρ ϕ2.
  Proof.
    intros M H ϕ1 ϕ2 ρ.
    split.
    - intros H0.
      apply (equal_iff_both_subseteq _ H) in H0.
      destruct H0 as [Hsub1 Hsub2].
      apply (subseteq_iff_interpr_subseteq _ H) in Hsub1.
      apply (subseteq_iff_interpr_subseteq _ H) in Hsub2.
      rewrite -> set_eq_subseteq.
      split; assumption.
    - intros H0.
      rewrite -> set_eq_subseteq in H0.
      destruct H0 as [Hincl1 Hincl2].
      apply (subseteq_iff_interpr_subseteq _ H) in Hincl1.
      apply (subseteq_iff_interpr_subseteq _ H) in Hincl2.
      apply equal_iff_both_subseteq. auto. split; auto.
  Qed.

  Lemma equal_refl : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ : Pattern) (ρ : Valuation),
        @eval Σ M ρ (patt_equal ϕ ϕ) = ⊤.
  Proof.
    intros M H ϕ ρ.
    apply (equal_iff_interpr_same _ H).
    auto.
  Qed.

  Lemma equal_sym : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ1 ϕ2 : Pattern) (ρ : Valuation),
        eval ρ (ϕ1 =ml ϕ2) = ⊤ ->
        @eval Σ M ρ (patt_equal ϕ2 ϕ1) = ⊤.
  Proof.
    intros M H ϕ1 ϕ2 ρ H0.
    apply (equal_iff_interpr_same _ H).
    apply (equal_iff_interpr_same _ H) in H0.
    symmetry. auto.
  Qed.

  Lemma equal_trans : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (ϕ1 ϕ2 ϕ3 : Pattern) (ρ : Valuation),
        eval ρ (ϕ1 =ml ϕ2) = ⊤ ->
        eval ρ (patt_equal ϕ2 ϕ3) = ⊤ ->
        @eval Σ M ρ (patt_equal ϕ1 ϕ3) = ⊤.
  Proof.
    intros M H ϕ1 ϕ2 ϕ3 ρ H0 H1.
    apply (equal_iff_interpr_same _ H).
    apply (equal_iff_interpr_same _ H) in H0.
    apply (equal_iff_interpr_same _ H) in H1.
    rewrite -> H0. auto.
  Qed.

  Lemma free_evar_in_patt : forall (M : Model),
      M ⊨ᵀ theory ->
      forall (x : evar)(ϕ : Pattern) (ρ : Valuation),
        (evar_valuation ρ x ∈ (eval ρ ϕ)) <->
        @eval Σ M ρ (patt_in (patt_free_evar x) ϕ) = ⊤.
  Proof.
    intros M H x ϕ ρ.
    split.
    - intros H0.
      unfold patt_in.
      apply (definedness_not_empty_1 _ H).
      intros Contra.
      apply Contains_Elements_Not_Empty in Contra. exact Contra.
      exists (evar_valuation ρ x).
      rewrite -> eval_and_simpl.
      split.
      + rewrite -> eval_free_evar_simpl. constructor.
      + assumption.
    - intros H0.
      unfold patt_in in H0.
      apply (definedness_not_empty_2 _ H) in H0.
      unfold not in H0.
      assert (H0': (eval ρ (patt_free_evar x and ϕ)) = ∅ -> False).
      { intros Contra. apply H0. auto. }
      apply Not_Empty_Contains_Elements in H0'.
      destruct H0' as [x0 H0'].
      rewrite -> eval_and_simpl in H0'.
      destruct H0'.
      rewrite -> eval_free_evar_simpl in H1.
      inversion H1. subst. assumption.
  Qed.

  Lemma T_predicate_defined : forall ϕ, T_predicate theory ⌈ ϕ ⌉.
  Proof.
    intros ϕ. unfold T_predicate. intros. unfold M_predicate. intros.
    pose proof (Hlr := classic ( eval ρ ϕ = ∅ )).
    destruct Hlr.
    + apply definedness_empty_1 in H0. right. apply H0. apply H.
    + apply definedness_not_empty_1 in H0. left. apply H0. apply H.
  Qed.

  Lemma T_pre_predicate_defined : forall ϕ, T_pre_predicate theory ⌈ ϕ ⌉.
  Proof.
    intros ϕ. unfold T_pre_predicate. intros M HM.
    unfold M_pre_predicate. intros l Hwf.
    intros Hfa Hci Hwf'.
    unfold patt_defined. rewrite bcmcloseex_app.
    rewrite bcmcloseex_sym. apply T_predicate_defined.
    exact HM.
  Qed.

  Hint Resolve T_predicate_defined : core.

  Lemma T_predicate_total : forall ϕ, T_predicate theory ⌊ ϕ ⌋.
  Proof.
    intros ϕ. unfold patt_total.
    apply T_predicate_not.
    apply T_predicate_defined.
  Qed.

  Lemma T_pre_predicate_total : forall ϕ, T_pre_predicate theory ⌊ ϕ ⌋.
  Proof.
    intros ϕ. unfold patt_total.
    unfold T_pre_predicate. intros M HM.
    apply M_pre_predicate_not.
    apply T_pre_predicate_defined.
    exact HM.
  Qed.

  Hint Resolve T_predicate_total : core.

  Lemma T_predicate_subseteq : forall ϕ₁ ϕ₂, T_predicate theory (patt_subseteq ϕ₁ ϕ₂).
  Proof.
    intros ϕ₁ ϕ₂. unfold patt_subseteq. apply T_predicate_total.
  Qed.

  Lemma T_pre_predicate_subseteq : forall ϕ₁ ϕ₂, T_pre_predicate theory (patt_subseteq ϕ₁ ϕ₂).
  Proof.
    intros ϕ₁ ϕ₂. apply T_pre_predicate_total.
  Qed.

  Hint Resolve T_predicate_subseteq : core.

  Lemma T_predicate_equals : forall ϕ₁ ϕ₂, T_predicate theory (patt_equal ϕ₁ ϕ₂).
  Proof.
    intros ϕ₁ ϕ₂. unfold patt_equal. apply T_predicate_total.
  Qed.

  Lemma T_pre_predicate_equal : forall ϕ₁ ϕ₂, T_pre_predicate theory (patt_equal ϕ₁ ϕ₂).
  Proof.
    intros ϕ₁ ϕ₂. apply T_pre_predicate_total.
  Qed.

  Hint Resolve T_predicate_equals : core.

  Lemma T_predicate_in : forall ϕ₁ ϕ₂, T_predicate theory (patt_in ϕ₁ ϕ₂).
  Proof.
    intros ϕ₁ ϕ₂. unfold patt_equal. apply T_predicate_defined.
  Qed.

  Hint Resolve T_predicate_in : core.

  Lemma T_predicate_eq_inversion : forall ϕ₁ ϕ₂,
    T_predicate theory (patt_eq_inversion_of ϕ₁ ϕ₂).
  Proof.
    intros ϕ₁ ϕ₂ M Hm.
    unfold patt_eq_inversion_of.
    apply M_predicate_forall.
    match goal with
    | |- context G [fresh_evar ?t] => remember (fresh_evar t) as X
    end.

    mlSimpl.
    apply T_predicate_equals.
    apply Hm.
  Qed.

  Lemma eval_eq_inversion_of ϕ₁ ϕ₂ M ρ :
    M ⊨ᵀ theory ->
    @eval Σ M ρ (patt_eq_inversion_of ϕ₁ ϕ₂) = ⊤
    <-> (forall m₁ m₂,
            m₂ ∈ rel_of ρ ϕ₁ m₁ <-> m₁ ∈ rel_of ρ ϕ₂ m₂ (* TODO make rel_of take one more parameter. *)
        ).
  Proof.
    intros Htheory.
    rewrite eval_forall_predicate.
    { mlSimpl. apply T_predicate_equals. apply Htheory. }
    apply all_iff_morphism. intros m₁.
    remember ((fresh_evar
          (patt_equal (nest_ex ϕ₁ $ BoundVarSugar.b0)
             (ex ,
              (BoundVarSugar.b0
                 and patt_in BoundVarSugar.b1 (nest_ex (nest_ex ϕ₂) $ BoundVarSugar.b0)))))) as x.
    unfold evar_open.
    mlSimpl.
    rewrite equal_iff_interpr_same.
    { apply Htheory. }

    rewrite eval_set_builder.
    { mlSimpl. apply T_predicate_in. apply Htheory. }

    assert (Hpi: ∀ M ρ ϕ rhs,
               eval ρ ϕ = rhs
               <-> (∀ m, m ∈ @eval _ M ρ ϕ <-> m ∈ rhs)).
    { split; intros H.
      + rewrite H. auto.
      + rewrite -> set_eq_subseteq. repeat rewrite elem_of_subseteq.
        split.
        * intros x0. specialize (H x0). destruct H as [H1 H2].
          apply H1.
        * intros x0. specialize (H x0). destruct H as [H1 H2].
          apply H2.
    }
    rewrite Hpi.
    apply all_iff_morphism. intros m₂.
    rewrite eval_app_simpl.

    rewrite nest_ex_same.
(*     {
      subst x.
      eapply evar_is_fresh_in_richer.
      2: { apply set_evar_fresh_is_fresh. }
      solve_free_evars_inclusion 5.
    } *)
    unfold evar_open, nest_ex.
    remember (fresh_evar
                (patt_free_evar x
                 ∈ml (nest_ex_aux 0 1 (nest_ex_aux 0 1 ϕ₂))^[evar:1↦patt_free_evar x] $ b0)) as y.
    rewrite fuse_nest_ex_same.
    rewrite nest_ex_same_general. 1-2: cbn; lia.
    mlSimpl. rewrite nest_ex_same.
(*
    do 3 rewrite evar_open_bound_evar.
    repeat case_match; try lia.
*)
(*
    rewrite simpl_evar_open.
    rewrite evar_open_free_evar.
*)
    repeat rewrite elem_of_PropSet.
   (*  rewrite <- free_evar_in_patt.
    2: { apply Htheory. } *)
    rewrite eval_free_evar_simpl.
    rewrite update_evar_val_same.
    fold (m₂ ∈ rel_of ρ ϕ₁ m₁). simpl.

    (*rewrite simpl_evar_open.*)
    rewrite <- free_evar_in_patt; auto.
    rewrite eval_app_simpl.
    repeat rewrite eval_free_evar_simpl.
    rewrite eval_free_evar_independent.
    {
      subst.
      eapply evar_is_fresh_in_richer'.
      2: apply set_evar_fresh_is_fresh'.
      solve_free_evars_inclusion 5.
    }
    rewrite eval_free_evar_independent.
    {
      subst.
      eapply evar_is_fresh_in_richer'.
      2: apply set_evar_fresh_is_fresh'. unfold nest_ex.
      rewrite fuse_nest_ex_same. simpl.
      solve_free_evars_inclusion 5.
    }
    rewrite eval_free_evar_independent.
    {
      subst.
      eapply evar_is_fresh_in_richer'.
      2: apply set_evar_fresh_is_fresh'.
      solve_free_evars_inclusion 5.
    }
    rewrite update_evar_val_comm.
    { solve_fresh_neq. }

    rewrite update_evar_val_same.
    rewrite update_evar_val_comm.
    { solve_fresh_neq. }

    rewrite update_evar_val_same.
    unfold app_ext.
    rewrite elem_of_PropSet.
    fold (rel_of ρ ϕ₂ m₂).
    auto.
  Qed.

  Lemma single_element_definedness_impl_satisfies_definedness (M : Model) :
    (exists (hashdef : Domain M),
        sym_interp M (inj definedness) = {[hashdef]}
        /\ forall x, app_interp _ hashdef x = ⊤
    ) ->
        satisfies_model M (axiom AxDefinedness).
  Proof.
    intros [hashdef [Hhashdefsym Hhashdeffull] ].
    unfold satisfies_model. intros ρ.
    unfold axiom.
    unfold sym.
    unfold patt_defined.
    unfold p_x.
    rewrite -> eval_app_simpl.
    rewrite -> eval_sym_simpl.
    rewrite -> set_eq_subseteq.
    split.
    { apply top_subseteq. }
    rewrite -> elem_of_subseteq.
    intros x _.
    intros.
    unfold Ensembles.In.
    unfold app_ext.
    exists hashdef.
    rewrite Hhashdefsym.
    rewrite -> eval_free_evar_simpl.
    exists (evar_valuation ρ ev_x).
    split.
    { constructor. }
    split.
    { constructor. }
    rewrite Hhashdeffull.
    constructor.
  Qed.

  Lemma satisfies_definedness_implies_has_element_for_every_element
    (M : Model):
    M ⊨ᵀ theory ->
    forall (x y : Domain M),
      exists (z : Domain M),
        z ∈ sym_interp M (inj definedness)
        /\ y ∈ app_interp _ z x.
  Proof.
    intros HM x y.
    unfold theory in HM.
    rewrite satisfies_theory_iff_satisfies_named_axioms in HM.
    specialize (HM AxDefinedness). simpl in HM.
    unfold satisfies_model in HM.
    remember (λ (ev : evar), x) as ρₑ.
    specialize (HM (mkValuation ρₑ (λ (sv : svar), ∅))).
    unfold patt_defined in HM.
    rewrite eval_app_simpl in HM.
    rewrite eval_sym_simpl in HM.
    rewrite eval_free_evar_simpl in HM.
    unfold app_ext in HM.
    rewrite set_eq_subseteq in HM.
    destruct HM as [_ HM].
    rewrite elem_of_subseteq in HM.
    specialize (HM y).
    feed specialize HM.
    {
      clear. set_solver.
    }
    rewrite elem_of_PropSet in HM.
    destruct HM as [le [re [HM1 [HM2 HM3] ] ] ].
    subst ρₑ.
    rewrite elem_of_singleton in HM2. subst re.
    exists le.
    split; assumption.
  Qed.

  Lemma not_equal_iff_not_interpr_same_1 : forall (M : Model),
    M ⊨ᵀ theory ->
    forall (ϕ1 ϕ2 : Pattern) (ρ : Valuation),
      @eval Σ M ρ (ϕ1 =ml ϕ2) = ∅ <->
      eval ρ ϕ1
      <> eval ρ ϕ2.
  Proof.
    intros M H ϕ1 ϕ2 ρ.
    rewrite -predicate_not_full_iff_empty.
    { apply T_predicate_equals. apply H. }
    rewrite equal_iff_interpr_same.
    { apply H. }
    split; intros H'; exact H'.
  Qed.

  Lemma not_subseteq_iff_not_interpr_subseteq_1 : forall (M : Model),
    M ⊨ᵀ theory ->
    forall (ϕ1 ϕ2 : Pattern) (ρ : Valuation),
      eval ρ (ϕ1 ⊆ml ϕ2) = ∅ <->
      ~(eval ρ ϕ1)
        ⊆ (@eval Σ M ρ ϕ2).
  Proof.
    intros M H ϕ1 ϕ2 ρ.
    rewrite -predicate_not_full_iff_empty.
    { apply T_predicate_subseteq. apply H. }
    rewrite subseteq_iff_interpr_subseteq.
    { apply H. }
    split; intros H'; exact H'.
  Qed.

End definedness.

From MatchingLogic Require Import StringSignature.

Module equivalence_insufficient.
  Open Scope ml_scope.
  Inductive exampleSymbols : Set :=
  | sym_f.

  Local
  Instance exampleSymbols_eqdec : EqDecision exampleSymbols.
  Proof. unfold EqDecision. intros x y. unfold Decision. decide equality. Defined.

  Local
  Program Instance exampleSymbols_fin : Finite exampleSymbols :=
  {|
    enum := [sym_f] ;
  |}.
  Next Obligation.
    apply NoDup_cons.
    split.
    {
      intros HContra. inversion HContra.
    }
    {
      apply NoDup_nil. exact I.
    }
  Qed.
  Next Obligation.
  intros []. set_solver.
  Qed.

  #[local]
  Instance mySignature : Signature :=
  {| variables := StringMLVariables;
     ml_symbols := {|
      symbols := exampleSymbols;
      sym_eqdec := exampleSymbols_eqdec;
     |};
  |}.

  Inductive exampleDomain : Set :=
  | one | two | f.

  Theorem exampleDomain_Inhabited : Inhabited exampleDomain.
  Proof. constructor. apply one. Defined.

  Definition example_app_interp (d1 d2 : exampleDomain) : propset exampleDomain :=
  match d1, d2 with
  | f, one => ⊤
  | f, two => ∅
  | _, _ => ∅
  end.

  Definition exampleModel : @Model mySignature :=
  {|
    Domain := exampleDomain;
    Domain_inhabited := exampleDomain_Inhabited;
    sym_interp := fun (x : symbols) =>
                      {[ f ]};
    app_interp := example_app_interp;
  |}.

  Theorem app_ext_singleton : forall x y,
    app_ext {[x]} {[y]} ≡ @app_interp mySignature exampleModel x y.
  Proof.
    intros x y. unfold app_ext. set_solver.
  Qed.

  Example equiv_not_eq :
    forall ρ, @eval _ exampleModel ρ (ex , (patt_sym sym_f $ patt_free_evar "x"%string <---> b0)) = ⊤.
  Proof.
    intros ρ. unfold_leibniz.
    rewrite set_equiv_subseteq. split.
    apply top_subseteq.
    rewrite eval_simpl. simpl.
    unfold evar_open. simpl.
    unfold propset_fa_union.

    apply elem_of_subseteq. intros x _.
    rewrite elem_of_PropSet.
    destruct (evar_valuation ρ "x"%string) eqn:Eqx.
    * destruct x.
      - exists one.
        repeat rewrite eval_simpl.
        rewrite update_evar_val_same.
        rewrite app_ext_singleton.
        rewrite update_evar_val_neq.
        { set_solver. }
        simpl. rewrite Eqx.
        set_unfold. intuition.
      - exists two.
        repeat rewrite eval_simpl.
        rewrite update_evar_val_same.
        rewrite app_ext_singleton.
        rewrite update_evar_val_neq.
        { set_solver. }
        simpl. rewrite Eqx.
        set_unfold. intuition.
      - exists f.
        repeat rewrite eval_simpl.
        rewrite update_evar_val_same.
        rewrite app_ext_singleton.
        rewrite update_evar_val_neq.
        { set_solver. }
        simpl. rewrite Eqx.
        set_unfold. intuition.
    * destruct x.
      - exists two.
        repeat rewrite eval_simpl.
        rewrite update_evar_val_same.
        rewrite app_ext_singleton.
        rewrite update_evar_val_neq.
        { set_solver. }
        simpl. rewrite Eqx.
        set_unfold. intuition.
        left. intuition. apply H. intro. congruence.
      - exists one.
        repeat rewrite eval_simpl.
        rewrite update_evar_val_same.
        rewrite app_ext_singleton.
        rewrite update_evar_val_neq.
        { set_solver. }
        simpl. rewrite Eqx.
        set_unfold. intuition.
        left. intuition. apply H. intro. congruence.
      - exists two.
        repeat rewrite eval_simpl.
        rewrite update_evar_val_same.
        rewrite app_ext_singleton.
        rewrite update_evar_val_neq.
        { set_solver. }
        simpl. rewrite Eqx.
        set_unfold. intuition.
        left. intuition. apply H. intro. congruence.
   * destruct x.
      - exists two.
        repeat rewrite eval_simpl.
        rewrite update_evar_val_same.
        rewrite app_ext_singleton.
        rewrite update_evar_val_neq.
        { set_solver. }
        simpl. rewrite Eqx.
        set_unfold. intuition.
        left. intuition. apply H. intro. congruence.
      - exists one.
        repeat rewrite eval_simpl.
        rewrite update_evar_val_same.
        rewrite app_ext_singleton.
        rewrite update_evar_val_neq.
        { set_solver. }
        simpl. rewrite Eqx.
        set_unfold. intuition.
        left. intuition. apply H. intro. congruence.
      - exists two.
        repeat rewrite eval_simpl.
        rewrite update_evar_val_same.
        rewrite app_ext_singleton.
        rewrite update_evar_val_neq.
        { set_solver. }
        simpl. rewrite Eqx.
        set_unfold. intuition.
        left. intuition. apply H. intro. congruence.
  Qed.
  Close Scope ml_scope.
End equivalence_insufficient.

#[export]
Hint Resolve T_predicate_defined : core.
#[export]
Hint Resolve T_predicate_total : core.
#[export]
Hint Resolve T_predicate_subseteq : core.
#[export]
Hint Resolve T_predicate_equals : core.
#[export]
Hint Resolve T_predicate_in : core.


(** This file is essentially a bunch of testcases. *)
From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import adequacy.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".

Section LiftingTests.
  Context `{heapG Σ} `{probG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val → iProp Σ.

  Definition simpl_test :
    ⌜(10 = 4 + 6)%nat⌝ -∗
    WP let: "x" := ref #1 in "x" <- !"x";; !"x" {{ v, ⌜v = #1⌝ }}.
  Proof.
    iIntros "?". wp_alloc l. repeat (wp_pure _) || wp_load || wp_store.
    match goal with
    | |- context [ (10 = 4 + 6)%nat ] => done
    end.
  Qed.

  Definition heap_e : expr :=
    let: "x" := ref #1 in "x" <- !"x" + #1 ;; !"x".

  Lemma heap_e_spec E : WP heap_e @ E {{ v, ⌜v = #2⌝ }}%I.
  Proof.
    iIntros "". rewrite /heap_e.
    wp_alloc l. wp_let. wp_load. wp_op. wp_store. by wp_load.
  Qed.

  Definition heap_e2 : expr :=
    let: "x" := ref #1 in
    let: "y" := ref #1 in
    "x" <- !"x" + #1 ;; !"x".

  Lemma heap_e2_spec E : WP heap_e2 @ E {{ v, ⌜v = #2⌝ }}%I.
  Proof.
    iIntros "". rewrite /heap_e2.
    wp_alloc l. wp_let. wp_alloc l'. wp_let.
    wp_load. wp_op. wp_store. wp_load. done.
  Qed.

  Definition heap_e3 : expr :=
    let: "x" := #true in
    let: "f" := λ: "z", "z" + #1 in
    if: "x" then "f" #0 else "f" #1.

  Lemma heap_e3_spec E : WP heap_e3 @ E {{ v, ⌜v = #1⌝ }}%I.
  Proof.
    iIntros "". rewrite /heap_e3.
    by repeat (wp_pure _).
  Qed.

  Definition heap_e4 : expr :=
    let: "x" := (let: "y" := ref (ref #1) in ref "y") in
    ! ! !"x".

  Lemma heap_e4_spec : WP heap_e4 {{ v, ⌜ v = #1 ⌝ }}%I.
  Proof.
    rewrite /heap_e4. wp_alloc l. wp_alloc l'. wp_let.
    wp_alloc l''. wp_let. by repeat wp_load.
  Qed.

  Definition heap_e5 : expr :=
    let: "x" := ref (ref #1) in FAA (!"x") (#10 + #1) + ! !"x".

  Lemma heap_e5_spec E : WP heap_e5 @ E {{ v, ⌜v = #13⌝ }}%I.
  Proof.
    rewrite /heap_e5. wp_alloc l. wp_alloc l'. wp_let.
    wp_load. wp_op. wp_faa. do 2 wp_load. wp_op. done.
  Qed.

  Definition FindPred : val :=
    rec: "pred" "x" "y" :=
      let: "yp" := "y" + #1 in
      if: "yp" < "x" then "pred" "x" "yp" else "y".
  Definition Pred : val :=
    λ: "x",
      if: "x" ≤ #0 then -FindPred (-"x" + #2) #0 else FindPred "x" #0.

  Lemma FindPred_spec n1 n2 E Φ :
    n1 < n2 →
    Φ #(n2 - 1) -∗ WP FindPred #n2 #n1 @ E {{ Φ }}.
  Proof.
    iIntros (Hn) "HΦ". iLöb as "IH" forall (n1 Hn).
    wp_rec. wp_let. wp_op. wp_let.
    wp_op; case_bool_decide; wp_if.
    - iApply ("IH" with "[%] HΦ"). omega.
    - by assert (n1 = n2 - 1) as -> by omega.
  Qed.

  Lemma Pred_spec n E Φ : ▷ Φ #(n - 1) -∗ WP Pred #n @ E {{ Φ }}.
  Proof.
    iIntros "HΦ". wp_lam.
    wp_op. case_bool_decide; wp_if.
    - wp_op. wp_op.
      wp_apply FindPred_spec; first omega.
      wp_op. by replace (n - 1) with (- (-n + 2 - 1)) by omega.
    - wp_apply FindPred_spec; eauto with omega.
  Qed.

  Lemma Pred_user E :
    (WP let: "x" := Pred #42 in Pred "x" @ E {{ v, ⌜v = #40⌝ }})%I.
  Proof. iIntros "". wp_apply Pred_spec. wp_let. by wp_apply Pred_spec. Qed.
End LiftingTests.

Lemma heap_e_adequate σ : adequate NotStuck heap_e σ (= #2).
Proof. eapply (heap_adequacy' heapΣ _)=> ??. by eapply heap_e_spec. Qed.


Require Import Coq.Reals.Rdefinitions.
Require Import TLA.TLA.
Import LibNotations.
Require Import TLA.DifferentialInduction.
Require Import TLA.ContinuousProofRules.
Require Import TLA.BasicProofRules.
Require Import Examples.System.

Open Scope HP_scope.
Open Scope string_scope.

Section SensorWithDelay.

  Variable x : Var.
  Variable Xmax : Var.
  Variable Xmin : Var.
  Variable xderiv : Var.
  Variable d : R.
  (** Clean this up? Maybe **)
  Let w_all := ["t" '  ::= -- (1), x '  ::= xderiv, Xmax '  ::= 0,
                Xmin '  ::= 0, xderiv '  ::= 0].
  Hypothesis get_deriv_Xmax :
    get_deriv Xmax w_all = Some (NatT 0).
  Hypothesis get_deriv_Xmin :
    get_deriv Xmin w_all = Some (NatT 0).
  Hypothesis get_deriv_xderiv :
    get_deriv xderiv w_all = Some (NatT 0).
  Hypothesis get_deriv_x :
    get_deriv x w_all = Some (VarNowT xderiv).

  Ltac rewrite_deriv_hyps :=
    breakAbstraction; unfold w_all in *;
    repeat first [ rewrite get_deriv_Xmax |
                   rewrite get_deriv_Xmin |
                   rewrite get_deriv_xderiv |
                   rewrite get_deriv_x ].

  Definition Sense : Formula :=
         (xderiv! >= 0 //\\ Xmax! = x + xderiv!*d //\\ Xmin! = x)
    \\// (xderiv! < 0 //\\ Xmax! = x //\\ Xmin! = x + xderiv!*d).

  Definition SenseSafeInd : Formula :=
         (xderiv >= 0 -->> (Xmax >= x + xderiv*"t" //\\ Xmin <= x))
    //\\ (xderiv < 0 -->> (Xmax >= x //\\ Xmin <= x + xderiv*"t")).

  Definition I := SenseSafeInd.

  Definition SenseSafe : Formula :=
    Xmin <= x <= Xmax.

  Variable WC : Formula.

  Definition w := (DiffEqC x xderiv::nil)%list.

  Definition SpecR : SysRec :=
    {| dvars := (Xmax::Xmin::xderiv::nil)%list;
       cvars := (x::nil)%list;
       Init := I;
       Prog := Sense;
       world := w;
       WConstraint := WC;
       maxTime := d |}.

  Definition Spec := SysD SpecR.

  Theorem sense_safe_ind :
    Spec |-- []SenseSafeInd.
  Proof.
    intro.
    eapply discr_indX.
    - tlaIntuition.
    - tlaAssume.
    - tlaAssume.
    - unfold Next. decompose_hyps.
      + unfold World, world.
        eapply diff_ind with (Hyps:=TRUE);
        try solve [tlaIntuition | tlaAssume ];
        repeat tlaSplit;
        try solve [ rewrite_deriv_hyps; solve_linear |
                    tlaIntro; eapply unchanged_continuous;
                      [ tlaAssume | solve_linear ] ].
      + solve_linear; solve_nonlinear.
      + solve_linear; solve_nonlinear.
  Qed.

  Theorem sense_safe :
    |-- Spec -->> []SenseSafe.
  Proof.
    intros. charge_intros.
    tlaAssert ([]TimeBound SpecR.(maxTime)).
    + eapply Sys_bound_t. unfold Spec, SpecR. tlaAssume.
    + charge_intros. tlaAssert ([]SenseSafeInd).
      * rewrite sense_safe_ind. tlaAssume.
      * tlaRevert. apply forget_prem.
        rewrite <- uncurry. rewrite Always_and.
        apply Always_imp. solve_nonlinear.
  Qed.

End SensorWithDelay.

Close Scope HP_scope.
Close Scope string_scope.


(** Coq coding by choukh, Aug 2021 **)

(* 哥德尔本体论公理在可变论域K系统中不一致 *)

Require Import CM.Logic.Classical.
Require Import CM.Logic.Modal.
Require Import CM.Logic.Entity.
Require Import CM.Logic.VaryingDomain.

Parameter 积极 : 泛性质 性质.
Definition 消极 := λ Φ, ¬ 积极 Φ.

Axiom 积极性质的反面消极 : ⌈∀ Φ, 积极 Φ → 消极 (反 Φ)⌋.

Axiom 积极的必然后果也积极 : ⌈∀ Φ Ψ : 性质, 积极 Φ → (Φ ⟹ Ψ) → 积极 Ψ⌋.

Theorem 积极性质可能存在实例 : ⌈∀ Φ, 积极 Φ → 在场一致 Φ⌋.
Proof.
  证明. intros Φ H. 反证.
  apply (在场爆炸原理 w Φ (反 Φ)) in 反设.
  apply (积极性质的反面消极 w Φ). apply H.
  now apply (积极的必然后果也积极 w Φ).
Qed.

(* P是x的本性，当且仅当x的任意性质都是P的必然后果 *)
Definition 本性 : 性质 → 实体 → 命题 :=
  λ Φ x, ∀ Ψ, Ψ x → Φ ⟹ Ψ.

(* 实体实在，当且仅当该实体的任意本性都必然存在实例 *)
Definition 实在性 : 性质 := λ x, ∀ Φ, 本性 Φ x → □ ∃ᴱ x, Φ x.

Axiom 实在性积极 : ⌈积极 实在性⌋.

Lemma 实在性可能存在实例 : ⌈在场一致 实在性⌋.
Proof. 证明. apply 积极性质可能存在实例. apply 实在性积极. Qed.

Lemma 可能必然存在反同一性实体 : ⌈◇ □ ∃ᴱ x, 反同一性 x⌋.
Proof.
  证明. eapply 可能性三段论1. apply 实在性可能存在实例.
  apply 𝗡. 证明. intros []. apply H. firstorder.
Qed.

Fact 公理不一致 : False.
Proof.
  destruct 存在世界 as [w].
  pose proof 可能必然存在反同一性实体. firstorder.
Qed.


Set Automatic Coercions Import.

Require Import List Bool.
Require Import util list_util stability containers.
Require Import CSetoids.
Require Import Morphisms.
Set Implicit Arguments.
Require Import EquivDec.
Require concrete.
Require Import CoLoR.Util.Vector.VecUtil.
Require Import hybrid.vector_setoid.
Require hybrid.nat_util.
Require Import hybrid.hlist_aux.

Module c := concrete.

Section contents.

  Variable chs: concrete.System.

  Record Space: Type :=
    { Region: Type
    ; Region_eq_dec: EquivDec.EqDec Region eq
    ; regions: ExhaustiveList Region
    ; NoDup_regions: NoDup regions
    ; in_region: Container (concrete.Point chs) Region
    ; in_region_mor: Proper (@cs_eq _ ==> eq ==> iff) in_region
    ; regions_cover: forall l p, c.invariant (l, p) -> DN (sig (in_region p))
    }.

  Existing Instance in_region.
  Existing Instance Region_eq_dec.
  Existing Instance regions.
  Existing Instance in_region_mor.

  Section space_derivatives.

    Variable p: Space.

    Definition State := (concrete.Location chs * Region p)%type.

    Definition region: State -> Region p := snd.
    Definition location: State -> c.Location chs := fst.

    Definition states: ExhaustiveList State := @ExhaustivePairList (concrete.Location chs) (Region p) _ _.

    Lemma NoDup_states: NoDup (regions p) -> NoDup states.
    Proof. apply NoDup_ExhaustivePairList, c.NoDup_locations. Qed.

  End space_derivatives.

  (* Given two sets of abstraction parameters, we can combine these to make
   finer-grained abstraction parameters where each region corresponds to the
   intersection of two regions of the respective abstraction parameters.

   For instance, for a hybrid system whose continuous state space is the plane,
   we could first define abstraction parameters with regions corresponding to X
   intervals, then define abstraction parameters with regions corresponding to
   Y intervals, and then finally combine these using param_prod below to
   produce abstraction parameters with regions corresponding to squares. *)

  Section prod_space.

    Variables ap ap': Space.

    Let in_region p r := in_region ap p (fst r) /\ in_region ap' p (snd r).

    Let in_region_mor: Proper (@cs_eq _ ==> eq ==> iff) in_region.
    Proof. unfold in_region. intros x x' e r r' e'. rewrite e, e'. split; auto. Qed.

    Program Definition regions_cover_prod l p : concrete.invariant (l, p) -> DN (sig (in_region p)) :=
      fun H =>
        C1 <- contents.regions_cover ap l p H;
        C2 <- contents.regions_cover ap' l p H;
        return [=(`C1, `C2)=].
    Next Obligation.
      split; crunch.
    Qed.

    Definition prod_space: Space := Build_Space _ _
      (NoDup_ExhaustivePairList (NoDup_regions ap) (NoDup_regions ap'))
      in_region_mor regions_cover_prod.

  End prod_space.

  (* We generalize the product space above from 2 to arbitrary 'n' dimensions,
     hence generalizing abstraction by squares in 2 dimensional space to
     abstraction by hyper-cubes in n-dimensional space *)

  Section hyper_space.

    Variable n : nat.
    Variable aps : list Space.

    (* [Regions] is formed by an n-product of [Region]s of respective [Space]s,
       epxressed with heterogenous list *)
    Notation Regions aps := (@hlist _ Region aps).

    Fixpoint in_region_aux (aps : list Space) (p : concrete.Point chs) : Regions aps -> Prop :=
      match aps as aps return Regions aps -> Prop with
      | [] => fun _ => True
      | s::ss => fun rs =>
          in_region s p (hhd rs) /\ @in_region_aux ss p (htl rs)
      end.

    Obligation Tactic := crunch.

    Program Fixpoint regions_cover_aux (aps : list Space) l p :
      concrete.invariant (l, p) -> DN (sig (@in_region_aux aps p)) :=
      match aps with
      | [] => fun H => return [= HNil (H:=_) =]
      | s::ss => fun H =>
          C1 <- contents.regions_cover s l p H;
          C2 <- @regions_cover_aux ss l p H;
          return [= `C1:::`C2 =]
      end.

    Lemma in_region_aux_morph : Proper (@st_eq _ ==> eq ==> iff) (@in_region_aux aps).
    Proof with auto.
      repeat intro.
      subst.
      induction aps. firstorder.
      split; intros [H0 H1]; split.
            apply (in_region_mor a x y H (refl_equal _))...
          apply IHl...
        apply (in_region_mor a x y H (refl_equal _))...
      apply IHl...
    Qed.

    Obligation Tactic := program_simpl; auto with typeclass_instances.

    Hint Resolve NoDup_regions.

    Program Definition hyper_space : Space := @Build_Space (Regions aps) _ _ _
      (@in_region_aux aps) in_region_aux_morph (@regions_cover_aux aps).
    Next Obligation.
      set (w := NoDup_ExhaustiveHList); simpl in w; apply w; auto.
    Qed.

  End hyper_space.

  Variable ap: Space.

  Instance abs: Container (c.State chs) (State ap) := fun s s' =>
    c.location s = location s' /\ c.point s ∈ region s'.

  Hint Unfold abs.

  Section CoverRelandsuch.

    Context `{Container (c.State chs) C} `{Container (State ap) D} (cs: C) (ss: D).

    Definition CompleteCover: Prop := forall s: c.State chs, s ∈ cs -> forall r: State ap, s ∈ r -> r ∈ ss.
    Definition SharedCover: Prop := forall s: c.State chs, s ∈ cs -> DN (exists r: State ap, s ∈ r /\ r ∈ ss).

  End CoverRelandsuch.

  Definition CompleteCoverList (cs: c.State chs -> Prop): Type :=
    sig (LazyProp ∘ (CompleteCover cs: list (State ap) -> Prop)).

  Section safe.

    (* We're looking for a set of abstract states... *)

    Variables (reachable: State ap -> Prop)

    (* ... that together cover concretely reachable states in a shared manner: *)

      (reachable_respect: SharedCover concrete.reachable reachable).

    (* Because then, abstract unreachability implies concrete unreachability *)

    Lemma safe (s: concrete.State chs): (forall s', s ∈ s' -> ~ reachable s') -> ~ concrete.reachable s.
    Proof with eauto.
      unfold not.
      intros.
      apply DN_free, (DN_bind (reachable_respect H0))...
      intros [s' [H1 H2]]...
    Qed.

    (* And consequently, if abstract reachability is overestimatable, reachability of an
     overestimatable concrete set is overestimatable: *)

    Hint Unfold intersection overlap nonempty.

    Context
      `(forall s, overestimation (reachable s))
      (cstates: concrete.State chs -> Prop)
      (astates: CompleteCoverList cstates).

    Program Definition some_reachable_1: overestimation (overlap cstates concrete.reachable) :=
      @overestimate (exists u, In u (proj1_sig astates) /\ reachable u) overestimate.

    Next Obligation. Proof with eauto.
      intros [x [Px r]].
      apply (@safe x)...
      repeat intro.
      apply (@overestimation_false (exists u, In u (proj1_sig astates) /\ reachable u) _ H0)...
        (* todo: ugly *)
      destruct astates.
      pose proof (c ())...
    Qed.

  End safe.

  Definition cont_trans (l: c.Location chs): relation (Region ap)
    := fun r r' => exists p q, p ∈ r /\ q ∈ r' /\ c.can_flow chs l p q.

  Definition sharing_transition_overestimator (R: relation (concrete.State chs)): Type :=
    forall s: State ap, sig (fun l: list (State ap) => LazyProp (NoDup l /\
      SharedCover (concrete.invariant ∩ (overlap s ∘ util.flip R)) l)).
        (* the invariant part is important because it means the overestimators can use
         regions_cover in their correctness proofs (which we do actually need) *)

  (* We define abstract versions of initiality, invariance, and guards, suitable
   as overestimation predicates. *)

  Definition Initial: State ap -> Prop := overlap (@concrete.initial chs).
  Definition invariant: State ap -> Prop := overlap (@concrete.invariant chs).

  Definition guard (l: concrete.Location chs) (r: Region ap) (l': concrete.Location chs): Prop
    := exists p, p ∈ r /\ concrete.guard _ (l, p) l'.

  Record System: Type :=
    { initial_dec: overestimator (overlap (@concrete.initial chs))
    ; disc_trans_over: sharing_transition_overestimator (@concrete.disc_trans _)
    ; cont_trans_over: sharing_transition_overestimator (@concrete.cont_trans _)
    }.

  Variable ahs: System.

  Definition trans (b: bool): relation (State ap) :=
    fun s1 s2 => s2 ∈ if b then proj1_sig (cont_trans_over ahs s1) else proj1_sig (disc_trans_over ahs s1).

  Definition reachable (s: State ap): Prop :=
    exists is: State ap,
      overestimation_bool (initial_dec ahs is) = true /\ alternate trans is s.

  Hint Unfold Initial predicate_container containers.intersection In.

  Lemma reachable_alternating_concrete_abstract (i s: c.State chs):
    concrete.initial i -> forall b, end_with (@concrete.trans_kind chs) b i s ->
      DN (exists is, overestimation_bool (initial_dec ahs is) = true /\
        exists s', s ∈ s' /\ end_with trans (negb b) is s').
  Proof with eauto; auto 20.
    intros H b H0.
    induction H0 as [| b i (l, p) H0 IH [l' p']].
      destruct s as [l cp].
      apply (DN_fmap (regions_cover ap l cp (concrete.invariant_initial chs _ H))).
      intros [x i].
      exists (l, x).
      split.
        apply overestimation_true.
        exists (l, cp).
        auto 20.
      exists (l, x)...
    apply (DN_bind (IH H)).
    intros [ir [H2 [[al r] [[H3 H5] H4]]]]. clear IH.
    apply (DN_exists (x := ir)).
    apply (DN_liftM2 (@conj _ _))...
    simpl in H3. subst.
    cut (DN (exists r0, In p' r0 /\ trans (negb b) (al, r) (l', r0))).
      intros.
      apply (DN_fmap H3).
      intros [x [H6 H7]].
      exists (l', x).
      eauto 30.
    destruct b; simpl in H0 |- *.
      unfold trans.
      destruct (disc_trans_over ahs (al, r)).
      simpl.
      destruct l...
      unfold SharedCover in H6.
      unfold In at 1 in H6.
      unfold predicate_container in H6.
      simpl in H1.
      cut (DN (exists r: State ap, In (l', p') r /\ In r x)).
        intro.
        apply (DN_fmap H7).
        intro.
        destruct H8.
        destruct H8.
        exists (region x0).
        destruct H8.
        split...
        destruct x0.
        simpl in H8. subst...
      apply H6.
      split...
        destruct H1. intuition.
      exists (al, p)...
    unfold trans.
    destruct cont_trans_over.
    simpl.
    destruct l...
    unfold SharedCover, In, predicate_container in H6.
    simpl in H1.
    cut (DN (exists r : State ap, (l', p') ∈ r /\ r ∈ x)).
      intro.
      apply (DN_fmap H7). clear H7.
      intros [x0 [[H7 H9] H8]].
      exists (region x0).
      split...
      simpl in H7. subst.
      destruct x0...
    apply H6.
    split.
      apply concrete.reachable_invariant.
      apply -> concrete.alternating_reachable.
      hnf.
      exists i.
      split...
      unfold alternate.
      exists false.
      eauto.
    exists (al, p)...
  Qed.

  Hint Unfold alternate.

  Lemma reachable_respect: SharedCover concrete.reachable reachable.
  Proof.
    unfold SharedCover.
    intros.
    apply concrete.alternating_reachable in H.
    destruct H as [s' [H0 [x0 H1]]].
    apply (DN_fmap (@reachable_alternating_concrete_abstract s' s H0 x0 H1)).
    intros [x [y [A [B C]]]].
    unfold reachable.
    eauto 10.
  Qed.

  Definition some_reachable_2 := @some_reachable_1 reachable reachable_respect.

End contents.

Existing Instance in_region.
Existing Instance Region_eq_dec.
Existing Instance regions.
Existing Instance in_region_mor.


Require Import StlcIso.CanForm.
Require Import StlcIso.SpecEvaluation.
Require Import StlcIso.SpecTyping.
Require Import StlcIso.LemmasTyping.
Require Import StlcIso.LemmasProgramContext.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     subst*);
  try discriminate;
  eauto with eval.

Ltac progressH :=
  match goal with
    | [ H: ⟪ _ : _ r∈ empty ⟫ |- _         ] => inversion H
    | [ H: _ ∨ _             |- _         ] => destruct H
    | [ H: True              |- _         ] => clear H
    | [ H: False             |- _         ] => inversion H
    | [                      |- False ∨ _ ] => right
    | [                      |- True ∨ _  ] => left; auto
  end;
  stlcCanForm.

#[export]
Hint Constructors eval : pctx.
#[export]
Hint Constructors eval₀ : pctx.
#[export]
Hint Extern 20 (Value _) => cbn : pctx.
#[export]
Hint Extern 20 (ECtx _) => cbn : pctx.

(* Lemma local_progress {t U} (wt: ⟪ empty ⊢ t : U ⟫) : *)
(*   Value t ∨ *)
(*   ∃ C t₀ t₀', *)
(*     t = pctx_app t₀ C ∧ *)
(*     t₀ -->₀ t₀' ∧ *)
(*     ECtx C. *)
(* Proof. *)
(*   depind wt; *)
(*   repeat *)
(*     (try progressH; cbn in *; destruct_conjs; subst); *)
(*     eauto 20 with pctx; *)
(*     try (exists phole; cbn; eauto 20 with pctx; fail). *)
(* Qed. *)

(* Lemma progress {t U} (wt: ⟪ empty ⊢ t : U ⟫) : *)
(*   Value t ∨ *)
(*   ∃ t', t --> t'. *)
(* Proof. *)
(*   destruct (local_progress wt); destruct_conjs; *)
(*     subst; eauto using eval. *)
(* Qed. *)

Lemma canon_tunit {Γ t} :
  Value t → ⟪ Γ i⊢ t : tunit ⟫ → t = unit.
Proof.
  crush.
  inversion H0; subst; now destruct H.
Qed.

Lemma canon_tarr {Γ t τ τ'} :
  Value t → ⟪ Γ i⊢ t : tarr τ τ' ⟫
  → exists t', t = abs τ t'.
  crush.
  inversion H0; subst; destruct H; eauto.
Qed.

Lemma canon_tsum {Γ t τ τ'} :
  Value t → ⟪ Γ i⊢ t : tsum τ τ' ⟫
  → exists t', Value t' ∧ (t = inl t' ∨ t = inr t').
Proof.
  intros.
  inversion H0; subst; try destruct H; eexists t0; eauto.
Qed.

Lemma canon_trec {Γ t τ} :
  Value t → ⟪ Γ i⊢ t : trec τ ⟫ → exists t', Value t' ∧ (t = fold_ t').
Proof.
  intros.
  inversion H0; subst; try destruct H; exists t0; eauto.
Qed.

Lemma context_replacement {Γ C t t' T}
  (hyp: ∀ Γ' T', ValidEnv Γ' → ⟪ Γ' i⊢ t : T' ⟫ → ⟪ Γ' i⊢ t' : T' ⟫) :
  ValidEnv Γ →
    ⟪ Γ i⊢ pctx_app t C : T ⟫ →
    ⟪ Γ i⊢ pctx_app t' C : T ⟫.
Proof.
  intros vΓ wt; depind wt; induction C;
    crush; eauto using Typing; crushTyping.
Qed.

Lemma preservation₀ {t t'} (r : t -->₀ t') :
  ∀ {Γ τ}, ValidEnv Γ → ⟪ Γ i⊢ t : τ ⟫ → ⟪ Γ i⊢ t' : τ ⟫.
Proof.
  induction r;
    eauto using context_replacement;
    crushTyping.
Qed.

Lemma preservation {t t'} (r: t --> t') :
  ∀ {Γ τ}, ValidEnv Γ → ⟪ Γ i⊢ t : τ ⟫ → ⟪ Γ i⊢ t' : τ ⟫.
Proof.
  induction r.
  eauto using context_replacement, preservation₀.
Qed.

Lemma preservation_star {t t'} (r: t -->* t') :
  ∀ {Γ τ}, ValidEnv Γ → ⟪ Γ i⊢ t : τ ⟫ → ⟪ Γ i⊢ t' : τ ⟫.
Proof.
  induction r;
  eauto using preservation.
Qed.

Lemma termination_value {t τ} (wt: ⟪ empty i⊢ t : τ ⟫) :
  t⇓ → ∃ t', t -->* t' ∧ Value t'.
Proof.
  destruct 1; crush.
Qed.


Module Type ModWithRecord.

  Record foo : Type :=
  { A : nat
  ; B : nat
  }.
End ModWithRecord.

Module Test_ModWithRecord (M : ModWithRecord).

  Definition test1 : M.foo :=
    {| M.A := 0
     ; M.B := 2
     |}.

  Module B := M.

  Definition test2 : M.foo :=
    {| M.A := 0
     ; M.B := 2
     |}.
End Test_ModWithRecord.


Require Import Coq.Strings.String.

Require Export SystemFR.StarLemmas.
Require Export SystemFR.ErasedTermLemmas.

(* Two terms `t1` and `t2` are observationally equivalent if for any context,   *)
(* `C[t1]` reduces to true iff `C[t2]` reduces to true                          *)
Definition equivalent_terms t1 t2 :=
  is_erased_term t1 /\
  is_erased_term t2 /\
  wf t1 0 /\
  wf t2 0 /\
  pfv t1 term_var = nil /\
  pfv t2 term_var = nil /\
  forall C,
    is_erased_term C ->
    wf C 1 ->
    pfv C term_var = nil ->
      open 0 C t1 ~>* ttrue <->
      open 0 C t2 ~>* ttrue.

Notation "[ t1 ≡ t2 ]" := (equivalent_terms t1 t2) (t1 at level 60, t2 at level 60, at level 60).

Ltac equivalence_instantiate C :=
  match goal with
  | H: [ _ ≡ _ ] |- _ =>
    poseNew (Mark (H) "equivalence_instantiate");
    unshelve epose proof ((proj2 (proj2 (proj2 (proj2 (proj2 (proj2 H)))))) C _ _ _)
  end.

Lemma equivalent_terms_fv1:
  forall t1 t2,
    [ t1 ≡ t2 ] ->
    pfv t1 term_var = nil.
Proof.
  unfold equivalent_terms; steps.
Qed.

Lemma equivalent_terms_fv2:
  forall t1 t2,
    [ t1 ≡ t2 ] ->
    pfv t2 term_var = nil.
Proof.
  unfold equivalent_terms; steps.
Qed.

#[export]
Hint Immediate equivalent_terms_fv1: fv.
#[export]
Hint Immediate equivalent_terms_fv2: fv.

Lemma equivalent_terms_erased1:
  forall t1 t2,
    [ t1 ≡ t2 ] ->
    is_erased_term t1.
Proof.
  unfold equivalent_terms; steps.
Qed.

Lemma equivalent_terms_erased2:
  forall t1 t2,
    [ t1 ≡ t2 ] ->
    is_erased_term t2.
Proof.
  unfold equivalent_terms; steps.
Qed.

#[export]
Hint Immediate equivalent_terms_erased1: erased.
#[export]
Hint Immediate equivalent_terms_erased2: erased.

Lemma equivalent_terms_wf1:
  forall t1 t2 k,
    [ t1 ≡ t2 ] ->
    wf t1 k.
Proof.
  unfold equivalent_terms; steps; eauto with wf.
Qed.

Lemma equivalent_terms_wf2:
  forall t1 t2 k,
    [ t1 ≡ t2 ] ->
    wf t2 k.
Proof.
  unfold equivalent_terms; steps; eauto with wf.
Qed.

#[export]
Hint Immediate equivalent_terms_wf1: wf.
#[export]
Hint Immediate equivalent_terms_wf2: wf.

Lemma equivalent_terms_twf1:
  forall t1 t2 k,
    [ t1 ≡ t2 ] ->
    twf t1 k.
Proof.
  unfold equivalent_terms; steps; eauto with twf.
Qed.

Lemma equivalent_terms_twf2:
  forall t1 t2 k,
    [ t1 ≡ t2 ] ->
    twf t2 k.
Proof.
  unfold equivalent_terms; steps; eauto with twf.
Qed.

#[export]
Hint Immediate equivalent_terms_twf1: twf.
#[export]
Hint Immediate equivalent_terms_twf2: twf.


(* Copyright (c) 2009, Harvard University
 * All rights reserved.
 *
 * Author: Adam Chlipala
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

Require Import List.

Require Import Ynot.

Set Implicit Arguments.

Open Local Scope hprop_scope.
Open Local Scope stsepi_scope.

Module Type LIST.
  Parameter t : Set.
  Parameter rep : forall T : Set, t -> list T -> hprop.

  Parameter Nil : forall (T : Set),
    STsep __ (fun t => rep t (@nil T)).
  Parameter Cons : forall (T : Set) (ls : [list T]) (x : T) (v : t),
    STsep (ls ~~ rep v ls) (fun v' => ls ~~ rep v' (x :: ls)).

  Parameter Rev : forall (T : Set) (ls : [list T]) (v : t),
    STsep (ls ~~ rep v ls) (fun v' => ls ~~ rep v' (rev ls)).
End LIST.

Module List : LIST.
  Section List.
    Definition t := option ptr.
    Variable T : Set.

    Record node : Set := Node {
      head : T;
      tail : t
    }.

    Fixpoint rep (v : t) (ls : list T) {struct ls} : hprop :=
      match v, ls with
        | None, nil => [True]
        | Some p, x :: ls' => Exists v' :@ t,
          p --> Node x v' * [ls = x :: ls'] * rep v' ls'
        | _, _ => [False]
      end.

    Ltac t' := sep fail idtac.

    Lemma rep_None : forall ls,
      rep None ls ==> [ls = nil].
      destruct ls; t'.
    Qed.

    Lemma rep_Some : forall p ls,
      rep (Some p) ls ==> Exists x :@ T, Exists ls' :@ list T, Exists p' :@ option ptr,
      [ls = x :: ls'] * p --> Node x p' * rep p' ls'.
      destruct ls; t'.
    Qed.

    Ltac simplr :=
      simpl_IfNull;
      repeat simpl_prem ltac:(apply rep_None || apply rep_Some).

    Definition Tail (ls : list T) :=
      match ls with
        | nil => nil
        | _ :: ls' => ls'
      end.

    Lemma rev_Tail : forall (ls : list T) x ls',
      ls = x :: Tail ls
      -> rev (Tail ls) ++ x :: ls' = rev ls ++ ls'.
      intros; match goal with
                | [ H : _ |- _ ] => rewrite H
              end;
      simpl; rewrite app_ass; reflexivity.
    Qed.

    Hint Rewrite rev_Tail using assumption : Rev.

    Ltac t := sep simplr ltac:(autorewrite with Rev).

    Definition Nil : STsep __ (fun t => rep t (@nil T)).
      refine {{Return None}}; t.
    Qed.

    Definition Cons : forall (ls : [list T]) (x : T) (v : t),
      STsep (ls ~~ rep v ls) (fun v' => ls ~~ rep v' (x :: ls)).
      intros; refine (p <- New (Node x v);
        {{Return (Some p)}}); t.
    Qed.

    Definition Rev' : forall (lsX lsY : [list T]) (x y : t),
      STsep (lsX ~~ lsY ~~ rep x lsX * rep y lsY)
      (fun v => lsX ~~ lsY ~~ rep v (rev lsX ++ lsY)).
      refine (Fix4
        (fun lsX lsY x y => lsX ~~ lsY ~~ rep x lsX * rep y lsY)
        (fun lsX lsY _ _ v => lsX ~~ lsY ~~ rep v (rev lsX ++ lsY))
        (fun self lsX lsY x y =>
          IfNull x Then
            {{Return y}}
          Else
            nd <- !x;
            x ::= Node (head nd) y;;
            {{self (lsX ~~~ Tail lsX) (lsY ~~~ head nd :: lsY)
              (tail nd) (Some x)
              <@> (lsX ~~ [lsX = head nd :: Tail lsX]) }})); t.
    Qed.

    Hint Rewrite <- app_nil_end : Rev.

    Definition Rev : forall (ls : [list T]) (v : t),
      STsep (ls ~~ rep v ls) (fun v' => ls ~~ rep v' (rev ls)).
      intros; refine {{Rev' ls [nil] v None}}; t.
    Qed.

  End List.
End List.