(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export rules_integer_ring.
Require Export rules_minus.
Require Export per_props_compute.
Require Export per_props_true.
Require Export cequiv_seq_util.

Lemma equality_of_int_mkc_integer {o} :
  forall lib n,
    @equality_of_int o lib (mkc_integer n) (mkc_integer n).
Proof.
  introv; exists n; dands; spcast; eauto 3 with slow.
Qed.
Hint Resolve equality_of_int_mkc_integer : slow.

Hint Rewrite @lsubstc_mk_true : slow.
Hint Rewrite @lsubstc_mk_false : slow.

(* Two rules about div and rem state equalities. They are div_rem_sum and rem_zero. *)

(*
   H |- a = (a div b) * b + (a rem b) in Z

     By divideRemainderSum

     H |- int_eq b 0 False True
     H |- a in Z
     H |- b in Z
 *)
Definition rule_div_rem_sum {o}
           (H : barehypotheses)
           (a b : @NTerm o) :=
  let d := mk_div a b in
  let r := mk_rem a b in
  let s := mk_add (mk_mul d b) r in
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality a s  mk_int)))
    [ mk_baresequent H (mk_conclax (mk_not_eqint b (mk_integer 0))),
      mk_baresequent H (mk_conclax (mk_member a mk_int)),
      mk_baresequent H (mk_conclax (mk_member b mk_int))
    ]
    [].

(*
   H |- (0 rem b) = 0 in Z

     By remZero

     H |- int_eq b 0 False True
     H |- b in Z
 *)
Definition rule_rem_zero {o}
           (H : barehypotheses)
           (b : @NTerm o) :=
    mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_rem (mk_integer 0) b) (mk_integer 0) mk_int)))
    [ mk_baresequent H (mk_conclax (mk_not_eqint b (mk_integer 0))),
      mk_baresequent H (mk_conclax (mk_member b mk_int))
    ]
    [].

Lemma rule_div_rem_sum_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_div_rem_sum H m n).
Proof.
  unfold rule_add_inverse, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  unfold mk_not_eqint.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* we now start proving the sequent *)
  vr_seq_true.

  lsubst_tac.
  rw <- @member_equality_iff.
  teq_and_eq (@mk_int o) m (mk_add (mk_mul (mk_div m n) n) (mk_rem m n)) s1 s2 H;
    eauto 3 with slow;[].

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 hf sim) as hyp1; clear hyp2.
  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 hf sim) as hyp2; clear hyp3.
  exrepnd.
  fold_mk_arithop.
  lsubst_tac.
  autorewrite with slow in *.

  match goal with
  | [ H : cover_vars _ _ |- _ ] => clear H
  | [ H : wf_term _ |- _ ] => clear H
  end.

  allrw <- @member_member_iff.
  apply tequality_mkc_member_implies_sp in hyp3; auto;[].
  apply tequality_mkc_member_implies_sp in hyp0; auto;[].

  revert hyp0 hyp3.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms n2.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms m2.
  introv hyp0 hyp3.

  eapply equality_trans;[exact hyp3|].
  apply equality_sym in hyp0; apply equality_refl in hyp0.
  apply equality_sym in hyp3; apply equality_refl in hyp3.
  eapply tequality_preserving_equality in hyp5;[|eauto];[].
  clear dependent m1; clear dependent n1.

  allrw @member_int_iff; spcast; exrepnd.
  apply equality_in_int; exists z; dands; spcast; auto;[].

  assert (z0 <> 0%Z) as nz.
  {
    clear - hyp2 hyp5.
    (* from these two hyps we can prove z0 is not 0 *)
    introv xx; subst.
    rewrite <- mkc_not_eqint_eq in hyp5.
    eapply cequivc_preserving_equality in hyp5;
      [|apply computes_to_valc_implies_cequivc;
        eapply mkc_not_eqint_comp1;eauto 3 with slow].
    apply equality_in_false in hyp5; tcsp.
  }

  (* now we have z0 not eq 0 *)

  assert (mkc_integer z = @mkc_integer o (((Z.quot z z0)*z0)+(Z.rem z z0))) as eq.
  { apply mkc_integer_eq_iff.
    pose proof Z.quot_rem z z0.
    rw Z.mul_comm; auto. }

  rewrite mkc_add_is_mkc_arithop.
  rw eq; repeat (apply computes_to_valc_arithop;auto).
Qed.

Lemma rule_rem__zero_true {o} :
  forall lib (H : barehypotheses)
         (n : @NTerm o),
    rule_true lib (rule_rem_zero H n).
Proof.
  unfold rule_add_inverse, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  unfold mk_not_eqint.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as hyp1; clear hyp2.

  exrepnd.
  fold_mk_arithop.
  lsubst_tac.
  repeat rw @lsubstc_mk_true in hyp2.
  repeat rw @lsubstc_mk_false in hyp2.
  repeat rw @lsubstc_mk_true in hyp3.
  repeat rw @lsubstc_mk_false in hyp3.
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms n2.
  assert (equality_of_int lib (mkc_integer 0) (mkc_integer 0)).
    apply equality_of_int_mkc_integer.
  split.
  - (* tequality *)
     apply @tequality_mkc_equality2; split.
    apply tequality_int. split;
    rw @equality_in_int;
    repeat (apply equality_of_int_arithop; auto).
    apply equality_of_int_mkc_integer; auto.

  - (* equality *)
     rw @member_eq. rw <- @member_equality_iff.
     rw @equality_in_int.
     clear dependent n2.
    allrw @member_int_iff. spcast. exrepnd.
   unfold equality_of_int.
   exists 0%Z.
   sp; auto; spcast; auto.
    assert (z <> 0%Z) as nz. clear - hyp0 hyp3.
    (* from these two hyps we can prove z is not 0 *)
    pose proof (Z.eq_dec z 0) as xx. destruct xx; auto.
    assert (equality lib mkc_axiom mkc_axiom mkc_false).
    pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
    specialize (r1 mkc_axiom mkc_axiom (mkc_inteq n1 (mkc_integer 0) mkc_false mkc_true) mkc_false).
    apply r1; auto.  rw e in hyp0. clear -hyp0.
    apply computes_to_valc_implies_cequivc.
    fold (@mkc_not_eqint o).
    pose proof (@mkc_not_eqint_comp1 o lib n1 (mkc_integer 0) 0 0) as xx.
     apply xx; auto.
     apply computes_to_valc_refl. apply iscvalue_mkc_integer.
   (* we have a member of False *)
    rw @equality_in_false in H; auto.

   (* now we have z not eq 0 *)
    pose proof (@computes_to_valc_arithop o lib ArithOpRem (mkc_integer 0) n1 0 z) as xx.
    assert (get_arith_op ArithOpRem 0 z = 0%Z).
    simpl. apply Z.rem_0_l; auto.
    rw H1 in xx. apply xx; auto; apply computes_to_valc_refl; apply iscvalue_mkc_integer.
    apply computes_to_valc_refl; apply iscvalue_mkc_integer.
Qed.

(* The next two rule give the sign of (a rem b) *)

(*
   H |- less (a rem b) 0 False True

     By remPositive

     H |- less 0 a True False
     H |- int_eq b 0 False True
     H |- a in Z
     H |- b in Z
 *)
Definition rule_rem_positive {o}
           (H : barehypotheses)
           (a b : @NTerm o) :=
    mk_rule
    (mk_baresequent H (mk_conclax (mk_not_less_than (mk_rem a b) (mk_integer 0))))
    [ mk_baresequent H (mk_conclax (mk_less_than (mk_integer 0) a)),
      mk_baresequent H (mk_conclax (mk_not_eqint b (mk_integer 0))),
      mk_baresequent H (mk_conclax (mk_member a mk_int)),
      mk_baresequent H (mk_conclax (mk_member b mk_int))
    ]
    [].

(*
   H |- less 0 (a rem b) False True

     By remNegative

     H |- less a 0 True False
     H |- int_eq b 0 False True
     H |- a in Z
     H |- b in Z
 *)
Definition rule_rem_negative {o}
           (H : barehypotheses)
           (a b : @NTerm o) :=
    mk_rule
    (mk_baresequent H (mk_conclax (mk_not_less_than (mk_integer 0) (mk_rem a b) )))
    [ mk_baresequent H (mk_conclax (mk_less_than a (mk_integer 0))),
      mk_baresequent H (mk_conclax (mk_not_eqint b (mk_integer 0))),
      mk_baresequent H (mk_conclax (mk_member a mk_int)),
      mk_baresequent H (mk_conclax (mk_member b mk_int))
    ]
    [].

Lemma rule_rem_positive_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_rem_positive H m n).
Proof.
  unfold rule_rem_positive, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  unfold mk_not_eqint.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  rename Hyp3 into hyp4.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as hyp1; clear hyp2.
  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 eqh sim) as hyp2; clear hyp3.
  vr_seq_true in hyp4.
  pose proof (hyp4 s1 s2 eqh sim) as hyp3; clear hyp4.
  exrepnd.
  unfold mk_less_than in hyp7.
  unfold mk_not_less_than.
  fold_mk_arithop.
  lsubst_tac.
  allrw @lsubstc_mk_true .
  allrw @lsubstc_mk_false .
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp4; auto.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms m2.
  generalize_lsubstc_terms n2.
  apply @equality_of_int_imp_tt in hyp4. destruct hyp4.
  apply @equality_of_int_imp_tt in hyp0. destruct hyp0.
  exrepnd.
  assert (x0 <> 0%Z) as nz. clear - hyp1 p1.
    (* from these two hyps we can prove x0 is not 0 *)
    pose proof (Z.eq_dec x0 0) as xx. destruct xx; auto.
    assert (equality lib mkc_axiom mkc_axiom mkc_false).
    pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
    specialize (r1 mkc_axiom mkc_axiom (mkc_inteq n1 (mkc_integer 0) mkc_false mkc_true) mkc_false).
    apply r1; auto.  rw e in p1. clear -p1.
    apply computes_to_valc_implies_cequivc.
    fold (@mkc_not_eqint o).
    pose proof (@mkc_not_eqint_comp1 o lib n1 (mkc_integer 0) 0 0) as xx.
     apply xx; auto.
     apply computes_to_valc_refl. apply iscvalue_mkc_integer.
   (* we have a member of False *)
    rw @equality_in_false in H; auto.
   (* now we have x0 not eq 0 *)
    assert (0 <= x)%Z.  clear - hyp7 p2.
    (* From these two hyps we can prove 0 <= x *)
     pose proof (Z.le_decidable 0 x) as xx. destruct xx; auto.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less (mkc_integer 0) m1 mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib (mkc_integer 0) m1 0 x) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H0. inversion H0.
   (* Now we have 0 <= x *)
   assert (0 <= Z.rem x x0)%Z. apply Z.rem_nonneg; auto.
  split.
  - (* tequality *) apply @tequality_mkc_less.
    exists (Z.rem x x0). exists 0%Z. exists (Z.rem x x0). exists 0%Z.
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m1 n1 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast. apply computes_to_valc_refl. apply iscvalue_mkc_integer.
    split.
    unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m2 n2 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast. apply computes_to_valc_refl. apply iscvalue_mkc_integer.
    assert (((0 <= Z.rem x x0)%Z # (0 <= Z.rem x x0)%Z # tequality lib mkc_true mkc_true)).
    split;auto; split;auto.
    auto.
  - (* equality *)

     rw @equality_in_less. exists (Z.rem x x0). exists 0%Z.
     split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m1 n1 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast. apply computes_to_valc_refl. apply iscvalue_mkc_integer.
    assert ((0 <= Z.rem x x0)%Z # equality lib mkc_axiom mkc_axiom mkc_true).
    split; auto.
    auto.
Qed.

Lemma rule_rem_negative_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_rem_negative H m n).
Proof.
  unfold rule_rem_negative, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  unfold mk_not_eqint.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  rename Hyp3 into hyp4.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as hyp1; clear hyp2.
  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 eqh sim) as hyp2; clear hyp3.
  vr_seq_true in hyp4.
  pose proof (hyp4 s1 s2 eqh sim) as hyp3; clear hyp4.
  exrepnd.
  unfold mk_less_than in hyp7.
  unfold mk_not_less_than.
  fold_mk_arithop.
  lsubst_tac.
  allrw @lsubstc_mk_true .
  allrw @lsubstc_mk_false .
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp4; auto.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms m2.
  generalize_lsubstc_terms n2.
  apply @equality_of_int_imp_tt in hyp4. destruct hyp4.
  apply @equality_of_int_imp_tt in hyp0. destruct hyp0.
  exrepnd.
  assert (x0 <> 0%Z) as nz. clear - hyp1 p1.
    (* from these two hyps we can prove x0 is not 0 *)
    pose proof (Z.eq_dec x0 0) as xx. destruct xx; auto.
    assert (equality lib mkc_axiom mkc_axiom mkc_false).
    pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
    specialize (r1 mkc_axiom mkc_axiom (mkc_inteq n1 (mkc_integer 0) mkc_false mkc_true) mkc_false).
    apply r1; auto.  rw e in p1. clear -p1.
    apply computes_to_valc_implies_cequivc.
    fold (@mkc_not_eqint o).
    pose proof (@mkc_not_eqint_comp1 o lib n1 (mkc_integer 0) 0 0) as xx.
     apply xx; auto.
     apply computes_to_valc_refl. apply iscvalue_mkc_integer.
   (* we have a member of False *)
    rw @equality_in_false in H; auto.
   (* now we have x0 not eq 0 *)
    assert (x <= 0)%Z.  clear - hyp7 p2.
    (* From these two hyps we can prove x <= 0 *)
     pose proof (Z.le_decidable x 0) as xx. destruct xx; auto.
     assert ( 0 < x)%Z. omega. clear H.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less m1 (mkc_integer 0) mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib m1 (mkc_integer 0) x 0) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H0.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H. inversion H.
   (* Now we have x <= 0 *)
   assert (Z.rem x x0 <= 0)%Z. apply Z.rem_nonpos; auto.
  split.
  - (* tequality *) apply @tequality_mkc_less.
    exists 0%Z. exists (Z.rem x x0). exists 0%Z. exists (Z.rem x x0).
    split. unfold ccomputes_to_valc. spcast. apply computes_to_valc_refl. apply iscvalue_mkc_integer.
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m1 n1 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast. apply computes_to_valc_refl. apply iscvalue_mkc_integer.
    split.
    unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m2 n2 x x0) as xx.
    apply xx; auto.
    assert  ((Z.rem x x0 <= 0)%Z # (Z.rem x x0 <= 0)%Z # tequality lib mkc_true mkc_true).
    split;auto; split;auto.
    auto.
  - (* equality *)

     rw @equality_in_less. exists 0%Z. exists (Z.rem x x0).
     split. unfold ccomputes_to_valc. spcast. apply computes_to_valc_refl. apply iscvalue_mkc_integer.
     split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m1 n1 x x0) as xx.
    apply xx; auto.

    assert ((Z.rem x x0 <= 0)%Z # equality lib mkc_axiom mkc_axiom mkc_true).
    split; auto.
    auto.
Qed.

(* The four remaining rules specify the magnitude of (a rem b) *)

(*
   H |- less (a rem b) b True False

     By remainderBounds1

     H |- less 0 a True False
     H |- less 0 b True False
     H |- a in Z
     H |- b in Z
 *)
Definition rule_rem_bounds1 {o}
           (H : barehypotheses)
           (a b : @NTerm o) :=
    mk_rule
    (mk_baresequent H (mk_conclax (mk_less_than (mk_rem a b) b)))
    [ mk_baresequent H (mk_conclax (mk_less_than (mk_integer 0) a)),
      mk_baresequent H (mk_conclax (mk_less_than (mk_integer 0) b)),
      mk_baresequent H (mk_conclax (mk_member a mk_int)),
      mk_baresequent H (mk_conclax (mk_member b mk_int))
    ]
    [].

(*
   H |- less (-b) (a rem b) True False

     By remainderBounds2

     H |- less a 0 True False
     H |- less 0 b True False
     H |- a in Z
     H |- b in Z
 *)
Definition rule_rem_bounds2 {o}
           (H : barehypotheses)
           (a b : @NTerm o) :=
    mk_rule
    (mk_baresequent H (mk_conclax (mk_less_than (mk_minus b) (mk_rem a b) )))
    [ mk_baresequent H (mk_conclax (mk_less_than a (mk_integer 0))),
      mk_baresequent H (mk_conclax (mk_less_than (mk_integer 0) b)),
      mk_baresequent H (mk_conclax (mk_member a mk_int)),
      mk_baresequent H (mk_conclax (mk_member b mk_int))
    ]
    [].

(*
   H |- less b (a rem b) True False

     By remainderBounds3

     H |- less a 0 True False
     H |- less b 0 True False
     H |- a in Z
     H |- b in Z
 *)
Definition rule_rem_bounds3 {o}
           (H : barehypotheses)
           (a b : @NTerm o) :=
    mk_rule
    (mk_baresequent H (mk_conclax (mk_less_than b (mk_rem a b) )))
    [ mk_baresequent H (mk_conclax (mk_less_than a (mk_integer 0))),
      mk_baresequent H (mk_conclax (mk_less_than b (mk_integer 0))),
      mk_baresequent H (mk_conclax (mk_member a mk_int)),
      mk_baresequent H (mk_conclax (mk_member b mk_int))
    ]
    [].

(*
   H |- less (a rem b) (-b) True False

     By remainderBounds4

     H |- less 0 a True False
     H |- less b 0 True False
     H |- a in Z
     H |- b in Z
 *)
Definition rule_rem_bounds4 {o}
           (H : barehypotheses)
           (a b : @NTerm o) :=
    mk_rule
    (mk_baresequent H (mk_conclax (mk_less_than (mk_rem a b) (mk_minus b))))
    [ mk_baresequent H (mk_conclax (mk_less_than (mk_integer 0) a)),
      mk_baresequent H (mk_conclax (mk_less_than b (mk_integer 0))),
      mk_baresequent H (mk_conclax (mk_member a mk_int)),
      mk_baresequent H (mk_conclax (mk_member b mk_int))
    ]
    [].

Lemma rule_rem_bounds1_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_rem_bounds1 H m n).
Proof.
  unfold rule_rem_bounds1, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  unfold mk_not_eqint.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  rename Hyp3 into hyp4.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as hyp1; clear hyp2.
  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 eqh sim) as hyp2; clear hyp3.
  vr_seq_true in hyp4.
  pose proof (hyp4 s1 s2 eqh sim) as hyp3; clear hyp4.
  exrepnd.
  unfold mk_less_than in hyp7.
  unfold mk_less_than in hyp1.
  unfold mk_less_than.
  fold_mk_arithop.
  lsubst_tac.
  allrw @lsubstc_mk_true .
  allrw @lsubstc_mk_false .
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp4; auto.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms m2.
  generalize_lsubstc_terms n2.
  apply @equality_of_int_imp_tt in hyp4. destruct hyp4.
  apply @equality_of_int_imp_tt in hyp0. destruct hyp0.
  exrepnd.
  assert (0 < x)%Z.  clear - hyp7 p2.
    (* From these two hyps we can prove 0 < x *)
     pose proof (Z.lt_decidable 0 x) as xx. destruct xx; auto.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less (mkc_integer 0) m1 mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib (mkc_integer 0) m1 0 x) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H0. inversion H0.
   (* Now we have 0 < x *)
  assert (0 < x0)%Z.  clear - hyp1 p1.
    (* From these two hyps we can prove 0 < x0 *)
     pose proof (Z.lt_decidable 0 x0) as xx. destruct xx; auto.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less (mkc_integer 0) n1 mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib (mkc_integer 0) n1 0 x0) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H0. inversion H0.
   (* Now we have 0 < x0 *)

  assert (x0 <> 0%Z) as nz. omega.
  (* now we have x0 not eq 0 *)

   assert (Z.rem x x0 < x0)%Z. apply Z.rem_bound_pos. omega. auto.
  split.
  - (* tequality *) apply @tequality_mkc_less.
    exists (Z.rem x x0). exists x0. exists (Z.rem x x0). exists x0.
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m1 n1 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast. auto.
    split.
    unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m2 n2 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast. auto.
    assert  ((Z.rem x x0 < x0)%Z # (Z.rem x x0 < x0)%Z # tequality lib mkc_true mkc_true).
    split;auto; split;auto.
    auto.
  - (* equality *)

     rw @equality_in_less. exists (Z.rem x x0). exists x0.
     split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m1 n1 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast. auto.

    assert ((Z.rem x x0 < x0)%Z # equality lib mkc_axiom mkc_axiom mkc_true).
    split; auto.
    auto.
Qed.

Lemma rule_rem_bounds2_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_rem_bounds2 H m n).
Proof.
  unfold rule_rem_bounds2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  unfold mk_not_eqint.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  rename Hyp3 into hyp4.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as hyp1; clear hyp2.
  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 eqh sim) as hyp2; clear hyp3.
  vr_seq_true in hyp4.
  pose proof (hyp4 s1 s2 eqh sim) as hyp3; clear hyp4.
  exrepnd.
  unfold mk_less_than in hyp7.
  unfold mk_less_than in hyp1.
  unfold mk_less_than.
  fold_mk_arithop.
  lsubst_tac.
  allrw @lsubstc_mk_true .
  allrw @lsubstc_mk_false .
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp4; auto.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms m2.
  generalize_lsubstc_terms n2.
  apply @equality_of_int_imp_tt in hyp4. destruct hyp4.
  apply @equality_of_int_imp_tt in hyp0. destruct hyp0.
  exrepnd.
  assert (x < 0)%Z.  clear - hyp7 p2.
    (* From these two hyps we can prove  x< 0 *)
     pose proof (Z.lt_decidable x 0) as xx. destruct xx; auto.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less n1 (mkc_integer 0) mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib n1 (mkc_integer 0) x 0) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H0. inversion H0.
   (* Now we have x < 0 *)
  assert (0 < x0)%Z.  clear - hyp1 p1.
    (* From these two hyps we can prove 0 < x0 *)
     pose proof (Z.lt_decidable 0 x0) as xx. destruct xx; auto.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less (mkc_integer 0) m1 mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib (mkc_integer 0) m1 0 x0) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H0. inversion H0.
   (* Now we have 0 < x0 *)

  assert (x0 <> 0%Z) as nz. omega.
  (* now we have x0 not eq 0 *)

   assert ( -(x0) < Z.rem x x0 )%Z.
    assert ( Z.abs (Z.rem x x0) < Z.abs x0)%Z. apply Z.rem_bound_abs; auto.
    rw Z.abs_lt in H2. rw Z.abs_eq in H2; auto. destruct H2; auto. omega.
   assert (computes_to_valc lib (mkc_minus m1) (mkc_integer (- x0))).
    pose proof (@implies_computes_to_valc_minus o lib) as xx. apply xx; auto.
  split.
  - (* tequality *) apply @tequality_mkc_less.
     exists ((-x0)%Z). exists (Z.rem x x0). exists ((-x0)%Z). exists (Z.rem x x0).
    split. unfold ccomputes_to_valc. spcast. auto.
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem n1 m1 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@implies_computes_to_valc_minus o lib) as xx. apply xx; auto.
    split.
    unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem n2 m2 x x0) as xx.
    apply xx; auto.
    assert ((- x0 < Z.rem x x0)%Z # (- x0 < Z.rem x x0)%Z # tequality lib mkc_true mkc_true).
    split;auto; split;auto.
    auto.
  - (* equality *)

     rw @equality_in_less. exists ((-x0)%Z). exists (Z.rem x x0).
     split. unfold ccomputes_to_valc. spcast. auto.
     split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem n1 m1 x x0) as xx.
    apply xx; auto.
    assert ((- x0 < Z.rem x x0)%Z # equality lib mkc_axiom mkc_axiom mkc_true).
    split; auto.
    auto.
Qed.

Lemma rule_rem_bounds3_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_rem_bounds3 H m n).
Proof.
  unfold rule_rem_bounds3, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  unfold mk_not_eqint.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  rename Hyp3 into hyp4.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as hyp1; clear hyp2.
  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 eqh sim) as hyp2; clear hyp3.
  vr_seq_true in hyp4.
  pose proof (hyp4 s1 s2 eqh sim) as hyp3; clear hyp4.
  exrepnd.
  unfold mk_less_than in hyp7.
  unfold mk_less_than in hyp1.
  unfold mk_less_than.
  fold_mk_arithop.
  lsubst_tac.
  allrw @lsubstc_mk_true .
  allrw @lsubstc_mk_false .
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp4; auto.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms m2.
  generalize_lsubstc_terms n2.
  apply @equality_of_int_imp_tt in hyp4. destruct hyp4.
  apply @equality_of_int_imp_tt in hyp0. destruct hyp0.
  exrepnd.
  assert (x < 0)%Z.  clear - hyp7 p2.
    (* From these two hyps we can prove x < 0*)
     pose proof (Z.lt_decidable x 0) as xx. destruct xx; auto.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less n1 (mkc_integer 0) mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib n1 (mkc_integer 0) x 0) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H0. inversion H0.
   (* Now we have x < 0 *)
  assert (x0 < 0 )%Z.  clear - hyp1 p1.
    (* From these two hyps we can prove x0 < 0 *)
     pose proof (Z.lt_decidable x0 0) as xx. destruct xx; auto.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less m1 (mkc_integer 0) mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib m1 (mkc_integer 0) x0 0) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H0. inversion H0.
   (* Now we have x0  < 0*)

  assert (x0 <> 0%Z) as nz. omega.
  (* now we have x0 not eq 0 *)

   assert (x0 < Z.rem x x0)%Z.
    assert ( Z.abs (Z.rem x x0) < Z.abs x0)%Z. apply Z.rem_bound_abs; auto.
    rw Z.abs_lt in H2. destruct H2. rw Z.abs_neq in H2; omega.
  split.
  - (* tequality *) apply @tequality_mkc_less.
    exists x0. exists (Z.rem x x0). exists x0. exists (Z.rem x x0).
    split. unfold ccomputes_to_valc. spcast. auto.
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem n1 m1 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast. auto.
    split.
    unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem n2 m2 x x0) as xx.
    apply xx; auto.

    assert ((x0 < Z.rem x x0)%Z # (x0 < Z.rem x x0)%Z # tequality lib mkc_true mkc_true).
    split;auto; split;auto.
    auto.
  - (* equality *)

     rw @equality_in_less. exists x0. exists (Z.rem x x0).
     split. unfold ccomputes_to_valc. spcast. auto.
     split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem n1 m1 x x0) as xx.
    apply xx; auto.
    assert ((x0 < Z.rem x x0)%Z # equality lib mkc_axiom mkc_axiom mkc_true).
    split; auto.
    auto.
Qed.

Lemma rule_rem_bounds4_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_rem_bounds4 H m n).
Proof.
  unfold rule_rem_bounds4, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  unfold mk_not_eqint.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  rename Hyp3 into hyp4.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as hyp1; clear hyp2.
  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 eqh sim) as hyp2; clear hyp3.
  vr_seq_true in hyp4.
  pose proof (hyp4 s1 s2 eqh sim) as hyp3; clear hyp4.
  exrepnd.
  unfold mk_less_than in hyp7.
  unfold mk_less_than in hyp1.
  unfold mk_less_than.
  fold_mk_arithop.
  lsubst_tac.
  allrw @lsubstc_mk_true .
  allrw @lsubstc_mk_false .
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp4; auto.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms m2.
  generalize_lsubstc_terms n2.
  apply @equality_of_int_imp_tt in hyp4. destruct hyp4.
  apply @equality_of_int_imp_tt in hyp0. destruct hyp0.
  exrepnd.
  assert (0 < x)%Z.  clear - hyp7 p2.
    (* From these two hyps we can prove 0 < x *)
     pose proof (Z.lt_decidable 0 x) as xx. destruct xx; auto.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less (mkc_integer 0) m1 mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib (mkc_integer 0) m1 0 x) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H0. inversion H0.
   (* Now we have 0 < x *)
   assert (x0 < 0)%Z.  clear - hyp1 p1.
    (* From these two hyps we can prove x0< 0 *)
     pose proof (Z.lt_decidable x0 0) as xx. destruct xx; auto.
     assert (equality lib mkc_axiom mkc_axiom mkc_false).
     pose proof (@respects_cequivc_equality o lib). destruct X. destruct p.
    unfold respects3_r in r1.
     specialize (r1 mkc_axiom mkc_axiom (mkc_less n1 (mkc_integer 0) mkc_true mkc_false) mkc_false).
     apply r1; auto.
     apply computes_to_valc_implies_cequivc.
     pose proof (@mkc_less_than_comp2 o lib n1 (mkc_integer 0) x0 0 ) as xx.
     rw @mkc_less_than_eq in xx.
     apply xx; auto. apply computes_to_valc_refl. apply iscvalue_mkc_integer. clear - H.
     omega.
    (* we have a member of False *)
    rw @equality_in_false in H0. inversion H0.
   (* Now we have  x0 < 0 *)

  assert (x0 <> 0%Z) as nz. omega.
  (* now we have x0 not eq 0 *)

   assert ( Z.rem x x0  < -(x0))%Z.
    assert ( Z.abs (Z.rem x x0) < Z.abs x0)%Z. apply Z.rem_bound_abs; auto.
    rw Z.abs_lt in H2. rw Z.abs_neq in H2; auto. destruct H2; auto. omega.
   assert (computes_to_valc lib (mkc_minus n1) (mkc_integer (- x0))).
    pose proof (@implies_computes_to_valc_minus o lib) as xx. apply xx; auto.
  split.
  - (* tequality *) apply @tequality_mkc_less.
     exists (Z.rem x x0). exists ((-x0)%Z). exists (Z.rem x x0). exists ((-x0)%Z).
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m1 n1 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@implies_computes_to_valc_minus o lib) as xx. apply xx; auto.
    split.
    unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m2 n2 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@implies_computes_to_valc_minus o lib) as xx. apply xx; auto.
    assert  ((Z.rem x x0 < - x0)%Z # (Z.rem x x0 < - x0)%Z # tequality lib mkc_true mkc_true).
    split;auto; split;auto.
    auto.
  - (* equality *)

     rw @equality_in_less. exists (Z.rem x x0). exists ((-x0)%Z).
    split. unfold ccomputes_to_valc. spcast.
    pose proof (@computes_to_valc_arithop o lib ArithOpRem m1 n1 x x0) as xx.
    apply xx; auto.
    split. unfold ccomputes_to_valc. spcast. auto.
    assert ((Z.rem x x0 < - x0)%Z # equality lib mkc_axiom mkc_axiom mkc_true).
    split; auto.
    auto.
Qed.


Require Import set.

Inductive Void : Type :=.

Definition absurd (x:Void) : set :=
    match x with
    end.

Definition zero : set := mkset Void absurd.

Notation "0" := (zero).


From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude.
From VLSM.Core Require Import VLSM VLSMProjections.VLSMInclusion VLSMProjections.VLSMEmbedding.

(** * VLSM Trace Equality

  We can also define VLSM _equality_ in terms of traces.
  When both VLSMs have the same state and label types they also share the
  same [Trace] type, and sets of traces can be compared without conversion.
  Then VLSM <<X>> and VLSM <<Y>> are _equal_ if their [valid_trace]s are exactly the same.
*)

Section sec_VLSM_equality.

Context
  {message : Type}
  {vtype : VLSMType message}
  .

Definition VLSM_eq_part
  (MX MY : VLSMMachine vtype)
  (X := mk_vlsm MX) (Y := mk_vlsm MY) : Prop :=
    VLSM_incl X Y /\ VLSM_incl Y X.

End sec_VLSM_equality.

Notation VLSM_eq X Y := (VLSM_eq_part (machine X) (machine Y)).

Lemma VLSM_eq_refl
  {message : Type}
  {vtype : VLSMType message}
  (MX : VLSMMachine vtype)
  (X := mk_vlsm MX)
  : VLSM_eq X X.
Proof.
  by firstorder.
Qed.

Lemma VLSM_eq_sym
  {message : Type}
  {vtype : VLSMType message}
  (MX MY : VLSMMachine vtype)
  (X := mk_vlsm MX) (Y := mk_vlsm MY)
  : VLSM_eq X Y -> VLSM_eq Y X.
Proof.
  by firstorder.
Qed.

Lemma VLSM_eq_trans
  {message : Type}
  {vtype : VLSMType message}
  (MX MY MZ : VLSMMachine vtype)
  (X := mk_vlsm MX) (Y := mk_vlsm MY) (Z := mk_vlsm MZ)
  : VLSM_eq X Y -> VLSM_eq Y Z -> VLSM_eq X Z.
Proof.
  by firstorder.
Qed.

Section sec_VLSM_eq_properties.

(** ** VLSM equality properties *)

Context
  {message : Type} [vtype : VLSMType message]
  [MX MY : VLSMMachine vtype]
  (Hincl : VLSM_eq_part MX MY)
  (X := mk_vlsm MX)
  (Y := mk_vlsm MY)
  .

(** VLSM equality specialized to finite trace. *)

Lemma VLSM_eq_finite_valid_trace
  (s : vstate X)
  (tr : list (vtransition_item X))
  : finite_valid_trace X s tr <-> finite_valid_trace Y s tr.
Proof.
  by split; apply VLSM_incl_finite_valid_trace, Hincl.
Qed.

Lemma VLSM_eq_finite_valid_trace_init_to
  (s f : vstate X)
  (tr : list (vtransition_item X))
  : finite_valid_trace_init_to X s f tr <->
    finite_valid_trace_init_to Y s f tr.
Proof.
  by split; apply VLSM_incl_finite_valid_trace_init_to, Hincl.
Qed.

Lemma VLSM_eq_valid_state
  (s : vstate X)
  : valid_state_prop X s <-> valid_state_prop Y s.
Proof.
  by split; apply VLSM_incl_valid_state, Hincl.
Qed.

Lemma VLSM_eq_initial_state
  (is : vstate X)
  : vinitial_state_prop X is <-> vinitial_state_prop Y is.
Proof.
  by split; apply VLSM_incl_initial_state, Hincl.
Qed.

Lemma VLSM_eq_finite_valid_trace_from
  (s : vstate X)
  (tr : list (vtransition_item X))
  : finite_valid_trace_from X s tr <->
    finite_valid_trace_from Y s tr.
Proof.
  by split; apply VLSM_incl_finite_valid_trace_from, Hincl.
Qed.

Lemma VLSM_eq_finite_valid_trace_from_to
  (s f : vstate X)
  (tr : list (vtransition_item X))
  : finite_valid_trace_from_to X s f tr <-> finite_valid_trace_from_to Y s f tr.
Proof.
  by split; apply VLSM_incl_finite_valid_trace_from_to, Hincl.
Qed.

Lemma VLSM_eq_in_futures
  (s1 s2 : vstate X)
  : in_futures X s1 s2 <-> in_futures Y s1 s2.
Proof.
  by split; apply VLSM_incl_in_futures, Hincl.
Qed.

Lemma VLSM_eq_input_valid_transition
  : forall l s im s' om,
  input_valid_transition X l (s, im) (s', om) <->
  input_valid_transition Y l (s, im) (s', om).
Proof.
  by split; apply @VLSM_incl_input_valid_transition, Hincl.
Qed.

Lemma VLSM_eq_input_valid
  : forall l s im,
  input_valid X l (s, im) <-> input_valid Y l (s, im).
Proof.
  by split; apply @VLSM_incl_input_valid, Hincl.
Qed.

Lemma VLSM_eq_can_produce
  (s : state)
  (om : option message)
  : option_can_produce X s om <-> option_can_produce Y s om.
Proof.
  by split; apply VLSM_incl_can_produce, Hincl.
Qed.

Lemma VLSM_eq_can_emit
  (m : message)
  : can_emit X m <-> can_emit Y m.
Proof.
  by split; apply VLSM_incl_can_emit, Hincl.
Qed.

Lemma VLSM_eq_infinite_valid_trace_from
  s ls
  : infinite_valid_trace_from X s ls <->
    infinite_valid_trace_from Y s ls.
Proof.
  by split; apply VLSM_incl_infinite_valid_trace_from, Hincl.
Qed.

Lemma VLSM_eq_infinite_valid_trace
  s ls
  : infinite_valid_trace X s ls <-> infinite_valid_trace Y s ls.
Proof.
  by split; apply VLSM_incl_infinite_valid_trace, Hincl.
Qed.

Lemma VLSM_eq_valid_trace
  : forall t, valid_trace_prop X t <-> valid_trace_prop Y t.
Proof.
  by split; apply VLSM_incl_valid_trace, Hincl.
Qed.

End sec_VLSM_eq_properties.

Section sec_VLSM_incl_preloaded_properties.

(** ** Inclusion properties for pre-loaded VLSMs *)

Context
  {message : Type}
  (X : VLSM message)
  .

Lemma pre_loaded_vlsm_with_valid_eq
  (P Q : message -> Prop)
  (QimpliesValid : forall m, Q m -> valid_message_prop (pre_loaded_vlsm X P) m)
  : VLSM_eq (pre_loaded_vlsm X (fun m => P m \/ Q m)) (pre_loaded_vlsm X P).
Proof.
  split; cbn.
  - by apply pre_loaded_vlsm_incl_relaxed; itauto.
  - by apply pre_loaded_vlsm_incl; itauto.
Qed.

Lemma pre_loaded_vlsm_idem
  (P : message -> Prop)
  : VLSM_eq (pre_loaded_vlsm (pre_loaded_vlsm X P) P) (pre_loaded_vlsm X P).
Proof.
  split; cbn.
  - by apply pre_loaded_vlsm_idem_l.
  - by apply pre_loaded_vlsm_idem_r.
Qed.

Lemma pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True
  : VLSM_eq (pre_loaded_with_all_messages_vlsm X) (pre_loaded_vlsm X (fun _ => True)).
Proof.
  split; cbn.
  - by apply pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True_l.
  - by apply pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True_r.
Qed.

Lemma pre_loaded_with_all_messages_eq_validating_pre_loaded_vlsm
  (P : message -> Prop)
  (Hvalidating :
    forall (l : label) (s : state) (m : message)
      (Hv : input_valid (pre_loaded_with_all_messages_vlsm X) l (s, Some m)),
      valid_message_prop (pre_loaded_vlsm X P) m)
  : VLSM_eq (pre_loaded_with_all_messages_vlsm X) (pre_loaded_vlsm X P).
Proof.
  split; cbn;
    [| by apply pre_loaded_vlsm_incl_pre_loaded_with_all_messages].
  apply basic_VLSM_incl.
  - by intro; intros **.
  - by intros l s m Hv _ _; eapply Hvalidating.
  - by intros l s om (_ & _ & ?).
  - by intros l s om s' om' [_ Ht].
Qed.

Lemma vlsm_is_pre_loaded_with_False
  : VLSM_eq X (pre_loaded_vlsm X (fun _ => False)).
Proof.
  by cbn; split; apply basic_VLSM_strong_incl; cbv; itauto.
Qed.

Lemma vlsm_is_pre_loaded_with_False_initial_message
  : strong_embedding_initial_message_preservation X (pre_loaded_vlsm X (fun _ => False)).
Proof.
  by intros m Hm; left.
Qed.

Lemma vlsm_is_pre_loaded_with_False_initial_message_rev
  : strong_embedding_initial_message_preservation (pre_loaded_vlsm X (fun _ => False)) X.
Proof.
  by intros m [Hm | Hfalse].
Qed.

Lemma pre_loaded_with_all_messages_vlsm_idem :
  VLSM_eq
    (pre_loaded_with_all_messages_vlsm (pre_loaded_with_all_messages_vlsm X))
    (pre_loaded_with_all_messages_vlsm X).
Proof.
  split; cbn.
  - by apply pre_loaded_with_all_messages_vlsm_idem_l.
  - by apply pre_loaded_with_all_messages_vlsm_idem_r.
Qed.

Lemma vlsm_is_pre_loaded_with_False_valid_state_message s om :
  valid_state_message_prop X s om <->
  valid_state_message_prop (pre_loaded_vlsm X (fun _ => False)) s om.
Proof.
  pose proof vlsm_is_pre_loaded_with_False as Heq.
  destruct X as (T, M); simpl in *.
  by split; (apply VLSM_incl_valid_state_message; [| cbv; tauto]); apply Heq.
Qed.

End sec_VLSM_incl_preloaded_properties.


Require Export cpdtTactics.

Axiom f_cong2: forall l1 l2, (f l1) # (f l2) -> l1 = l2.
Lemma InvarMsg: forall (m:message), (submsg_msg 0 (Mvar 0) m) # m.
Proof.  induction m using (message_Bool_ind') with (P:= (fun m => (submsg_msg 0 (Mvar 0) m) # m)) (P0:= (fun b =>  ((submsg_bol 0 (Mvar 0) b) ## b)));crush.
destruct n.
reflexivity.
reflexivity.
induction l.
simpl. reflexivity.
simpl in H |- *.
inversion H.
rewrite H0.
simpl in IHl |- *.
apply IHl in H1.

simpl.
apply f_cong2 in H1.
rewrite H1.
reflexivity. Qed.
Lemma invarm : forall  (m:message), m # m.

Proof. induction m using (message_Bool_ind') with (P:= (fun m => m # m)) (P0:= (fun b =>  b##b));crush. Qed.

Lemma invarb: forall (b:Bool), b##b.
 Proof. induction b using (Bool_message_ind') with (P:= (fun m => m # m)) (P0:= (fun b =>  b##b));crush. Qed.

Set Nested Proofs Allowed.

Ltac rewriteHyp :=
  match goal with
    | [ H : _ |- _ ] =>  rewrite H by solve [ auto ]
  end.
Ltac un_done :=
  repeat match goal with
           | [ H : done _ |- _ ] => clear H
         end.

Lemma  invarsub_Bmsg : forall (t:message), ((0:= (Bvar 0))t  # t).

Proof.
 induction t using (message_Bool_ind') with (P:= (fun m => (subbol_msg 0 (Bvar 0) m) # m)) (P0:= (fun b =>  ((subbol_bol 0 (Bvar 0) b) ## b))); crush.
induction l.
simpl. reflexivity.
simpl.
simpl in H; inversion H.
apply IHl in H1.
apply f_cong2 in H1.
rewrite H1, H0; reflexivity.
induction n. reflexivity.
simpl.
reflexivity. Qed.
Lemma invarsub_b: forall b, (([0:=(Bvar 0)] b) ## b).
  Proof.
 induction b using (Bool_message_ind') with (P:= (fun m => (subbol_msg 0 (Bvar 0) m) # m)) (P0:= (fun b =>  ((subbol_bol 0 (Bvar 0) b) ## b))); crush.
induction l.
simpl. reflexivity.
simpl.
simpl in H; inversion H.
apply IHl in H1.
apply f_cong2 in H1.
rewrite H1, H0; reflexivity.
induction n. reflexivity.
simpl.
reflexivity. Qed.


Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Import PredMonad.OrderedTerms.

Module ONotations.
  Notation "x '-o>' y" := (otype_fun x y) (right associativity, at level 99).
  Notation "x ~~ y" := (@oequiv _ x y) (no associativity, at level 70).
  Notation "x <~ y" := (@ole _ x y) (no associativity, at level 70).
  Notation "x @ y" := (otype_apply x y) (left associativity, at level 11, y at level 0).
  Notation "x $ y" := (otype_apply x y) (left associativity, at level 11, y at level 200, only parsing).

  Ltac make_cons T n :=
    let rec go n :=
        lazymatch n with
        | 0 => uconstr:(@cons T _ _)
        | S ?Z =>
          let p := go Z in
          uconstr:(@cons T _ p)
        end
    in
    let z := go n in
    refine z.

  Delimit Scope ctx_scope with ctx.

  Notation "x @ y" := (@App_ctx _ _ _ x%ctx y%ctx) (left associativity, at level 11, y at level 0) : ctx_scope.
  Notation "x $ y" := (@App_ctx _ _ _ x%ctx y%ctx) (left associativity, at level 11, y at level 200, only parsing) : ctx_scope.
  Notation "\ t => y" := (@Abs_ctx _ t _ y%ctx) (left associativity, at level 200) : ctx_scope.
  Notation "! x" := (@Lift_ctx _ _ x%ctx) (no associativity, at level 0) : ctx_scope.
  Notation "# n" := (@Var_ctx _ n%nat ltac:(make_cons otype n) eq_refl) (at level 0) : ctx_scope.
  Arguments ToCtx {_} _%ctx.
  Arguments Abs_ctx {_ _ _} _%ctx.
  Arguments App_ctx {_ _ _} (_ _)%ctx.
End ONotations.

Import ONotations.

Typeclasses Opaque oequiv ole.

(**
 ** The Definition of an ordered monad
 **)
Class OMonad (M : otype -> otype) : Type :=
{ returnM : forall {A : otype}, A -o> (M A)
; bindM : forall {A B : otype}, M A -o> (A -o> M B) -o> M B
; monad_return_bind : forall (A B : otype) (x : A) (f : A -o> M B),
    bindM @ (returnM @ x) @ f ~~ f @ x
; monad_bind_return : forall A (m : M A),
    bindM @ m @ returnM ~~ m
; monad_assoc : forall {A B C : otype} m (f : A -o> M B) (g : B -o> M C),
    bindM @ (bindM @ m @ f) @ g ~~
    bindM @ m $ ToCtx (\ A => !bindM @ (!f @ #0) @ !g)
}.

(**
 ** Pair Functions
 **)
Definition otype_pair {A B : otype} : A -o> B -o> otype_prod A B.
  refine (ToCtx (\ _ => \ _ => _)).
  red. simpl. exists (fun ba_ => (fst (snd ba_), fst ba_)).
  abstract (do 2 red; split; simpl; apply H).
Defined.

Definition pair_fst {A B : otype} : otype_prod A B -o> A.
  exists fst.
  abstract (do 2 red; simpl; intros; apply H).
Defined.

Definition pair_snd {A B : otype} : otype_prod A B -o> B.
  exists snd.
  abstract (do 2 red; simpl; intros; apply H).
Defined.

Definition pair_elim {A B C : otype} : otype_prod A B -o> (A -o> B -o> C) -o> C :=
  ToCtx (\ _ => \ _ => #0 @ (!pair_fst @ #1) @ (!pair_snd @ #1)).

(** * Pair Reduction **)
Lemma pair_elim_red {A B C : otype} (f : A -> B -> C)  pf' pf x :
  pair_elim @ x @ (@otype_abs _ _ (fun x => @otype_abs _ _ (f x) (pf' x)) pf)
  ~~ f (pair_fst @ x) (pair_snd @ x).
Proof. destruct x; reflexivity. Defined.
Lemma pair_elim_pair_red {A B C : otype} (f : A -o> B -o> C) x y :
  pair_elim @ (otype_pair @ x @ y) @ f ~~ f @ x @ y.
Proof. reflexivity. Defined.
Lemma pair_fst_pair_red {A B} x y :
  @pair_fst A B @ (x,y) ~~ x.
Proof. reflexivity. Defined.
Lemma pair_snd_pair_red {A B} x y :
  @pair_snd A B @ (x,y) ~~ y.
Proof. reflexivity. Defined.
Lemma otype_pair_red {A B} x y :
  (@otype_pair A B @ x @ y) ~~ (x,y).
Proof. reflexivity. Defined.
Lemma otype_pair_eta_contract {A B} (x : otype_prod A B) :
  otype_pair @ (pair_fst @ x) @ (pair_snd @ x) ~~ x.
Proof. destruct x; reflexivity. Defined.
Lemma pair_eta_contract {A B} (x : otype_prod A B) :
  ((pair_fst @ x), (pair_snd @ x)) ~~ x.
Proof. destruct x; reflexivity. Defined.
Lemma pair_elim_arr {A B C : otype} x (f : A -o> B -o> C)
  : pair_elim @ x @ f ~~ f @ (pair_fst @ x) @ (pair_snd @ x).
Proof. destruct x; reflexivity. Defined.

Global Instance Proper_pair {A B : otype}
: Proper (oequiv ==> oequiv ==> oequiv) (@pair A B).
Proof. do 3 red. intros.
       do 2 constructor; first [ apply H | apply H0 ].
Qed.

Hint Rewrite @pair_elim_pair_red @otype_pair_eta_contract @pair_eta_contract
  : reduce_pair.
Hint Rewrite @pair_elim_arr @otype_pair_red
     @pair_fst_pair_red @pair_snd_pair_red
  : reduce_pair.

(** Tuple Reduction **)
Lemma tuple_hd_red {A : otype} {As : list otype} x xs
: @tuple_hd A As @ (otype_pair @ x @ xs) ~~ x.
Proof. reflexivity. Defined.
Lemma tuple_tl_red {A : otype} {As : list otype} x xs
: @tuple_tl A As @ (otype_pair @ x @ xs) ~~ xs.
Proof. reflexivity. Defined.

Lemma tuple_tl_pair {A : otype} {Bs : list otype} (x : A) (y : otype_tuple Bs)
: OrderedTerms.tuple_tl @ (x,y) ~~ y.
Proof. reflexivity. Defined.
Lemma tuple_hd_pair {A : otype} {Bs : list otype} (x : A) (y : otype_tuple Bs)
: OrderedTerms.tuple_hd @ (x,y) ~~ x.
Proof. reflexivity. Defined.

(**
 ** Generic Reduction
 **
 ** NOTE: Most things here follow immediately from reflexivity. However, we do
 ** not want to compute them because we only want to reduce in these instances.
 ** If we do unconstrained reduction, then we will expose proofs and everything
 ** will slow down.
 **)
Lemma otype_apply_ToCtx {B} (f : InCtx nil B)
: ToCtx f ~~ f @ tt.
Proof. reflexivity. Defined.
Lemma otype_apply_Abs_ctx A B G (f : InCtx (A :: G) B) (x : A) gs
: Abs_ctx f @ gs @ x ~~ f @ (x, gs).
Proof. reflexivity. Defined.
Lemma otype_apply_App_ctx {A B G} (f : InCtx G (A -o> B)) x gs
: otype_apply (App_ctx f x) gs ~~ otype_apply (f @ gs) (x @ gs).
Proof. reflexivity. Defined.
Lemma otype_apply_Lift_ctx {A : otype} {G : list otype} (f : A) gs
: otype_apply (Lift_ctx (ls:=G) f) gs ~~ f.
Proof. reflexivity. Defined.
Lemma otype_apply_Var_ctx_O {A : otype} {G : list otype} (x : A)
      (xs : otype_tuple G)
: otype_apply (Var_ctx (a:=A) (ls:=A::G) 0 (@eq_refl _ (List.nth_error (A::G) 0))) (x, xs) ~~ x.
Proof. reflexivity. Qed.
Lemma otype_apply_Var_ctx_O' {A : otype} {G : list otype} (x : A)
      (xs : otype_tuple G)
: otype_apply (Var_ctx (a:=A) (ls:=A::G) 0 (@eq_refl _ (Some A))) (x, xs) ~~ x.
Proof. reflexivity. Qed.
Lemma otype_apply_Var_ctx_S {A B : otype} {G : list otype} n pf (x : A)
      (xs : otype_tuple G)
  : otype_apply (Var_ctx (a:=B) (ls:=A::G) (S n) pf) (x, xs) ~~
                otype_apply (Var_ctx n pf) xs.
Proof. simpl. unfold otype_compose.
       generalize (Var_ctx n pf). intros.
       destruct t.
       simpl. reflexivity.
Qed.
Lemma otype_abs_otype_apply : forall {A B : otype} f pf x,
    (@otype_abs A B f pf @ x) ~~ f x.
Proof. reflexivity. Qed.
Lemma ToCtx_oequiv {B} (f : InCtx nil B)
: ToCtx f ~~ f @ tt.
Proof. reflexivity. Qed.
Lemma ToCtx_eq {B} (f : InCtx nil B)
: ToCtx f = f @ tt.
Proof. reflexivity. Qed.
Lemma otype_compose_red {A B C : otype} (f : A -o> B) (g : C -o> A) (x : C) :
  otype_compose g f @ x ~~ f $ g $ x.
Proof. reflexivity. Defined.

Hint Rewrite otype_apply_Abs_ctx @ToCtx_eq
     @otype_apply_Abs_ctx @otype_apply_App_ctx
     @otype_apply_Lift_ctx @otype_apply_Var_ctx_S
     @otype_apply_Var_ctx_O @otype_apply_Var_ctx_O'
     @ToCtx_oequiv
  : reduce.
Hint Rewrite @otype_abs_otype_apply : reduce.
Hint Rewrite @otype_compose_red : reduce.

(** * Tactics for Ordered Terms **)
Ltac oext := repeat (eapply otype_ext_eq; intros).

Ltac of_equal := first [ eapply Proper_otype_apply_oequiv
                       | eapply Proper_otype_apply_ole ] ; try reflexivity.

Ltac oreduce :=
  rewrite_strat topdown (repeat (choice (hints reduce) (hints reduce_pair))).

(***
 *** The Identity Monad
 ***)
Definition Identity (X:otype) := X.
Instance OMonad_Identity : OMonad Identity :=
{ returnM := fun A => ToCtx (\ A => #0)
; bindM  := fun A B => ToCtx (\ Identity A => \ (A -o> Identity B) => #0 @ #1)
}.
Proof.
{ reflexivity. }
{ reflexivity. }
{ reflexivity. }
Qed.

(***
 *** The State Monad
 ***)
Section with_state.
  Context {s : otype}.

  Definition State (x : otype) := s -o> otype_prod x s.
  Instance OMonad_State : OMonad State :=
  { returnM := fun A => ToCtx (\ A => \ s => !otype_pair @ #1 @ #0)
  ; bindM   := fun A B => ToCtx (\ State A => \ (A -o> State B) => \ s =>
                                 !pair_elim @ (#2 @ #0) @ #1)
  }.
  Proof.
  all: unfold State; simpl List.nth_error.
  { intros; oext.
    oreduce.
    reflexivity. }
  { intros; oext.
    oreduce.
    reflexivity. }
  { intros; oext.
    oreduce.
    reflexivity. }
  Defined.
End with_state.

Hint Rewrite @monad_return_bind @monad_bind_return @monad_assoc : reduce_monad.

Section StateT.
  Variable s : otype.
  Variable m : otype -> otype.
  Variable Mm : OMonad m.

  Ltac oreduce_m :=
    rewrite_strat topdown (repeat (choice (hints reduce)
                                          (choice (hints reduce_pair)
                                                  (hints reduce_monad)))).

  Definition StateT (x : otype) : otype := s -o> m (otype_prod x s).
  Instance OMonad_StateT : OMonad StateT :=
  { returnM := fun A => ToCtx (\ A => \ s => !returnM $ !otype_pair @ #1 @ #0)
  ; bindM   := fun A B => ToCtx (\ StateT A => \ (A -o> StateT B) => \ s =>
                                 !bindM @ (#2 @ #0) @ \ (otype_prod A s) =>
                                 !pair_elim @ #0 @ \ A => \ s =>
                                   #4 @ #1 @ #0)
  }.
  Proof.
  all: simpl List.nth_error; unfold StateT.
  { intros; oext. oreduce_m. reflexivity. }
  { intros; oext. oreduce_m.
    etransitivity; [ | eapply monad_bind_return ].
    of_equal.
    oext. oreduce_m.
    reflexivity. }
  { intros; oext. oreduce_m.
    of_equal. oext.
    oreduce_m.
    of_equal. oext.
    oreduce_m.
    reflexivity. }
  Time Defined.
End StateT.

Section PredMonad.
  Variable M : otype -> otype.
  Variable PM : otype -> otype.
  Context {OMonad_M : OMonad M} {OMonad_PM : OMonad PM}.

  Class PredMonad : Type :=
  { forallP: forall {A B: otype}, (A -o> PM B) -o> PM B
  ; existsP: forall {A B: otype}, (A -o> PM B) -o> PM B
  ; impliesP: forall {A: otype}, PM A -o> PM A -o> PM A
  ; liftP: forall {A: otype}, M A -o> PM A
(*  ; entailsP: forall {A: otype}, relation (PM A) *)

  ; forallP_elim :
      forall {A B:otype} (f: A -o> PM B) a,
        (forallP @ f) <~ (f @ a)
  ; forallP_intro :
      forall {A B: otype} (f: A -o> PM B) P,
        (forall a, P <~ f @ a) ->
        P <~ forallP @ f
  }.
End PredMonad.

Canonical Structure oprop : otype :=
{| T := Prop
 ; order := {| le := Basics.impl |} |}.

(* contra-variant *)
Definition otype_flip (x : otype) :=
{| T := x.(T)
 ; order := {| le := Basics.flip (@le _ x.(order)) |} |}.

Section SetMonad.
  Definition Ensemble (x : otype) : otype := otype_flip x -o> oprop.

  Definition Ole {A : otype} : otype_flip A -o> A -o> oprop.
  refine (ToCtx (\ otype_flip A => \ A => _)).
  red. simpl.
  refine (@otype_abs _ _ (fun x => ole _ (fst (snd x))) _).
  Unshelve.
  Focus 2. simpl. eapply (fst x).
  abstract (do 6 red; simpl; intros;
            etransitivity; [ eapply H | ];
            etransitivity; [ eapply H0 | eapply H ]).
  Defined.

  Definition Oge {A : otype} : A -o> otype_flip A -o> otype_flip oprop.
  refine (ToCtx (\ A => \ otype_flip A => _)).
  red. simpl.
  unfold otype_flip. simpl.
  eexists. Unshelve.
  Focus 2. simpl.
  refine (fun x => ole (fst (snd x)) (fst x) ).
  red. red. simpl. intros.
  destruct H.
  destruct H0.
  red. red. red. red. red. intro.
  etransitivity. red. simpl in *. eassumption.
  etransitivity. eapply H2. eassumption.
  Defined.

  Definition Oexists {A : otype} : (A -o> otype_flip A -o> oprop) -o> oprop.
  refine (ToCtx (\ _ => _ )).
  red. simpl.
  refine (@otype_abs _ _ (fun (f_ : (A -o> otype_flip A -o> oprop) * otype_unit) =>
                            exists x : A, function (function (fst f_) x) x) _).
  Proof.
  red. red. red. simpl. intros.
  red. intros.
  destruct H0. exists x0.
  eapply H. reflexivity. reflexivity. eassumption.
  Defined.

  Definition Oforall {A : otype} : (A -o> otype_flip A -o> oprop) -o> oprop.
  refine (ToCtx (\ _ => _ )).
  red. simpl.
  refine (@otype_abs _ _ (fun (f_ : (A -o> otype_flip A -o> oprop) * otype_unit) =>
                            forall x : A, function (function (fst f_) x) x) _).
  Proof.
  red. red. red. simpl. intros.
  red. intros.
  specialize (H0 x0).
  eapply H. reflexivity. reflexivity. eassumption.
  Defined.

  Definition Oand : oprop -o> oprop -o> oprop.
  refine (ToCtx (\ _ => \ _ => _ )).
  red. simpl.
  refine (@otype_abs _ _ (fun f_ => (fst (snd f_)) /\ (fst f_)) _).
  red. red. red. simpl. unfold Basics.impl. intros.
  split; eapply H; tauto.
  Defined.

  Definition Oimpl : otype_flip oprop -o> oprop -o> oprop.
  refine (ToCtx (\ _ => \ _ => _ )).
  red. simpl.
  refine (@otype_abs _ _ (fun f_ => Basics.impl _ (fst f_)) _).
  Unshelve.
  Focus 2.
  refine (fst (snd f_)).
  red. red. red. simpl. unfold Basics.impl. intros.
  eapply H. eapply H0. eapply H. eapply H1.
  Defined.

  (** NOTE: These are generic lemmas that belong elsewhere **)
  Lemma Prop_oequiv (a b : oprop) : (a ~~ b) <-> (a <-> b).
  Proof. red. split; intro; eassumption. Qed.
  Lemma exists_and : forall {A : Type} P (Q  : Prop),
      ((exists x : A, P x) /\ Q) <-> exists x : A, P x /\ Q.
  Proof. intuition. destruct H0; eauto. destruct H; eauto. exists x; tauto. destruct H; tauto. Qed.
  Lemma exists_comm {A B : Type} (P : A -> B -> Prop) :
    (exists x y, P x y) <-> (exists y x, P x y).
  Proof. split; destruct 1 as [ ? [ ? ? ] ]; do 2 eexists; eauto. Qed.

  Hint Rewrite @otype_abs_otype_apply : reduce.

  (** TODO: It would be good to simplify the reasoning about the logical
   ** connectives.
   **)

  Instance OMonad_Ensemble : OMonad Ensemble :=
  { returnM := fun A => ToCtx (\ A => \ otype_flip A => !Ole @ #0 @ #1)
  ; bindM   := fun A B => ToCtx (
      \ Ensemble A => \ (A -o> Ensemble B) => \ otype_flip B =>
          !Oexists @ \ A => \ otype_flip A =>
             !Oand @ (#4 @ #0) $ #3 @ #1 @ #2)
  }.
  Proof.
  all: unfold Ensemble; simpl List.nth_error; intros.
  { simpl otype_tuple. oext. oreduce.
    unfold Oexists. oreduce.
    simpl otype_tuple.
    oreduce. simpl fst.
    split.
    { intro. destruct H.
      simpl in H. destruct H.
      revert H0.
      change (f @ x1 @ x0 <~ f @ x @ x0).
      eapply Proper_otype_apply_ole; try reflexivity.
      clear - H.
      eapply (@Proper_otype_apply_ole _ _ f). reflexivity. eapply H. }
    { intro.
      exists x. simpl. split. reflexivity. eassumption. } }
  { oext. oreduce. unfold Oexists.
    oreduce.
    simpl otype_tuple.
    oreduce.
    simpl.
    split.
    { intro. destruct H. destruct H.
      revert H.
      change (m @ x0 <~ m @ x).
      eapply Proper_otype_apply_ole; try reflexivity.
      eassumption. }
    { intro. eexists; split; eauto. reflexivity. } }
  { oext. oreduce.
    unfold Oexists. oreduce.
    simpl otype_tuple.
    oreduce. simpl.
    eapply Prop_oequiv.
    setoid_rewrite exists_and.
    rewrite exists_comm.
    eapply Morphisms_Prop.ex_iff_morphism. red. intros.
    rewrite and_comm.
    rewrite exists_and.
    eapply Morphisms_Prop.ex_iff_morphism. red. intros. tauto. }
  Defined.

End SetMonad.

(* Definition Flip_cast {a b : otype} (x : otype_flip a -o> otype_flip b) *)
(* : otype_flip (a -o> b). *)
(* red. simpl. simpl in x. *)
(* destruct x. *)
(* compute in function. exists function. *)
(* red. red. red. intros. *)
(* eapply Proper_function. eapply H. *)
(* Defined. *)
(* Definition Flip_cast' {a b : otype} (x : otype_flip (a -o> b)) *)
(* : otype_flip a -o> otype_flip b. *)
(* Admitted. *)

(* Definition Flip {a b : otype} (x : a -o> b) *)
(* : otype_flip (otype_flip a -o> otype_flip b). *)
(* red. simpl. simpl in x. *)
(* destruct x. *)
(* destruct a. destruct b. simpl in *. *)
(* unfold otype_flip; simpl. *)
(* exists function. *)
(* red. red. red. intros. *)
(* eapply Proper_function. eapply H. *)
(* Defined. *)

(* Definition Flip_Flip {a : otype} (x : otype_flip (otype_flip a)) : a := x. *)
(* Definition Flip_Flip' {a : otype} (x : a) : otype_flip (otype_flip a) := x. *)

(* Structure Flipper : Type := *)
(* { _type :> otype *)
(* ; _Ftype : otype *)
(* ; _Fcast : _type -o> otype_flip _Ftype *)
(* }. *)

(* Axiom todo : forall x : Type, x. *)

(* Canonical Structure Flipper_otype_flip (x : otype) : Flipper := *)
(* {| _type  := otype_flip x *)
(*  ; _Ftype := x *)
(*  ; _Fcast := todo _ *)
(*  |}. *)

(* Canonical Structure Flipper_otype_fun (a b : Flipper) : Flipper := *)
(* {| _type  := otype_fun a.(_type) b.(_type) *)
(*  ; _Ftype := otype_fun a.(_Ftype) b.(_Ftype) *)
(*  ; _Fcast := todo _ *)
(*  |}. *)

(* Definition Flip_ctx {g} {a : Flipper} (x : InCtx g a.(_type)) *)
(* : InCtx g a.(_Ftype). *)
(* red. red. simpl. red in x. simpl in x. *)
(* eexists (fun g => Flip_Flip (a.(_Fcast) $ x @ g)). *)
(* red. red. intros. *)
(* unfold Flip_Flip. *)
(* eapply (Proper_otype_apply_ole (_Fcast a) (_Fcast a)). reflexivity. *)
(* eapply (Proper_otype_apply_ole x x). reflexivity. *)
(* red in H. red in H. red. red. *)
(* clear - H. revert H. unfold ole, le. simpl. *)


From Undecidability.L Require Export L Tactics.LTactics GenEncode.

From Undecidability.L.Datatypes Require Import LBool.

From Undecidability.L Require Import Functions.EqBool GenEncode.
(*
From Undecidability.L Require Import LNat.*)

(* ** Encoding of pairs *)

Section Fix_XY.

  Variable X Y:Type.

  Context {intX : registered X}.
  Context {intY : registered Y}.

  MetaCoq Run (tmGenEncode "prod_enc" (X * Y)).
  Hint Resolve prod_enc_correct : Lrewrite.

  (* now we must register the constructors*)
  Global Instance term_pair : computableTime' (@pair X Y) (fun _ _ => (1,fun _ _ => (1,tt))).
  Proof.
    extract constructor. solverec.
  Qed.

  Global Instance term_fst : computableTime' (@fst X Y) (fun _ _ => (5,tt)).
  Proof.
    extract. solverec.
  Qed.

  Global Instance term_snd : computableTime' (@snd X Y) (fun _ _ => (5,tt)).
  Proof.
    extract. solverec.
  Qed.

  Definition prod_eqb f g (a b: X*Y):=
    let (x1,y1):= a in
    let (x2,y2):= b in
    andb (f x1 x2) (g y1 y2).

  Lemma prod_eqb_spec f g:
    (forall (x1 x2 : X) , reflect (x1 = x2) (f x1 x2))
    -> (forall (y1 y2 : Y) , reflect (y1 = y2) (g y1 y2))
    -> forall x y, reflect (x=y) (prod_eqb f g x y).
  Proof with try (constructor;congruence).
    intros Hf Hg [x1 y1] [x2 y2].
    specialize (Hf x1 x2); specialize (Hg y1 y2);cbn.
    inv Hf;inv Hg;cbn...
  Qed.

  Global Instance eqbProd f g `{eqbClass (X:=X) f} `{eqbClass (X:=Y) g}:
    eqbClass (prod_eqb f g).
  Proof.
    intros ? ?. eapply prod_eqb_spec. all:eauto using eqb_spec.
  Qed.

  Global Instance eqbComp_Prod `{eqbCompT X (R:=intX)} `{eqbCompT Y (R:=intY)}:
    eqbCompT (X*Y).
  Proof.
    evar (c:nat). exists c. unfold prod_eqb.
    unfold enc;cbn.
    change (eqb0) with (eqb (X:=X)).
    change (eqb1) with (eqb (X:=Y)).
    extract. unfold eqb,eqbTime. fold @enc.
    recRel_prettify2. easy.
    [c]:exact (c__eqbComp X + c__eqbComp Y + 6).
    all:unfold c. cbn iota delta [prod_enc].
    fold (@enc X _). fold (@enc Y _).
    cbn [size].  nia.
  Qed.

  (*
  Global Instance term_prod_eqb :
    computableTime' prod_eqb
                     (fun _ eqT1 =>
                        (1,fun _ eqT2 =>
                             (1,fun x _ =>
                                  (1,fun y _ =>
                                       (let '(k1,eqT1') := (eqT1 (fst x) tt) in
                                                             k1 +fst (eqT1' (fst y) tt)
                                       + (let '(k2,eqT2') := (eqT2 (snd x) tt) in
                                           k2 +fst (eqT2' (snd y) tt)) + 14, tt))))).
  Proof.
    extract. solverec.
  Qed.

  Global Instance term_prod_eqb_notime :
    computable prod_eqb.
  Proof.
    extract.
  Qed. *)

  Lemma size_prod (w:X*Y):
    size (enc w) = size (enc (fst w)) + size (enc (snd w)) + 4.
  Proof.
    destruct w. unfold enc. now cbn.
  Qed.

End Fix_XY.

#[export] Hint Resolve prod_enc_correct : Lrewrite.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

(*i $Id: Relations_2_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Relations_2.

Theorem Rstar_reflexive :
 forall (U:Type) (R:Relation U), Reflexive U (Rstar U R).
Proof.
auto with sets.
Qed.

Theorem Rplus_contains_R :
 forall (U:Type) (R:Relation U), contains U (Rplus U R) R.
Proof.
auto with sets.
Qed.

Theorem Rstar_contains_R :
 forall (U:Type) (R:Relation U), contains U (Rstar U R) R.
Proof.
intros U R; red in |- *; intros x y H'; apply Rstar_n with y; auto with sets.
Qed.

Theorem Rstar_contains_Rplus :
 forall (U:Type) (R:Relation U), contains U (Rstar U R) (Rplus U R).
Proof.
intros U R; red in |- *.
intros x y H'; elim H'.
generalize Rstar_contains_R; intro T; red in T; auto with sets.
intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets.
Qed.

Theorem Rstar_transitive :
 forall (U:Type) (R:Relation U), Transitive U (Rstar U R).
Proof.
intros U R; red in |- *.
intros x y z H'; elim H'; auto with sets.
intros x0 y0 z0 H'0 H'1 H'2 H'3; apply Rstar_n with y0; auto with sets.
Qed.

Theorem Rstar_cases :
 forall (U:Type) (R:Relation U) (x y:U),
   Rstar U R x y -> x = y \/ (exists u : _, R x u /\ Rstar U R u y).
Proof.
intros U R x y H'; elim H'; auto with sets.
intros x0 y0 z H'0 H'1 H'2; right; exists y0; auto with sets.
Qed.

Theorem Rstar_equiv_Rstar1 :
 forall (U:Type) (R:Relation U), same_relation U (Rstar U R) (Rstar1 U R).
Proof.
generalize Rstar_contains_R; intro T; red in T.
intros U R; unfold same_relation, contains in |- *.
split; intros x y H'; elim H'; auto with sets.
generalize Rstar_transitive; intro T1; red in T1.
intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets.
intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets.
Qed.

Theorem Rsym_imp_Rstarsym :
 forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Rstar U R).
Proof.
intros U R H'; red in |- *.
intros x y H'0; elim H'0; auto with sets.
intros x0 y0 z H'1 H'2 H'3.
generalize Rstar_transitive; intro T1; red in T1.
apply T1 with y0; auto with sets.
apply Rstar_n with x0; auto with sets.
Qed.

Theorem Sstar_contains_Rstar :
 forall (U:Type) (R S:Relation U),
   contains U (Rstar U S) R -> contains U (Rstar U S) (Rstar U R).
Proof.
unfold contains in |- *.
intros U R S H' x y H'0; elim H'0; auto with sets.
generalize Rstar_transitive; intro T1; red in T1.
intros x0 y0 z H'1 H'2 H'3; apply T1 with y0; auto with sets.
Qed.

Theorem star_monotone :
 forall (U:Type) (R S:Relation U),
   contains U S R -> contains U (Rstar U S) (Rstar U R).
Proof.
intros U R S H'.
apply Sstar_contains_Rstar; auto with sets.
generalize (Rstar_contains_R U S); auto with sets.
Qed.

Theorem RstarRplus_RRstar :
 forall (U:Type) (R:Relation U) (x y z:U),
   Rstar U R x y -> Rplus U R y z ->  exists u : _, R x u /\ Rstar U R u z.
Proof.
generalize Rstar_contains_Rplus; intro T; red in T.
generalize Rstar_transitive; intro T1; red in T1.
intros U R x y z H'; elim H'.
intros x0 H'0; elim H'0.
intros x1 y0 H'1; exists y0; auto with sets.
intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets.
intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0.
split; [ try assumption | idtac ].
apply T1 with z0; auto with sets.
Qed.

Theorem Lemma1 :
 forall (U:Type) (R:Relation U),
   Strongly_confluent U R ->
   forall x b:U,
     Rstar U R x b ->
     forall a:U, R x a ->  exists z : _, Rstar U R a z /\ R b z.
Proof.
intros U R H' x b H'0; elim H'0.
intros x0 a H'1; exists a; auto with sets.
intros x0 y z H'1 H'2 H'3 a H'4.
red in H'.
specialize H' with (x := x0) (a := a) (b := y); lapply H';
 [ intro H'8; lapply H'8;
    [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ]
 | clear H' ]; auto with sets.
elim H'9.
intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5.
elim (H'3 t); auto with sets.
intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5.
exists z1; split; [ idtac | assumption ].
apply Rstar_n with t; auto with sets.
Qed.