Require Export is_pos_neg_SO_lemmas Pred_is_pos_SO Pred_is_neg_SO.
Require Export med_mods.

Lemma P_pos_negSO : forall (alpha : SecOrder) (P : predicate),
  Pred_is_pos_SO (negSO alpha) P -> Pred_is_neg_SO alpha P.
Proof.
  intros alpha P [H1 H2]. constructor. firstorder.
  intros i Hocc Hat. apply H2 in Hat. apply is_pos_negSO.
  auto.  firstorder.
Qed.

Lemma P_neg_negSO : forall (alpha : SecOrder) (P : predicate),
  Pred_is_neg_SO (negSO alpha) P -> Pred_is_pos_SO alpha P.
Proof.
  intros alpha P [H1 H2]. constructor. firstorder.
  intros i Hocc Hat. apply H2 in Hat. apply is_neg_negSO.
  auto.  firstorder.
Qed.

Lemma Pred_is_neg_SO_allFO  : forall (alpha : SecOrder) (x : FOvariable) (P : predicate),
  Pred_is_neg_SO (allFO x alpha) P <-> Pred_is_neg_SO alpha P.
Proof. firstorder. Qed.

Lemma Pred_is_neg_SO_exFO  : forall (alpha : SecOrder) (x : FOvariable) (P : predicate),
  Pred_is_neg_SO (exFO x alpha) P <-> Pred_is_neg_SO alpha P.
Proof. firstorder. Qed.

Lemma Pred_is_neg_SO_conjSO_l : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha1 P ->
  Pred_is_neg_SO (conjSO alpha1 alpha2) P ->
  Pred_is_neg_SO alpha1 P.
Proof.
  intros alpha1 alpha2 P Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. pose proof Hocc as Hocc'.
  eapply is_neg_SO_conjSO_l in Hocc.
  apply Hocc. apply H2. apply occ_in_SO_conjSO2. firstorder.
  simpl. rewrite at_pred_app_l;firstorder.
Qed.

Lemma Pred_is_neg_SO_conjSO_r : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha2 P ->
  Pred_is_neg_SO (conjSO alpha1 alpha2) P ->
  Pred_is_neg_SO alpha2 P.
Proof.
  intros alpha1 alpha2 P Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. pose proof Hocc as Hocc'.
  assert (i <> 0) as Hass2. firstorder.
  assert (i = i + length (preds_in alpha1) - length (preds_in alpha1)) as Hass.
    firstorder. rewrite Hass in *.
  eapply is_neg_SO_conjSO_r in Hocc. rewrite <- Hass in *.
  apply Hocc. apply H2. apply occ_in_SO_conjSO2. firstorder.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pred_app_r. auto.
  destruct i; firstorder.
  rewrite PeanoNat.Nat.add_comm.
  apply occ_in_SO_preds_in. firstorder.
Qed.

Lemma Pred_is_neg_SO_disjSO_l : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha1 P ->
  Pred_is_neg_SO (disjSO alpha1 alpha2) P ->
  Pred_is_neg_SO alpha1 P.
Proof.
  intros alpha1 alpha2 P Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. pose proof Hocc as Hocc'.
  eapply is_neg_SO_disjSO_l in Hocc.
  apply Hocc. apply H2. apply occ_in_SO_disjSO2. firstorder.
  simpl. rewrite at_pred_app_l;firstorder.
Qed.

Lemma Pred_is_neg_SO_disjSO_r : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha2 P ->
  Pred_is_neg_SO (disjSO alpha1 alpha2) P ->
  Pred_is_neg_SO alpha2 P.
Proof.
  intros alpha1 alpha2 P Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. pose proof Hocc as Hocc'.
  assert (i <> 0) as Hass2. firstorder.
  assert (i = i + length (preds_in alpha1) - length (preds_in alpha1)) as Hass.
    firstorder. rewrite Hass in *.
  eapply is_neg_SO_disjSO_r in Hocc. rewrite <- Hass in *.
  apply Hocc. apply H2. apply occ_in_SO_disjSO2. firstorder.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pred_app_r. auto.
  destruct i; firstorder.
  rewrite PeanoNat.Nat.add_comm.
  apply occ_in_SO_preds_in. firstorder.
Qed.

Lemma Pred_is_pos_SO_implSO_l : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha1 P ->
  Pred_is_pos_SO (implSO alpha1 alpha2) P ->
  Pred_is_neg_SO alpha1 P.
Proof.
  intros alpha1 alpha2 P Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. pose proof Hocc as Hocc'.
  eapply is_pos_SO_implSO_l2 in Hocc'.
  pose proof (pos_or_neg_SO _ _ Hocc) as H3.
  destruct H3. contradiction. auto.
  apply H2. apply occ_in_SO_implSO2. auto.
  simpl. rewrite at_pred_app_l. auto. firstorder.
Qed.

Lemma Pred_is_neg_SO_implSO_l : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha1 P ->
  Pred_is_neg_SO (implSO alpha1 alpha2) P ->
  Pred_is_pos_SO alpha1 P.
Proof.
  intros alpha1 alpha2 P Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. pose proof Hocc as Hocc'.
  eapply is_neg_SO_implSO_l2 in Hocc'.
  pose proof (pos_or_neg_SO _ _ Hocc) as H3.
  destruct H3. auto. contradiction.
  apply H2. apply occ_in_SO_implSO2. auto.
  simpl. rewrite at_pred_app_l. auto. firstorder.
Qed.

Lemma Pred_is_pos_SO_implSO_r : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha2 P  ->
  Pred_is_pos_SO (implSO alpha1 alpha2) P ->
  Pred_is_pos_SO alpha2 P.
Proof.
  intros alpha1 alpha2 P Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. pose proof Hocc as Hocc'.
  assert (i <> 0) as Hass2. firstorder.
  assert (i = i + length (preds_in alpha1) - length (preds_in alpha1)) as Hass.
    firstorder. rewrite Hass in *.
  eapply is_pos_SO_implSO_r in Hocc. rewrite <- Hass in *.
  apply Hocc. apply H2. apply occ_in_SO_implSO2. firstorder.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pred_app_r. auto.
  destruct i; firstorder.
  rewrite PeanoNat.Nat.add_comm.
  apply occ_in_SO_preds_in. firstorder.
Qed.

Lemma Pred_is_neg_SO_implSO_r : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha2 P ->
  Pred_is_neg_SO (implSO alpha1 alpha2) P ->
  Pred_is_neg_SO alpha2 P.
Proof.
  intros alpha1 alpha2 P Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. pose proof Hocc as Hocc'.
  assert (i <> 0) as Hass2. firstorder.
  assert (i = i + length (preds_in alpha1) - length (preds_in alpha1)) as Hass.
    firstorder. rewrite Hass in *.
  eapply is_neg_SO_implSO_r in Hocc. rewrite <- Hass in *.
  apply Hocc. apply H2. apply occ_in_SO_implSO2. firstorder.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pred_app_r. auto.
  destruct i; firstorder.
  rewrite PeanoNat.Nat.add_comm.
  apply occ_in_SO_preds_in. firstorder.
Qed.

Lemma is_neg_SO_allSO : forall (alpha : SecOrder) (P : predicate) (i : nat),
  occ_in_SO alpha i ->
  is_neg_SO (allSO P alpha) (S i) <-> is_neg_SO alpha i.
Proof.
  intros alpha P i Hocc; split; intros [H1 H2]; simpl in H2.
    destruct i. discriminate.  firstorder.

    constructor. apply occ_in_SO_allSO. auto.
    simpl. destruct i. firstorder. auto.
Qed.

Lemma is_neg_SO_exSO : forall (alpha : SecOrder) (P : predicate) (i : nat),
  occ_in_SO alpha i ->
  is_neg_SO (exSO P alpha) (S i) <-> is_neg_SO alpha i.
Proof.
  intros alpha P i Hocc; split; intros [H1 H2]; simpl in H2.
    destruct i. discriminate.  firstorder.

    constructor. apply occ_in_SO_exSO. auto.
    simpl. destruct i. firstorder. auto.
Qed.

Lemma Pred_is_neg_SO_allSO : forall (alpha : SecOrder) (P Q : predicate),
Pred_in_SO alpha P ->
Pred_is_neg_SO (allSO Q alpha) P -> Pred_is_neg_SO alpha P.
Proof.
  intros alpha P Q Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. eapply is_neg_SO_allSO.
  auto. apply H2.  apply occ_in_SO_allSO. auto.
  simpl. destruct i. firstorder. auto.
Qed.

Lemma Pred_is_neg_SO_exSO : forall (alpha : SecOrder) (P Q : predicate),
Pred_in_SO alpha P ->
Pred_is_neg_SO (exSO Q alpha) P -> Pred_is_neg_SO alpha P.
Proof.
  intros alpha P Q Hpocc [H1 H2].
  constructor. firstorder.
  intros i Hocc Hat. eapply is_neg_SO_exSO.
  auto. apply H2.  apply occ_in_SO_exSO. auto.
  simpl. destruct i. firstorder. auto.
Qed.


(*
  Copyright 2014 Cornell University
  Copyright 2015 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 computation_arith.
Require Export approx_props2.
Require Export sequents_tacs.
Require Export sequents_tacs2.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export per_props_nat.
Require Export per_can.
Require Export per_props_top.
Require Export integer_type.
Require Export terms_arith.

Lemma mkc_integer_eq_iff {o} :
  forall a b, @mkc_integer o a = mkc_integer b <-> a = b.
Proof. intros; split; introv H.
   -  apply @mkc_integer_eq in H; auto.
   - subst. auto.
Qed.

(*
   H |- (m+n)+k = m+(n+k) in Z

     By addAssociative

     H |- m in Z
     H |- n in Z
     H |- k in Z
 *)
Definition rule_add_associative {o}
           (H : barehypotheses)
           (m n k: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_add (mk_add m n) k) (mk_add m (mk_add n k)) mk_int)))
    [ mk_baresequent H (mk_conclax (mk_member m mk_int)),
      mk_baresequent H (mk_conclax (mk_member n mk_int)),
      mk_baresequent H (mk_conclax (mk_member k mk_int))
    ]
    [].

(*
   H |- (m*n)*k = m*(n*k) in Z

     By mulAssociative

     H |- m in Z
     H |- n in Z
     H |- k in Z
 *)
Definition rule_mul_associative {o}
           (H : barehypotheses)
           (m n k: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_mul (mk_mul m n) k) (mk_mul m (mk_mul n k)) mk_int)))
    [ mk_baresequent H (mk_conclax (mk_member m mk_int)),
      mk_baresequent H (mk_conclax (mk_member n mk_int)),
      mk_baresequent H (mk_conclax (mk_member k mk_int))
    ]
    [].

(*
   H |- m*(n+k) = (m*n) + (m*k) in Z

     By mulDistributive

     H |- m in Z
     H |- n in Z
     H |- k in Z
 *)
Definition rule_mul_distributive {o}
           (H : barehypotheses)
           (m n k: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_mul m (mk_add n k))
                        (mk_add (mk_mul m n) (mk_mul m k)) mk_int)))
    [ mk_baresequent H (mk_conclax (mk_member m mk_int)),
      mk_baresequent H (mk_conclax (mk_member n mk_int)),
      mk_baresequent H (mk_conclax (mk_member k mk_int))
    ]
    [].

(*
   H |- m + (n - m) = n in Z

     By addInverse

     H |- m in Z
     H |- n in Z
 *)
Definition rule_add_inverse {o}
           (H : barehypotheses)
           (m n: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax
                       (mk_equality (mk_add m (mk_sub n m))
                                     n mk_int)))
    [ mk_baresequent H (mk_conclax (mk_member m mk_int)),
      mk_baresequent H (mk_conclax (mk_member n mk_int))
    ]
    [].

(*
   H |- m op n = m op n in Z

     By arithopEquality

     H |- m in Z
     H |- n in Z

 *)
Definition rule_arithop_equality {o}
           (H : barehypotheses)
           op
           (m n: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_arithop op m n) (mk_arithop op m n) mk_int)))
    [ mk_baresequent H (mk_conclax (mk_member m mk_int)),
      mk_baresequent H (mk_conclax (mk_member n mk_int))
    ]
    [].

(*
   H |- (m+n) = (n+m) in Z

     By addCommutative

     H |- m in Z
     H |- n in Z
 *)
Definition rule_add_commutative {o}
           (H : barehypotheses)
           (m n : @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_add m n) (mk_add n m ) mk_int)))
    [ mk_baresequent H (mk_conclax (mk_member m mk_int)),
      mk_baresequent H (mk_conclax (mk_member n mk_int))
    ]
    [].

(*
   H |- (m*n) = (n*m) in Z

     By mullCommutative

     H |- m in Z
     H |- n in Z
 *)
Definition rule_mul_commutative {o}
           (H : barehypotheses)
           (m n : @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_mul m n) (mk_mul n m ) mk_int)))
    [ mk_baresequent H (mk_conclax (mk_member m mk_int)),
      mk_baresequent H (mk_conclax (mk_member n mk_int))
    ]
    [].

(*
   H |- (0+n) = n in Z

     By addZero

     H |- n in Z
 *)
Definition rule_add_zero {o}
           (H : barehypotheses)
           (n : @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_add (mk_integer 0) n) n mk_int)))
    [ mk_baresequent H (mk_conclax (mk_member n mk_int)) ]
    [].

(*
   H |- (1*n) = n in Z

     By mulOne

     H |- n in Z
 *)
Definition rule_mul_one {o}
           (H : barehypotheses)
           (n : @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_mul (mk_integer 1) n) n  mk_int)))
    [ mk_baresequent H (mk_conclax (mk_member n mk_int)) ]
    [].

Lemma rule_arithop_equality_true {o} :
  forall lib (H : barehypotheses) op
         (m n : @NTerm o),
    rule_true lib (rule_arithop_equality H op m n).
Proof.
  unfold rule_arithop_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  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.
  lsubst_tac.
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp2; 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.
(*
 assert (equality_of_int lib (mkc_arithop op m1 n1)
          (mkc_arithop op m2 n2)) by (apply @equality_of_int_arithop; auto).
 *) split.

  - (* tequality *) apply @tequality_mkc_equality2; split.
    apply tequality_int. split;
    rw @equality_in_int;
    apply equality_of_int_arithop; auto.

  - (* equality *)
     rw @member_eq. rw <- @member_equality_iff.
     rw @equality_in_int.
      clear dependent n2. clear dependent m2.
      allrw @member_int_iff. spcast. exrepnd.
      exists (get_arith_op op z z0). sp; spcast; apply computes_to_valc_arithop; auto.
Qed.

Lemma rule_add_associative_true {o} :
  forall lib (H : barehypotheses)
         (m n k : @NTerm o),
    rule_true lib (rule_add_associative H m n k).
Proof.
  unfold rule_add_associative, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  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.
  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.
  exrepnd.
  fold_mk_arithop.
  lsubst_tac.
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp4; auto.
  apply (@tequality_member_int o) in hyp3; auto.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms k1.
  generalize_lsubstc_terms m2.
  generalize_lsubstc_terms n2.
  generalize_lsubstc_terms k2.
  split.
  -
 (* tequality *)
  apply @tequality_mkc_equality2; split.
    apply tequality_int. split;
    rw @equality_in_int;
    repeat (apply equality_of_int_arithop; auto).

  - (* equality *)
     rw @member_eq. rw <- @member_equality_iff.
     rw @equality_in_int.
     clear dependent k2. clear dependent n2. clear dependent m2.
    allrw @member_int_iff. spcast. exrepnd.
   unfold equality_of_int.
   assert ((z + z0 + z1)%Z = (z + (z0 + z1))%Z) as eq by omega.
   exists (z + z0 + z1)%Z. sp; auto; spcast;
     [ | rw eq]; repeat (apply computes_to_valc_arithop;auto).
Qed.

Lemma rule_add_commutative_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_add_commutative H m n).
Proof.
  unfold rule_add_commutative, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  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.
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp2; 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.
  split.
  - (* tequality *)
     apply @tequality_mkc_equality2; split.
    apply tequality_int. split;
    rw @equality_in_int;
    repeat (apply equality_of_int_arithop; auto).

  - (* equality *)
     rw @member_eq. rw <- @member_equality_iff.
     rw @equality_in_int.
     clear dependent n2. clear dependent m2.
    allrw @member_int_iff. spcast. exrepnd.
   unfold equality_of_int.
   assert ((z + z0)%Z = (z0 + z)%Z) as eq by omega.
   exists (z + z0)%Z. sp; auto; spcast;
     [ | rw eq]; repeat (apply computes_to_valc_arithop;auto).
Qed.

Lemma rule_mul_associative_true {o} :
  forall lib (H : barehypotheses)
         (m n k : @NTerm o),
    rule_true lib (rule_mul_associative H m n k).
Proof.
  unfold rule_mul_associative, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  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.
  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.
  exrepnd.
  fold_mk_arithop.
  lsubst_tac.
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp4; auto.
  apply (@tequality_member_int o) in hyp3; auto.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms k1.
  generalize_lsubstc_terms m2.
  generalize_lsubstc_terms n2.
  generalize_lsubstc_terms k2.
  split.
  - (* tequality *)
      apply @tequality_mkc_equality2; split.
    apply tequality_int. split;
    rw @equality_in_int;
    repeat (apply equality_of_int_arithop; auto).

  - (* equality *)
     rw @member_eq. rw <- @member_equality_iff.
     rw @equality_in_int.
     clear dependent k2. clear dependent n2. clear dependent m2.
    allrw @member_int_iff. spcast. exrepnd.
   unfold equality_of_int.
   assert ((z * z0 * z1)%Z = (z * (z0 * z1))%Z) as eq by (rw Z.mul_assoc;auto).
   exists (z * z0 * z1)%Z. sp; auto; spcast;
     [ | rw eq]; repeat (apply computes_to_valc_arithop;auto).
Qed.

Lemma rule_mul_distributive_true {o} :
  forall lib (H : barehypotheses)
         (m n k : @NTerm o),
    rule_true lib (rule_mul_distributive H m n k).
Proof.
  unfold rule_mul_distributive, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  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.
  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.
  exrepnd.
  fold_mk_arithop.
  lsubst_tac.
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp4; auto.
  apply (@tequality_member_int o) in hyp3; auto.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms m1.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms k1.
  generalize_lsubstc_terms m2.
  generalize_lsubstc_terms n2.
  generalize_lsubstc_terms k2.
  split.
  - (* tequality *)
     apply @tequality_mkc_equality2; split.
    apply tequality_int. split;
    rw @equality_in_int;
    repeat (apply equality_of_int_arithop; auto).

  - (* equality *)
     rw @member_eq. rw <- @member_equality_iff.
     rw @equality_in_int.
     clear dependent k2. clear dependent n2. clear dependent m2.
    allrw @member_int_iff. spcast. exrepnd.
   unfold equality_of_int.
   assert ((z * (z0 + z1))%Z = ((z * z0) + (z * z1))%Z) as eq by (rw Z.mul_add_distr_l;auto).
   exists (z * (z0 + z1))%Z. sp; auto; spcast;
     [ | rw eq]; repeat (apply computes_to_valc_arithop;auto).
Qed.

Lemma rule_mul_commutative_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_mul_commutative H m n).
Proof.
  unfold rule_mul_commutative, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  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.
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp2; 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.
  split.
  - (* tequality *)
     apply @tequality_mkc_equality2; split.
    apply tequality_int. split;
    rw @equality_in_int;
    repeat (apply equality_of_int_arithop; auto).

  - (* equality *)
     rw @member_eq. rw <- @member_equality_iff.
     rw @equality_in_int.
     clear dependent n2. clear dependent m2.
    allrw @member_int_iff. spcast. exrepnd.
   unfold equality_of_int.
   assert ((z * z0)%Z = (z0 * z)%Z) as eq by(rw Z.mul_comm;auto).
   exists (z * z0)%Z. sp; auto; spcast;
     [ | rw eq]; repeat (apply computes_to_valc_arithop;auto).
Qed.

Lemma rule_add_inverse_true {o} :
  forall lib (H : barehypotheses)
         (m n : @NTerm o),
    rule_true lib (rule_add_inverse H m n).
Proof.
  unfold rule_add_inverse, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  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.
  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp2; 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.
  split.
  - (* tequality *)
     apply @tequality_mkc_equality2; split.
    apply tequality_int. split;
    rw @equality_in_int;
    repeat (apply equality_of_int_arithop; auto).

    auto.

  - (* equality *)
     rw @member_eq. rw <- @member_equality_iff.
     rw @equality_in_int.
     clear dependent n2. clear dependent m2.
    allrw @member_int_iff. spcast. exrepnd.
   unfold equality_of_int.
   exists z0.
   sp; auto; spcast; auto.
   assert ( (mkc_integer z0) = @mkc_integer o (z + (z0 - z))) as eq by
     (apply mkc_integer_eq_iff; omega).
     rw eq; repeat (apply computes_to_valc_arithop;auto).
Qed.

Lemma rule_mul_one_true {o} :
  forall lib (H : barehypotheses)
         (n : @NTerm o),
    rule_true lib (rule_mul_one H n).
Proof.
  unfold rule_mul_one, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  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.
  exrepnd.
  fold_mk_arithop.
  lsubst_tac.

  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms n2.
  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.
    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.
   assert (mkc_integer (1 * z) = @mkc_integer o z) as eq by
     (apply mkc_integer_eq_iff; omega).
    exists z; sp; spcast; auto.
    rw<- eq. apply @computes_to_valc_arithop; auto.
    apply computes_to_valc_refl.
    apply iscvalue_mkc_integer.

Qed.

Lemma rule_add_zero_true {o} :
  forall lib (H : barehypotheses)
         (n : @NTerm o),
    rule_true lib (rule_add_zero H n).
Proof.
  unfold rule_add_zero, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  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.
  exrepnd.
  fold_mk_arithop.
  lsubst_tac.

  allrw (@equality_in_member o).
  exrepnd.
  apply (@tequality_member_int o) in hyp0; auto.
  generalize_lsubstc_terms n1.
  generalize_lsubstc_terms n2.
  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.
    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.
   assert (mkc_integer (0 + z) = @mkc_integer o z) as eq by
     (apply mkc_integer_eq_iff; omega).
    exists z; sp; spcast; auto.
    rw<- eq. apply @computes_to_valc_arithop; auto.
    apply computes_to_valc_refl.
    apply iscvalue_mkc_integer.

Qed.


(**

  This library deals with "natural maps", a slight shorthand for the
  situation where you have a commuting square of maps and regard (say)
  the horizontal maps as being some sort of natural transformation
  between the vertical ones.

 *)

Require Import Program.Basics.

Set Implicit Arguments.

Section nat_map.
  Variables A B C D: Type.
  Variable p : A -> B.
  Variable q : C -> D.

  Definition is_nat_map (fg : (A -> C) * (B -> D)) : Prop :=
    forall a : A, q (fst fg a) = snd fg (p a).

  Definition nat_map := sig is_nat_map.

  Definition nm_top (fg : nat_map) :=
    match fg with
      exist _ (f, _) _ => f
    end.

  Definition nm_bot (fg : nat_map) :=
    match fg with
      exist _ (_, g) _ => g
    end.

  Lemma nat_map_nat (fg : nat_map) (a : A)
    : q (nm_top fg a) = nm_bot fg (p a).
  Proof.
    destruct fg as [ pr H ].
    destruct pr as [ f g ].
    unfold is_nat_map in H.
    unfold nm_top, nm_bot.
    specialize (H a). auto.
  Qed.
End nat_map.

Definition sumf {A A' B B'} (f : A -> B) (g : A' -> B') (aa : A + A')
  : B + B' :=
  match aa with
  | inl a => inl (f a)
  | inr a' => inr (g a')
  end.

Definition nat_map_inl (A B C D : Type) (p : A -> B) (q : C -> D)
  : nat_map p (sumf p q) := exist (is_nat_map p (sumf p q))
                                  (inl, inl) (fun _ => eq_refl).

Definition nat_map_inr (A B C D : Type) (p : A -> B) (q : C -> D)
  : nat_map p (sumf q p) := exist (is_nat_map p (sumf q p))
                                  (inr, inr) (fun _ => eq_refl).

Definition nat_map_v (A B : Type) (p : A -> B)
  : nat_map p p := exist (is_nat_map p p) (id, id) (fun _ => eq_refl).

Definition nat_map_h (A B : Type) (f : A -> B)
  : nat_map id id := exist (is_nat_map id id) (f, f) (fun _ => eq_refl).

Lemma is_nat_map_comp_h (A B C D E F : Type)
      (p : A -> B) (q : C -> D) (r : E -> F)
      (m0 : nat_map p q) (m1 : nat_map q r)
  : is_nat_map p r (compose (nm_top m1) (nm_top m0),
                    compose (nm_bot m1) (nm_bot m0)).
Proof.
  destruct m0 as [ pr0 H0 ]; destruct pr0 as [ f0 g0 ].
  destruct m1 as [ pr1 H1 ]; destruct pr1 as [ f1 g1 ].
  unfold compose, is_nat_map in *. intro a. simpl.
  specialize (H0 a); simpl in H0.
  specialize (H1 (f0 a)); simpl in H1.
  rewrite H1, H0.
  exact eq_refl.
Qed.

Definition nat_map_comp_h (A B C D E F : Type)
           (p : A -> B) (q : C -> D) (r : E -> F)
           (m0 : nat_map p q) (m1 : nat_map q r)
  : nat_map p r := exist _ (compose (nm_top m1) (nm_top m0),
                            compose (nm_bot m1) (nm_bot m0))
                         (is_nat_map_comp_h m0 m1).

Lemma is_nat_map_comp_v (A B C D E F : Type)
      (p : A -> B) (q : C -> D) (p' : B -> E) (q' : D -> F)
      (m0 : nat_map p q) (m1 : nat_map p' q')
  : (forall b, nm_top m1 b = nm_bot m0 b) ->
    is_nat_map (compose p' p) (compose q' q) (nm_top m0, nm_bot m1).
Proof.
  intro eqH.
  destruct m0 as [ pr0 H0 ]; destruct pr0 as [ f0 g0 ].
  destruct m1 as [ pr1 H1 ]; destruct pr1 as [ f1 g1 ].
  unfold compose, is_nat_map in *. intro a. simpl.
  simpl in *.
  specialize (H0 a).
  specialize (H1 (p a)).
  specialize (eqH (p a)).
  rewrite H0, <- eqH, H1.
  exact eq_refl.
Qed.

Definition nat_map_comp_v (A B C D E F : Type)
           (p : A -> B) (q : C -> D) (p' : B -> E) (q' : D -> F)
           (m0 : nat_map p q) (m1 : nat_map p' q')
           (eqH : forall b, nm_top m1 b = nm_bot m0 b)
  : nat_map (compose p' p) (compose q' q) :=
  exist _ (nm_top m0, nm_bot m1) (is_nat_map_comp_v m0 m1 eqH).

Definition nat_map_diag (A B C : Type) (f : A -> B) (g : B -> C)
  : nat_map f g := exist (is_nat_map f g) (f, g) (fun _ => eq_refl).

Definition nat_map_some (A B : Type) (p : A -> B)
  : nat_map p (option_map p) := exist (is_nat_map p (option_map p))
                                      (Some, Some) (fun _ => eq_refl).

(*

  The notion of injectivity that we want is injectivity on the lower
  map. If [p] is surjective (which is usually the case in settings we
  care about), this is exactly asking that [nm_bot f] is injective. In
  general, we just ask that it's injective on the image of [p].

*)
Definition inj_nat_map
           (A B C D : Type) (p : A -> B) (q : C -> D)
           (f : nat_map p q) :=
  forall a a',
    nm_bot f (p a) = nm_bot f (p a') -> p a = p a'.

Definition inv_bottom
           (A B C D : Type) (p : A -> B) (q : C -> D)
           (f : nat_map p q) (g : nat_map q p) :=
  (forall a : A, nm_bot (nat_map_comp_h f g) (p a) = p a) /\
  (forall c : C, nm_bot (nat_map_comp_h g f) (q c) = q c).

(*
  Facts about composing nat maps horizontally.
*)
Section nm_pair.
  Variables A B C D E F : Type.
  Variable p : A -> D.
  Variable q : B -> E.
  Variable r : C -> F.

  Variable f : nat_map p q.
  Variable g : nat_map q r.

  Lemma nm_bot_comp_h d
    : nm_bot (nat_map_comp_h f g) d = nm_bot g (nm_bot f d).
  Proof.
    tauto.
  Qed.
End nm_pair.

Section nm_triple.
  Variables A0 A1 A2 A3 : Type.
  Variables B0 B1 B2 B3 : Type.
  Variable p0 : A0 -> B0.
  Variable p1 : A1 -> B1.
  Variable p2 : A2 -> B2.
  Variable p3 : A3 -> B3.

  Variable f : nat_map p0 p1.
  Variable g : nat_map p1 p2.
  Variable h : nat_map p2 p3.

  Lemma nm_comp_h_assoc_bot b0
    : nm_bot (nat_map_comp_h f (nat_map_comp_h g h)) b0 =
      nm_bot (nat_map_comp_h (nat_map_comp_h f g) h) b0.
  Proof.
    tauto.
  Qed.
End nm_triple.


(** * Introduction to interaction trees *)

(* HIDE *)
(* THIS IS ACTUALLY THE SOLUTIONS FILE. TO DO THE EXERCISES, SEE
   [tutorial/Introduction.v]. *)
(* /HIDE *)

(** This file contains exercises to get familiar with the
    Interaction Trees library, via the simplified
    interface of [theories/ITree/Simple.v].

    The solutions can be found in [examples/IntroductionSolutions.v].
 *)

(* begin hide *)
From Coq Require Import
     Arith
     Lia
     List.

From ExtLib Require Import
     Monad
     Traversable
     Data.List.

From ITree Require Import
     Simple.

Import ListNotations.
Import ITreeNotations.
Import MonadNotation.
Open Scope monad_scope.
(* end hide *)

(** * Events *)

(** We first show how to represent effectful computations
    as interaction trees. The [itree] type is parameterized
    by an _event type_, which is typically an indexed type
    with constructors describing the possible interactions
    with the environment.

    For instance, [ioE] below is a type of simple input/output
    events. The fields of each constructor contain data produced
    by the tree, and the type index the type of answer that the
    tree expects as a response to the event.
 *)

Inductive ioE : Type -> Type :=
| Input : ioE (list nat)
  (** Ask for a list of [nat] from the environment. *)

| Output : list nat -> ioE unit
  (** Send a list of [nat]. *)
.

(** Events are wrapped as ITrees using [ITree.trigger], and
    composed using monadic operations [bind] and [ret]. *)

(** Read some input, and echo it back, appending [1] to it. *)
Definition write_one : itree ioE unit :=
  xs <- ITree.trigger Input;;
  ITree.trigger (Output (xs ++ [1])).

(** We can _interpret_ interaction trees by giving semantics
    to their events individually, as a _handler_: a function
    of type [forall R, ioE R -> M R] for some monad [M]. *)

(** The handler [handle_io] below responds to every [Input] event
    with [[0]], and appends any [Output] to a global log.

    Here the target monad is [M := stateT (list nat) (itree void1)],
    - [stateT] is the state monad transformer, that type unfolds to
      [M R := list nat -> itree void1 (list nat * R)];
    - [void1] is the empty event (so the resulting ITree can trigger
      no event). *)

Compute Monads.stateT (list nat) (itree void1) unit.
Print void1.

Definition handle_io
  : forall R, ioE R -> Monads.stateT (list nat) (itree void1) R
  := fun R e log =>
       match e with
       | Input => ret (log, [0])
       | Output o => ret (log ++ o, tt)
       end.

(** [interp] lifts any handler into an _interpreter_, of type
    [forall R, itree ioE R -> M R]. *)
Definition interp_io
  : forall R, itree ioE R -> itree void1 (list nat * R)
  := fun R t => Monads.run_stateT (interp handle_io t) [].

(** We can now interpret [write_one]. *)
Definition interpreted_write_one : itree void1 (list nat * unit)
  := interp_io _ write_one.

(** Intuitively, [interp_io] replaces every [ITree.trigger] in the
    definition of [write_one] with [handle_io]:
[[
  interpreted_write_one =
    xs <- handle_io _ Input;;
    handle_io _ (Output (xs ++ [1]))
]]

    We can prove such a lemma in a more restricted setting, where
    [handle_io] targets some monad of the form [itree F], rather than
    [T (itree F)] (above, [T := stateT (list nat)]). (The library is
    currently missing some theory about the monads we can instantiate
    [interp] with.)

    The proof of [interp_write_one] will require us to rewrite an
    expression under a binder---i.e., on the right side of a
    [;;]. The [rewrite] tactic will fail in this situation; instead,
    we can use [setoid_rewrite], which works under binders.
 *)
Lemma interp_write_one F (handle_io : forall R, ioE R -> itree F R)
  : interp handle_io write_one
  ≈ (xs <- handle_io _ Input;;
     handle_io _ (Output (xs ++ [1]))).
Proof.
  unfold write_one.
  (* Use lemmas from [ITree.Simple] ([theories/Simple.v]). *)
  (* ADMITTED *)
  rewrite interp_bind.
  rewrite interp_trigger.
  setoid_rewrite interp_trigger.
  reflexivity.
Qed. (* /ADMITTED *)

(** An [itree void1] is a computation which can either return a value,
    or loop infinitely. Since Coq is total, [interpreted_write_one]
    will not be reduced naively.

    Instead, we can force computation with fuel, using [burn]:
 *)
Compute (burn 100 interpreted_write_one).

(** * General recursion with interaction trees *)

(** One application of [interp] is to define and reason about recursive
    functions as ITrees. In this section, we will demonstrate:
    - [rec]
    - equational reasoning using [≈] ([\approx])
*)

(** In this file, we won't use external events, so we will use this
    empty event type [void1]. *)
Definition E := void1.

(** ** Factorial *)

(** This is the Coq specification -- the usual mathematical definition. *)
Fixpoint factorial_spec (n : nat) : nat :=
  match n with
  | 0 => 1
  | S m => n * factorial_spec m
  end.

(** The generic [rec] interface of the library's [Interp] module can
    be used to define a single recursive function.  The more general
    [mrec] (from which [rec] is defined) allows multiple, mutually
    recursive definitions.

    The argument of [rec] is an interaction tree with an event type
    [callE A B] to represent "recursive calls", with input [A]
    and output [B]. The function [call : A -> itree _ B] can be used
    to make such calls.

    In this case, since [factorial : nat -> nat], we use
    [callE nat nat].
 *)
Definition fact_body (x : nat) : itree (callE nat nat +' E) nat :=
  match x with
  | 0 => Ret 1
  | S m =>
    y <- call m ;;  (* Recursively compute [y := m!] *)
    Ret (x * y)
  end.

(** The factorial function itself is defined as an ITree by "tying
    the knot" using [rec].
 *)
Definition factorial (n : nat) : itree E nat :=
  rec fact_body n.

(** *** Evaluation *)

(** Contrary to definitions by [Fixpoint], there are no restrictions
    on the arguments of recursive calls: [rec] may thus produce
    diverging computations, and Coq will not naively reduce
    [factorial 5].

    We can force the computation with fuel, e.g., using [burn]...
 *)
Compute (burn 100 (factorial 5)).

(** ... or with tactics, such as [tau_steps], which removes
    all taus from the left-hand side of an [≈] equation. *)
Example fact_5 : factorial 5 ≈ Ret 120.
Proof.
  tau_steps. reflexivity.
Qed.

(** *** Alternative notation *)

(** An equivalent definition with a [rec-fix] notation looking like
    [fix], where the recursive call can be given a more specific name.
 *)
Definition factorial' : nat -> itree E nat :=
  rec-fix fact x :=
    match x with
    | 0 => Ret 1
    | S m => y <- fact m ;; Ret (x * y)
    end.

(** These two definitions are definitionally equal. *)
Lemma factorial_same : factorial = factorial'.
Proof. reflexivity. Qed.

(** *** Correctness *)

(** [rec] is actually a special version of [interp], which replaces
    every [call] in [fact_body] with [factorial] itself.
 *)
Lemma unfold_factorial : forall x,
    factorial x ≈ match x with
                  | 0 => Ret 1
                  | S m =>
                    y <- factorial m ;;
                    Ret (x * y)
                  end.
Proof.
  intros x.
  unfold factorial.
  (* ADMITTED *)
  rewrite rec_as_interp; unfold fact_body at 2.
  destruct x.
  - rewrite interp_ret.
    reflexivity.
  - rewrite interp_bind.
    rewrite interp_recursive_call.
    setoid_rewrite interp_ret.
    reflexivity.
Qed. (* /ADMITTED *)

(** We can prove that the ITrees version [factorial] is "equivalent"
    to the [factorial_spec] version.  The proof goes by induction on
    [n] and uses only rewriting -- no coinduction necessary.

    Here, we detail each step of rewriting to illustrate the use of
    the equational theory, which is mostly applications of the monad
    laws and the properties of [rec].

    In this proof, we do all of the rewriting steps explicitly.
 *)
Lemma factorial_correct : forall n,
    factorial n ≈ Ret (factorial_spec n).
Proof.
  intros n.
  (* ADMITTED *)
  induction n as [ | n' IH ].
  - (* n = 0 *)
    rewrite unfold_factorial.
    reflexivity.
  - (* n = S n' *)
    rewrite unfold_factorial.
    rewrite IH.                   (* Induction hypothesis *)
    rewrite bind_ret.
    simpl.
    reflexivity.
Qed. (* /ADMITTED *)

(* HIDE *)
(** The tactics [tau_steps] and [autorewrite with itree] offer
    a little automation to simplify monadic expressions. *)
Lemma factorial_correct' : forall n,
    factorial n ≈ Ret (factorial_spec n).
Proof.
  intros n.
  unfold factorial.
  induction n as [ | n' IH ].
  - (* n = 0 *)
    tau_steps. (* Just compute away. *)
    reflexivity.
  - (* n = S n' *)
    rewrite rec_as_interp.
    unfold fact_body at 2.
    autorewrite with itree.
    rewrite IH.             (* Induction hypothesis *)
    autorewrite with itree.
    reflexivity.
Qed.
(* /HIDE *)

(** ** Fibonacci *)

(** Carry out the analogous proof of correctness for the Fibonacci
    function, whose naturally recursive coq definition is given below.
 *)

Fixpoint fib_spec (n : nat) : nat :=
  match n with
  | 0 => 0
  | S n' =>
    match n' with
    | 0 => 1
    | S n'' => fib_spec n'' + fib_spec n'
    end
  end.

Definition fib_body : nat -> itree (callE nat nat +' E) nat
  (* ADMITDEF *)
  := fun n =>
    match n with
    | 0 => Ret 0
    | S n' =>
      match n' with
      | 0 => Ret 1
      | S n'' =>
        y1 <- call n'' ;;
        y2 <- call n' ;;
        Ret (y1 + y2)
      end
    end.
  (* /ADMITDEF *)

Definition fib n : itree E nat :=
  rec fib_body n.

Example fib_3_6 : mapT fib [4;5;6] ≈ Ret [3; 5; 8].
Proof.
  (* Use [tau_steps] to compute. *)
  (* ADMITTED *)
  tau_steps. reflexivity.
Qed. (* /ADMITTED *)

(** Since fib uses two recursive calls, we need to strengthen the
    induction hypothesis.  One way to do that is to prove the
    property for all [m <= n].

    You may find the following two lemmas useful at the start
    of each case.
[[
Nat.le_0_r : forall n : nat, n <= 0 <-> n = 0
Nat.le_succ_r : forall n m : nat, n <= S m <-> n <= m \/ n = S m
]]
 *)

Lemma fib_correct_aux : forall n m, m <= n ->
    fib m ≈ Ret (fib_spec m).
Proof.
  intros n.
  unfold fib.
  induction n as [ | n' IH ]; intros.
  - (* n = 0 *)
    apply Nat.le_0_r in H. subst m.
    (* ADMIT *)
    rewrite rec_as_interp. simpl.
    rewrite interp_ret.
    (* alternatively, [tau_steps], or [autorewrite with itree] *)
    reflexivity.
    (* /ADMIT *)
  - (* n = S n' *)
    apply Nat.le_succ_r in H.
    (* ADMIT *)
    destruct H.
    + apply IH. auto.
    + rewrite rec_as_interp.
      subst m. simpl.
      destruct n' as [ | n'' ].
      * rewrite interp_ret. reflexivity.
      * autorewrite with itree.
        rewrite IH. 2: lia.
        autorewrite with itree.
        rewrite IH. 2: lia.
        autorewrite with itree.
        reflexivity.
    (* /ADMIT *)
(* ADMITTED *) Qed. (* /ADMITTED. *)

(** The final correctness result follows. *)
Lemma fib_correct : forall n,
    fib n ≈ Ret (fib_spec n).
Proof. (* ADMITTED *)
  intros n.
  eapply fib_correct_aux.
  reflexivity.
Qed. (* /ADMITTED *)

(** ** Logarithm *)

(** An example of a function which is not structurally recursive.
    [log_ b n]: logarithm of [n] in base [b].

    Specification:
      [log_ b (b ^ y) ≈ Ret y] when [1 < b].

    (Note that this only constrains a very small subset of inputs,
    and in fact our solution diverges for some of them.)
 *)
Definition log (b : nat) : nat -> itree E nat
  (* ADMITDEF *)
  := rec-fix log_b n :=
       if n <=? 1 then
         Ret O
       else
         y <- log_b (n / b) ;; Ret (S y).
  (* /ADMITDEF *)

Example log_2_64 : log 2 (2 ^ 6) ≈ Ret 6.
Proof.
  (* ADMITTED *)
  tau_steps. reflexivity.
Qed. (* /ADMITTED *)

(** These lemmas take care of the boring arithmetic. *)
Lemma log_correct_helper :
  forall b y, 1 < b ->
              (b * b ^ y <=? 1) = false.
Proof.
  intros.
  apply Nat.leb_gt.
  apply Nat.lt_1_mul_pos; auto.
  apply Nat.neq_0_lt_0. intro.
  apply (Nat.pow_nonzero b y); lia.
Qed.

Lemma log_correct_helper2 :
  forall b y, 1 < b ->
              (b * b ^ y / b) = (b ^ y).
Proof.
  intros; rewrite Nat.mul_comm, Nat.div_mul; lia.
Qed.

Lemma log_correct : forall b y, 1 < b -> log b (b ^ y) ≈ Ret y.
Proof.
  intros b y H.
  (* ADMITTED *)
  unfold log, rec_fix.
  induction y.
  - rewrite rec_as_interp; cbn.
    autorewrite with itree.
    reflexivity.
  - rewrite rec_as_interp; cbn.
    (* (b * b ^ y <=? 1) = false *)
    rewrite log_correct_helper by auto.
    autorewrite with itree.
    (* (b * b ^ y / b) = (b ^ y)*)
    rewrite log_correct_helper2 by auto.
    rewrite IHy.
    autorewrite with itree.
    reflexivity.
Qed. (* /ADMITTED *)


From Coq          Require Import Init.Nat.
From Coq          Require Import Lists.List.
From Coq          Require Import Logic.Eqdep_dec.
From Coq          Require Import Omega.
From Coq          Require Import String.
From Coq          Require Import Vectors.Vector.

From CryptolToCoq Require Import CryptolPrimitivesForSAWCore.
From CryptolToCoq Require Import CryptolPrimitivesForSAWCoreExtra.
From CryptolToCoq Require Import Cryptol_proofs.
From CryptolToCoq Require Import MEE_CBC.
From CryptolToCoq Require Import SAWCorePrelude.
From CryptolToCoq Require Import SAWCorePreludeExtra.
From CryptolToCoq Require Import SAWCorePrelude_proofs.
From CryptolToCoq Require Import SAWCoreScaffolding.
From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors.

Import CryptolPrimitives.
Import SAWCorePrelude.

(*Notation "a" := (TCNum a) (at level 0, a at level 0, only printing).*)
Notation "a '+' b" := (tcAdd a b).
Notation "a '-' b" := (tcSub a b).
Notation "a '*' b" := (tcMul a b).
Notation "'Bit'" := (Bool).
Notation "b '[' a ']'" := (seq a b) (left associativity, at level 50).
Notation "'Byte'" := (seq (TCNum 8) Bool).
Notation "'🧙' a" := (coerce _ _ _ a) (at level 100, a at level 0, only printing).

Inductive finite : Num -> Prop :=
| TCNum_finite : forall n, finite (TCNum n)
.

Definition tcGe (a b : Num) : Prop :=
  match a, b with
  | TCNum a, TCNum b => ge a b
  | TCInf,   _       => Coq.Init.Logic.True
  | _,       TCInf   => Coq.Init.Logic.False
  end.

Notation "a '≥' b" := (tcGe a b) (at level 90, only printing).
Notation "'|' a '|'" := (tcWidth a) (only printing).

Definition blkBytes : Num := TCNum 16. (* TODO: translate me *)

Inductive pad_preconditions n p b :=
| mk_pad_preconditions :
      forall
        (fin_n   : finite n)
        (width_p : tcGe (TCNum 8) (tcWidth p))
        (p_eq    : p = tcSub (tcMul blkBytes b) n)
        (bound_n : tcGe (tcMul blkBytes b) n)
      ,
        pad_preconditions n p b
.

Inductive unpad_preconditions n p b :=
| mk_unpad_preconditions :
      forall
        (fin_n   : finite n)
        (width_p : tcGe (TCNum 8) (tcWidth p))
        (p_eq    : p = tcSub (tcMul blkBytes b) n)
        (bound_n : tcGe (tcMul blkBytes b) n)
      ,
        unpad_preconditions n p b
.

Theorem ecNumber_PLiteralSeqBool : forall n,
    ecNumber (TCNum n) Byte (PLiteralSeqBool (TCNum 8)) = bvNat 8 n.
Proof.
  reflexivity.
Qed.

Theorem rewriteRepeat T (x : T) n : repeat (TCNum n) _ x = Vector.const x n.
Proof.
  unfold repeat, seqMap.
  unfold Num_rect, map.
  induction n.
  { reflexivity. }
  {
    simpl in *.
    now f_equal.
  }
Qed.

Definition fin_seq_concat T m n :
    seq (TCNum m) T -> seq (TCNum n) T -> seq (tcAdd (TCNum m) (TCNum n)) T.
  simpl.
  rewrite rewrite_addNat.
  apply Vector.append.
Defined.

Theorem Nat__rec_S t o s n : Nat__rec t o s (S n) = s n (Nat__rec t o s n).
Proof.
  induction n; reflexivity.
Qed.

Theorem rewrite_ltNat m n : ltNat m n = ltb m n.
Proof.
  unfold ltNat.
  rewrite Nat_cases2_match_spec.
  revert m.
  induction n.
  {
    reflexivity.
  }
  {
    intros m.
    destruct m.
    {
      reflexivity.
    }
    {
      simpl.
      now rewrite IHn.
    }
  }
Qed.

Theorem ltb_add_left a b : a + b <? a = false.
Proof.
  destruct (PeanoNat.Nat.ltb_spec0 (a + b) a).
  { omega. }
  { reflexivity. }
Qed.

Theorem subNat_add m n : subNat (m + n)%nat m = n.
  unfold subNat.
  rewrite Nat_cases2_match_spec.
  induction m.
  {
    reflexivity.
  }
  {
    simpl.
    assumption.
  }
Qed.

Theorem rewrite_ecCat_TCNum m n a b :
    ecCat (TCNum m) (TCNum n) Byte a b = fin_seq_concat _ m n a b.
Proof.
  unfold ecCat.
  simpl.
  unfold append.
  unfold fin_seq_concat.
  rewrite rewrite_addNat.
  rewrite gen_add.
  f_equal.
  {
    rewrite gen_domain_eq with (g := fun i => sawAt m _ a i).
    {
      setoid_rewrite rewrite_ltNat.
      setoid_rewrite ltb_add_left.
      setoid_rewrite subNat_add.
      rewrite gen_sawAt.
      rewrite gen_sawAt.
      reflexivity.
    }
    {
      intros x XM.
      rewrite rewrite_ltNat.
      destruct (PeanoNat.Nat.ltb_spec0 x m).
      {
        reflexivity.
      }
      {
        intuition.
      }
    }
  }
Qed.

Theorem rewrite_ecCat m n a b :
    ecCat m n Byte a b =
    match m as m' return Byte [m'] -> Byte [m' + n] with
    | TCNum m' => fun a' =>
      match n as n' return Byte [n'] -> Byte [TCNum m' + n'] with
      | TCNum n' => fun b' => fin_seq_concat _ m' n' a' b'
      | _ => fun b' => streamAppend Byte _ a' b'
      end b
    | _ => fun a' =>
            error
              (forall (n0 : Num) (a0 : Type), a0 [TCInf] -> a0 [n0] -> a0 [TCInf + n0])
              "Unexpected Fin constraint violation!" n Byte a' b
    end a.
Proof.
  destruct m.
  {
    destruct n.
    {
      apply rewrite_ecCat_TCNum.
    }
    {
      reflexivity.
    }
  }
  {
    reflexivity.
  }
Qed.

Fixpoint join_fixpoint m n a (v : Vec m (Vec n a)) {struct v} : Vec (mulNat m n) a :=
  match v in Vector.t _ m' return Vec (mulNat m' n) a with
  | nil _ => nil _
  | cons _ h m' t => append _ _ _ h (join_fixpoint _ _ _ t)
  end.

Theorem rewrite_mulNat m n : mulNat m n = (m * n)%nat.
Proof.
  induction m.
  {
    reflexivity.
  }
  {
    simpl.
    rewrite rewrite_addNat.
    congruence.
  }
Defined.

Notation "<< Sig # C >> x" := (eq_rect _ Sig x _ C) (at level 65).
Notation "{{ Sig # x == y }}" := (existT Sig _ x = existT Sig _ y) (at level 50).

Definition typeId (T : Type) := T.

Theorem rewrite_divModNat m n : divModNat m n = (m / n, m mod n).
Proof.
  destruct n.
  {
    simpl.
    reflexivity.
  }
  {
    simpl.
    destruct (divmod m n 0 n).
    reflexivity.
  }
Qed.

Theorem rewrite_divNat m n : divNat m n = m / n.
Proof.
  unfold divNat.
  now rewrite rewrite_divModNat.
Qed.

Theorem rewrite_modNat m n : modNat m n = m mod n.
Proof.
  unfold modNat.
  now rewrite rewrite_divModNat.
Qed.

Theorem rewrite_append m n T a b :
    existT _ (addNat m n) (append m n T a b) =
    existT _ (m + n)%nat (Vector.append a b).
Proof.
  unfold append.
  induction a.
  {
    simpl.
    rewrite gen_sawAt.
    reflexivity.
  }
  {
    simpl.
    rewrite sawAt_zero.
    setoid_rewrite sawAt_S.
    dependent rewrite <- IHa.
    reflexivity.
  }
Qed.

Theorem rewrite_join' m n a v :
    existT (Vector.t a) (mulNat m n) (join m n a v) =
    existT (Vector.t a) (mulNat m n) (join_fixpoint m n a v).
Proof.
  induction v as [ | h i v ].
  {
    unfold join.
    simpl.
    reflexivity.
  }
  {
    unfold join.
    simpl.
    setoid_rewrite rewrite_modNat.
    setoid_rewrite rewrite_divNat.
    pattern (addNat n (mulNat i n)) at 1 2.
    rewrite rewrite_addNat.
    rewrite gen_add.
    rewrite gen_domain_eq with (g := fun i => sawAt n a h i).
    {
      rewrite gen_sawAt.
      unfold join in IHv.
      rewrite gen_domain_eq with (g := fun x => sawAt _ _ (sawAt _ _ v (divNat x n)) (modNat x n)).
      {
        apply inj_pair2_eq_dec in IHv.
        {
          rewrite IHv.
          rewrite rewrite_append.
          reflexivity.
        }
        {
          apply Peano_dec.eq_nat_dec.
        }
      }
      {
        rewrite rewrite_mulNat.
        intros m M.
        assert (0 < n) by (destruct n; omega).
        pose proof (Nat.lt_exists_pred 0 ((n + m) / n)) as P1.
        destruct P1 as [ x [ H1 H2 ] ].
        {
          pose proof (Nat.div_str_pos (n + m) n) as P2.
          apply P2.
          constructor; omega.
        }
        {
          simpl.
          rewrite H1.
          rewrite sawAt_S.
          pose proof (Nat.mod_add m 1 n) as P1.
          replace (m + 1 * n)%nat with (n + m)%nat in P1 by omega.
          rewrite P1.
          {
            rewrite rewrite_modNat.
            rewrite rewrite_divNat.
            f_equal.
            f_equal.
            pose proof (Nat.div_add m 1 n) as P2.
            replace (m + 1 * n)%nat with (n + m)%nat in P2 by omega.
            rewrite P2 in H1.
            {
              omega.
            }
            {
              omega.
            }
          }
          {
            omega.
          }
        }
      }
    }
    {
      intros m M.
      rewrite (Nat.mod_small m n M).
      rewrite (Nat.div_small m n M).
      rewrite sawAt_zero.
      reflexivity.
    }
  }
Qed.

Theorem rewrite_join m n a v : join m n a v = join_fixpoint m n a v.
Proof.
  apply (inj_pair2_eq_dec nat).
  {
    apply Peano_dec.eq_nat_dec.
  }
  {
    apply rewrite_join'.
  }
Qed.

Definition ecJoin_fixpoint m n a : a [n] [m] -> a [m * n] :=
  match m as m' return a [n] [m'] -> a [m' * n] with
  | TCNum m' =>
    match n as n' return forall a, Vec m' (a [n']) -> a [TCNum m' * n'] with
    | TCNum n' => join_fixpoint m' n'
    | TCInf => error _ "Unexpected Fin constraint violation!"
    end a
  | TCInf =>
    match n as n' return forall a, Stream (a [n']) -> a [TCInf * n'] with
    | TCNum n' =>
      match n' as n'' return forall a, Stream (a [TCNum n'']) -> a [TCInf * TCNum n''] with
      | 0     => fun a _ => nil a
      | S n'' => fun a s => streamJoin a n'' s (* TODO: do we want a co-inductive version? *)
      end
    | TCInf => error _ "Unexpected Fin constraint violation!"
    end a
  end.

Theorem rewrite_ecJoin m n a v : ecJoin m n a v = ecJoin_fixpoint m n a v.
Proof.
  destruct m.
  {
    unfold ecJoin_fixpoint.
    destruct n.
    {
      simpl.
      apply rewrite_join.
    }
    {
      simpl.
      reflexivity.
    }
  }
  {
    destruct n.
    {
      destruct n.
      {
        reflexivity.
      }
      {
        reflexivity.
      }
    }
    {
      simpl.
      reflexivity.
    }
  }
Qed.

Fixpoint split_fixpoint m n a {struct m} : Vec (mulNat m n) a -> Vec m (Vec n a).
Proof.
  intros v.
  induction m.
  {
    apply nil.
  }
  {
    apply cons.
    {
      simpl in v.
      eapply SAWCorePrelude.take.
      apply v.
    }
    {
      apply split_fixpoint.
      eapply SAWCorePrelude.drop.
      apply v.
    }
  }
Defined.

Theorem sawAt_drop T m n (v : Vec (addNat n m) T) i:
    sawAt _ _ (SAWCorePrelude.drop _ _ _ v) i =
    sawAt _ _ v (n + i)%nat.
Proof.
  induction n.
  {
    simpl.
    unfold SAWCorePrelude.drop.
    rewrite gen_sawAt.
    reflexivity.
  }
  {
    simpl in v.
    apply @Vector.caseS' with (v := v).
    intros h t.
    simpl.
    setoid_rewrite sawAt_S.
    rewrite <- IHn.
    f_equal.
  }
Qed.

Lemma rewrite_split m n a v : split m n a v = split_fixpoint m n a v.
Proof.
  induction m.
  {
    reflexivity.
  }
  {
    unfold split.
    simpl.
    f_equal.
    {
      rewrite <- IHm.
      unfold split.
      apply gen_domain_eq.
      intros i I.
      apply gen_domain_eq.
      intros j J.
      admit.
    }
  }
Admitted.

Lemma join_split s n (v : Byte [TCNum s * TCNum n]) :
    join_fixpoint s n (Vec 8 Bit) (split_fixpoint s n (Vec 8 Bit) v) = v.
Proof.
Admitted.

Theorem ecJoin_ecSplit m n v : ecJoin m n Byte (ecSplit m n Byte v) = v.
  rewrite rewrite_ecJoin.
  destruct m; destruct n; simpl.
  {
    rewrite rewrite_split.
    apply join_split.
  }
  {
    admit.
  }
  {
    admit.
  }
  {
    admit.
  }
Admitted.

Theorem fin_seq_concat_cons T m n h a b :
    fin_seq_concat T (S m) n (cons T h m a) b =
    cons T h (addNat m n) (fin_seq_concat T m n a b).
Proof.
  unfold fin_seq_concat.
  unfold eq_rect_r.
  simpl.
  unfold f_equal_nat.
  rewrite eq_sym_map_distr.
  destruct (eq_sym _).
  simpl.
  reflexivity.
Qed.

Theorem rewrite_fin_seq_concat T m n a b :
    existT (Vector.t T) (addNat m n) (fin_seq_concat T m n a b) =
    existT (Vector.t T) (m + n)%nat (Vector.append a b).
Proof.
  induction a.
  {
    compute.
    reflexivity.
  }
  {
    simpl.
    dependent rewrite <- IHa.
    f_equal.
    rewrite fin_seq_concat_cons.
    reflexivity.
  }
Qed.

Theorem sawAt_fin_seq_concat_left T m n a :
    forall b i,
    i < m ->
    sawAt (addNat m n) T (fin_seq_concat T m n a b) i = sawAt m T a i.
Proof.
  induction a as [ | h m t]; intros b i I.
  {
    omega.
  }
  {
    rewrite fin_seq_concat_cons.
    destruct i.
    {
      simpl.
      rewrite !sawAt_zero.
      reflexivity.
    }
    {
      simpl.
      rewrite !sawAt_S.
      apply IHt.
      omega.
    }
  }
Qed.

Theorem take_fin_seq_concat T m n a b :
    take (TCNum m) (TCNum n) T (fin_seq_concat T m n a b) = a.
Proof.
  induction a as [ | h m t ].
  {
    unfold take.
    unfold fin_seq_concat.
    simpl.
    unfold SAWCorePrelude.take.
    simpl.
    reflexivity.
  }
  {
    unfold take.
    simpl.
    unfold SAWCorePrelude.take.
    simpl.
    rewrite fin_seq_concat_cons.
    rewrite sawAt_zero.
    f_equal.
    setoid_rewrite sawAt_S.
    pose proof (sawAt_fin_seq_concat_left _ _ _ t b).
    rewrite gen_domain_eq with (g := fun i => sawAt _ _ t i).
    {
      apply gen_sawAt.
    }
    {
      intros i I.
      now apply sawAt_fin_seq_concat_left.
    }
  }
Qed.

Theorem pad_unpad n p b msg tag :
    pad_preconditions   n p b ->
    (* NOTE: those are the exact same as `pad_preconditions`, redundant *)
    (* unpad_preconditions n p b -> *)
    unpad n p b (pad n p b msg tag) = (msg, (tag, false)).
Proof.
  intros [].
  destruct n as [n|]; [clear fin_n|inversion fin_n].
  destruct p as [p|]; [|contradiction].
  destruct b as [b|]; [|inversion p_eq].
  unfold pad, unpad.
  rewrite ecNumber_PLiteralSeqBool.
  rewrite rewriteRepeat.
  f_equal.
  {
    rewrite rewrite_ecCat_TCNum.
    rewrite rewrite_ecCat.
    rewrite ecJoin_ecSplit.
    unfold coerce.

    unfold seq_cong1.
    unfold eq_cong.
    unfold Eq__rec.
    unfold identity_rect.

    Theorem plus_minus a b : a + b - a = b.
    Admitted.

    pattern (TCNum n + (TCNum 16 * (TCNum 2 + TCNum b) - TCNum n)).

    setoid_rewrite plus_minus.

    Axiom rewrite_sawUnsafeAssert : forall T x, sawUnsafeAssert T x x = identity_refl x.

    unfold sawUnsafeAssert.

    pattern (seq_cong1 (TCNum 16 * (TCNum 2 + TCNum b))) at 1.
    remember (TCNum 16 * (TCNum 2 + TCNum b) - TCNum n) as n1.
    cbn.
    unfold coerce.
    destruct seq_cong1.

    simpl.
    destruct (TCNum 32 + TCNum p).
    admit.
  }
  {
    f_equal.
    {
      admit.
    }
    {
      unfold ecEq.
      unfold Rget.
    }
  }
Admitted.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Basic_Cons.CCC Basic_Cons.PullBack.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import PreSheaf.PreSheaf.

Section PSh_PullBack.
  Context (C : Category) {F G I : PreSheaf C} (f : (F –≻ I)%nattrans) (g : (G –≻ I)%nattrans).

  Local Hint Extern 1 =>
  match goal with
    [x : sig _ |- _ ] =>
    let H := fresh "H" in
    destruct x as [x H]
  end.

  Local Hint Extern 1 => match goal with [|- context [(?F _a id)%morphism]] => rewrite (F_id F) end.
  Local Hint Extern 1 =>
  match goal with
    [|- context [(?F _a (?f ∘ ?g))%morphism]] =>
    cbn_rewrite (F_compose F f g)
  end.

  Local Hint Extern 1 =>
  match goal with
    [|- context [Trans ?f _ ((?F _a)%morphism ?h _)]] =>
    cbn_rewrite (equal_f (Trans_com f h))
  end.

  Local Hint Extern 1 => progress cbn in *.

  Local Obligation Tactic := basic_simpl; auto 10.

  (** The pointwise pullback presheaf. *)
  Program Definition PSh_PullBack_Func : PreSheaf C :=
    {|
      FO :=
        fun c =>
          {x : ((F _o c) * (G _o c))%object%type |
           Trans f c (fst x) = Trans g c (snd x)
          };
      FA :=
        fun c c' h x =>
          exist
            _
            ((F _a h (fst (proj1_sig x)))%morphism, (G _a h (snd (proj1_sig x)))%morphism)
            _
    |}.

  (** The morphism from the pullback to the domain object of the first morphism. *)
  Program Definition PSh_PullBack_morph_1 : (PSh_PullBack_Func –≻ F)%nattrans :=
    {|
      Trans := fun c x => fst (proj1_sig x)
    |}.

  (** The morphism from the pullback to the domain object of the second morphism. *)
  Program Definition PSh_PullBack_morph_2 : (PSh_PullBack_Func –≻ G)%nattrans :=
    {|
      Trans := fun c x => snd (proj1_sig x)
    |}.

  (** The morphism from the candidate pullback to the pullback. *)
  Program Definition PSh_PullBack_morph_ex
          (p' : (C ^op –≻ Type_Cat)%functor)
          (pm1 : (p' –≻ F)%nattrans)
          (pm2 : (p' –≻ G)%nattrans)
          (H : (f ∘ pm1)%nattrans = (g ∘ pm2)%nattrans)
    :
      (p' –≻ PSh_PullBack_Func)%nattrans
    :=
      {|
        Trans :=
          fun c x =>
            exist
              _
              (Trans pm1 c x, Trans pm2 c x)
              (f_equal (fun w : (p' –≻ I)%nattrans => Trans w c x) H)
      |}.

  (** The pointwise pullback presheaf is the pullback of presheafs. *)
  Program Definition PSh_PullBack : @PullBack (PShCat C) _ _ _ f g :=
    {|
      pullback := PSh_PullBack_Func;
      pullback_morph_1 := PSh_PullBack_morph_1;
      pullback_morph_2 := PSh_PullBack_morph_2;
      pullback_morph_ex := PSh_PullBack_morph_ex
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros p' pm1 pm2 H u u' H1 H2 H3 H4.
    rewrite <- H3 in H1; clear H3.
    rewrite <- H4 in H2; clear H4.
    apply NatTrans_eq_simplify.
    extensionality c.
    extensionality x.
    assert (H1' := f_equal (fun w : (p' –≻ F)%nattrans => Trans w c x) H1); clear H1.
    assert (H2' := f_equal (fun w : (p' –≻ G)%nattrans => Trans w c x) H2); clear H2.
    cbn in *.
    match goal with
      [|- ?A = ?B] => destruct A as [[? ?] ?]; destruct B as [[? ?] ?]
    end.
    apply sig_proof_irrelevance.
    cbn in *; subst; trivial.
  Qed.

End PSh_PullBack.

Instance PSh_Has_PullBacks (C : Category) : Has_PullBacks (PShCat C) :=
  @PSh_PullBack C.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tG_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deftogethergreater_1 : (forall A B C D E F : Universe, (exists X : Universe, (tG_ A B C D E F -> (betS_ A B X /\ (cong_ B X C D /\ lt_ E F A X))))).
Variable deftogethergreater2_2 : (forall A B C D E F X : Universe, ((betS_ A B X /\ (cong_ B X C D /\ lt_ E F A X)) -> tG_ A B C D E F)).
Variable lemma_betweennotequal_3 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_inequalitysymmetric_4 : (forall A B : Universe, (A <> B -> B <> A)).
Variable axiom_nocollapse_5 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
Variable lemma_extension_6 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable cn_equalityreverse_7 : (forall A B : Universe, cong_ A B B A).
Variable lemma_congruencesymmetric_8 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruencetransitive_9 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable cn_sumofparts_10 : (forall A B C E F G : Universe, ((cong_ A B E F /\ (cong_ B C F G /\ (betS_ A B C /\ betS_ E F G))) -> cong_ A C E G)).
Variable lemma_lessthancongruence_11 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ C D E F) -> lt_ A B E F)).
Variable lemma_lessthancongruence2_12 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ A B E F) -> lt_ E F C D)).

Theorem lemma_TGflip_13 : (forall A B C Xa Xb Xc : Universe, (tG_ A Xa B Xb C Xc -> (tG_ Xa A B Xb C Xc /\ tG_ A Xa B Xb Xc C))).
Proof.
  time tac.
Qed.

End FOFProblem.


(* NIZK Proof System - verification script by Remi Bazin *)

Load pairings.

(* Bilinear groups and a few constants *)
Inductive B1 : Set :=
  | ConstrB1 : G1 -> G1 -> B1.
Inductive B2 : Set :=
  | ConstrB2 : G2 -> G2 -> B2.
Inductive BT : Set :=
  | ConstrBT : GT -> GT -> GT -> GT -> BT.

Definition B1_O : B1 := ConstrB1 G1_O G1_O.
Definition B2_O : B2 := ConstrB2 G2_O G2_O.
Definition BT_1 : BT := ConstrBT GT_1 GT_1 GT_1 GT_1.

(* Group operations *)

Definition addB1 (a b:B1) : B1 :=
  match a with | ConstrB1 a1 a2 =>
    match b with | ConstrB1 b1 b2 =>
      ConstrB1 (addG1 a1 b1) (addG1 a2 b2)
    end
  end
.

Definition addB2 (a b:B2) : B2 :=
  match a with | ConstrB2 a1 a2 =>
    match b with | ConstrB2 b1 b2 =>
      ConstrB2 (addG2 a1 b1) (addG2 a2 b2)
    end
  end
.

Definition multBT (a b:BT) : BT :=
  match a with | ConstrBT a1 a2 a3 a4 =>
    match b with | ConstrBT b1 b2 b3 b4 =>
      ConstrBT (multGT a1 b1) (multGT a2 b2) (multGT a3 b3) (multGT a4 b4)
    end
  end
.

(* Mathematical structure properties *)
Theorem B1_abelian : (Is_Fp_isomorphic B1 addB1 p).
Proof.
  admit. (* TODO *)
Qed.

Theorem B2_abelian : (Is_Fp_isomorphic B2 addB2 p).
Proof.
  admit. (* TODO *)
Qed.

Theorem BT_abelian : (Is_Fp_isomorphic BT multBT p).
Proof.
  admit. (* TODO *)
Qed.


(** Here we define signatures for HITs *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

(**
Data type of polynomials.
These are used for both the point constructor and the arguments of the path constructors.
 *)
Inductive poly_code : UU :=
| C : hSet → poly_code
| I : poly_code
| plus : poly_code → poly_code → poly_code
| times : poly_code → poly_code → poly_code.

Notation "P + Q" := (plus P Q).
Notation "P * Q" := (times P Q).

(**
Type of endpoints
 *)
Inductive endpoint (A : poly_code) : poly_code → poly_code → UU :=
| id_e : forall (P : poly_code), endpoint A P P
| comp : forall (P Q R : poly_code), endpoint A P Q → endpoint A Q R → endpoint A P R
| ι₁ : forall (P Q : poly_code), endpoint A P (P + Q)
| ι₂ : forall (P Q : poly_code), endpoint A Q (P + Q)
| π₁ : forall (P Q : poly_code), endpoint A (P * Q) P
| π₂ : forall (P Q : poly_code), endpoint A (P * Q) Q
| pair : forall (P Q R : poly_code),
    endpoint A P Q -> endpoint A P R → endpoint A P (Q * R)
| c : forall (P : poly_code) (T : hSet), T → endpoint A P (C T)
| fmap : forall {X Y : hSet} (f : X → Y), endpoint A (C X) (C Y)
| constr : endpoint A A I.

Arguments id {_} _.
Arguments comp {A} {P} {Q} {R} _ _.
Arguments ι₁ {_} P Q.
Arguments ι₂ {_} P Q.
Arguments π₁ {_} P Q.
Arguments π₂ {_} P Q.
Arguments pair {A} {P} {Q} {R} _ _.
Arguments c {_} P {_} _.
Arguments fmap {_} {X Y} f.
Arguments constr {_}.

(**
The signature of a HIT
 *)
Definition hit_signature
  := ∑ (A : poly_code) (J : Type) (Q : J → poly_code),
     (∏ (j : J), endpoint A (Q j) I)
     ×
      ∏ (j : J), endpoint A (Q j) I.

(**
Projections of HIT signatures
 *)
Section SignatureProjections.
  Variable (Σ : hit_signature).

  Definition point_arg
    : poly_code
    := pr1 Σ.

  Definition path_index
    : UU
    := pr12 Σ.

  Definition path_arg
    : path_index → poly_code
    := pr122 Σ.

  Definition path_lhs
    : ∏ (j : path_index), endpoint point_arg (path_arg j) I
    := pr1 (pr222 Σ).

  Definition path_rhs
    : ∏ (j : path_index), endpoint point_arg (path_arg j) I
    := pr2 (pr222 Σ).
End SignatureProjections.


Require Import Cdcl.Itauto.
Require Import List.

Goal forall (P P0 P1: Prop),
  (P1 -> P0) ->
  (P0 -> P1) ->
  ((P0 \/ P -> False) -> (P1 -> False) /\ (P -> False)) /\
  ((P1 -> False) /\ (P -> False) -> P0 \/ P -> False).
Proof.
  intros.
  itauto idtac.
Qed.

Goal forall P0 P1 (D:Prop),
    (((P0 \/ P1 -> False) -> (P1 -> False) /\ (P0 -> False)) -> D) ->
  D.
Proof.
  intros P0 P1 D.
  itauto idtac.
Qed.

Goal forall P0 P1 (D:Prop),
    (((P0 \/ P1 -> False) -> (P1 -> False) /\ (P0 -> False)) -> D) ->
  D.
Proof.
  intros P0 P1 D.
  itauto idtac.
Qed.


Set Implicit Arguments.
Require Import LibTactics.

(*****************************************************)
(** * Stream *)

(** Definition *)

CoInductive stream : Type :=
  | stream_cons : nat -> stream -> stream.

Notation "x ::: s" := (stream_cons x s) (at level 60).

(*****************************************************)
(** * Definition of concrete streams *)

(** Simple definition *)

CoFixpoint nat_stream_1 n :=
  n ::: (nat_stream_1 (S n)).

(** Definition with [let] *)

CoFixpoint nat_stream_2 n :=
  let s' := nat_stream_2 (S n) in
  n ::: s'.

(** Definition with [bind] *)

Definition bind (P Q:Type) (x:P) (f:P->Q) : Q := f x.

CoFixpoint nat_stream_3 n :=
  bind (nat_stream_3 (S n)) (fun s' => n ::: s').

(** Definition with [bind'] *)

Definition bind' (P Q:Type) (x:P) (f:P->Q) : Q.
Proof. exact (f x). Defined.

CoFixpoint nat_stream_4 n :=
  bind' (nat_stream_4 (S n)) (fun s' => n ::: s').

(** Definition with [bind''] *)

Definition bind'' (P Q:Type) (x:P) (f:P->Q) : Q.
Proof. exact (f x). Qed.

(*
CoFixpoint nat_stream_5 n :=
  bind'' (nat_stream_5 (S n)) (fun s' => n ::: s').

  Error:
  Sub-expression "bind'' (nat_stream_5 (S n)) (fun s' : stream => n ::: s')"
  not in guarded form
*)

(*****************************************************)
(** * Bisimilarity *)

(** Definition of bisimiarity *)

CoInductive bisim : stream -> stream -> Prop :=
  | bisim_cons : forall x s s',
     bisim s s' -> bisim (x:::s) (x:::s').

(** Proof of reflexivity via tactic *)

Lemma bisim_refl_0 : forall s, bisim s s.
Proof.
  cofix IH. intros [x s']. constructor. apply IH.
Qed.

(* Print bisim_refl_0. *)

Lemma bisim_refl_0a : forall s, bisim s s.
Proof.
  cofix IH. intros [x s']. apply IH.
  (* Guarded.
     Unguarded recursive call in "IH (x ::: s')". *)
Admitted.

(** Associated proof term *)

CoFixpoint bisim_refl_1 s : bisim s s :=
  match s with x ::: s' =>
    bisim_cons x (bisim_refl_1 s')
  end.

(** Another proof term with [let] *)

CoFixpoint bisim_refl_2 s : bisim s s :=
  match s with x ::: s' =>
    let H := bisim_refl_2 s' in
    bisim_cons x H
  end.

(** Another proof term with [let_lemma_prop] *)

Lemma let_lemma_prop : forall (P Q : Prop),
  P -> (P -> Q) -> Q.
Proof. auto. Defined.

CoFixpoint bisim_refl_3 s : bisim s s :=
  match s with x ::: s' =>
    let_lemma_prop (bisim_refl_3 s') (fun H => bisim_cons x H)
  end.

(** Another proof term with [let_lemma_prop'] *)

Lemma let_lemma_prop' : forall (P Q : Prop),
  P -> (P -> Q) -> Q.
Proof. auto. Qed.

(*
CoFixpoint bisim_refl_4 s : bisim s s :=
  match s with x ::: s' =>
    let_lemma_prop' (bisim_refl_4 s') (fun H => bisim_cons x H)
  end.

  Error:
  Sub-expression
    "let_lemma_prop (bisim_refl_4 s')
     (fun H : bisim s' s' => bisim_cons x H)"
  not in guarded form
*)

(** Proof of reflexivity via tactic, using rewrite *)

Lemma add_zero : forall n, 0 + n = n.
Proof. auto. Qed.

Lemma bisim_refl_5 : forall s, bisim s s.
Proof.
  cofix IH. intros [x s'].
  rewrite <- (add_zero x). rewrite (add_zero x).
  constructor. apply IH.
Qed.
(*Print bisim_refl_5.*)

Lemma bisim_refl_5a : forall s, bisim s s.
Proof.
  cofix IH. intros [x s']. constructor.
  sets_eq s'': s'. subst s''.
  apply IH.
Qed.
(*Print bisim_refl_5a.*)

(** Proof of reflexivity via tactic, using [eq_rect] *)

Definition eq_rect' : forall (A : Type) (x : A) (P : A -> Type),
       P x -> forall y : A, x = y -> P y.
Proof.
exact(
  fun (A : Type) (x : A) (P : A -> Type) (f : P x) (y : A) (e : x = y) =>
  match e in (_ = y0) return (P y0) with
  | eq_refl => f
  end).
Defined.

Arguments eq_rect' [A].

CoFixpoint bisim_refl_5' s : bisim s s :=
  match s as s0 return (bisim s0 s0) with
  | x ::: s' =>
      eq_rect' (0 + x) (fun x0 : nat => bisim (x0 ::: s') (x0 ::: s'))
        (eq_ind_r (fun n : nat => bisim (n ::: s') (n ::: s'))
           (bisim_cons x (bisim_refl_5' s')) (add_zero x)) x (add_zero x)
  end.

(** Proof of reflexivity via tactic, using [eq_rect''] *)

Definition eq_rect'' : forall (A : Type) (x : A) (P : A -> Type),
       P x -> forall y : A, x = y -> P y.
Proof.
exact(
  fun (A : Type) (x : A) (P : A -> Type) (f : P x) (y : A) (e : x = y) =>
  match e in (_ = y0) return (P y0) with
  | eq_refl => f
  end).
Qed.

Arguments eq_rect'' [A].

(* Not guarded
CoFixpoint bisim_refl_5'' s : bisim s s :=
  match s as s0 return (bisim s0 s0) with
  | x ::: s' =>
      eq_rect'' (0 + x) (fun x0 : nat => bisim (x0 ::: s') (x0 ::: s'))
        (eq_ind_r (fun n : nat => bisim (n ::: s') (n ::: s'))
           (bisim_cons x (bisim_refl_5'' s')) (add_zero x)) x (add_zero x)
  end.
*)

(*****************************************************)
(** * Debugging guardedness *)

Lemma bisim_refl_6 : forall s, bisim s s.
Proof.
  cofix IH. intros [x s'].
  apply (@let_lemma_prop' (bisim s' s')).
    apply IH.
    (* Guarded. *)
(* Sub-expression "let_lemma_prop' (IH s') (?1 IH x s')" not in guarded form *)
Admitted.

Lemma bisim_refl_7 : forall s, bisim s s.
Proof.
  cofix IH. intros [x s'].
  apply (@let_lemma_prop' True).
    auto. intros.
  (* Guarded. *)
  constructor.
  (* Guarded. *)
  apply IH.
  (* Guarded.
    Sub-expression "let_lemma_prop' I (fun _ : True => bisim_cons x (IH s'))" not
    in guarded form
  *)
Admitted.

Lemma bisim_refl_8 : forall s, bisim s s.
Proof.
  cofix IH. intros [x s']. constructor.
  apply (@let_lemma_prop' True).
    auto. intros.
    (* Guarded. *)
   (* Guarded. *)
   apply IH.
  (* Guarded.
    Sub-expression "let_lemma_prop' I (fun _ : True => bisim_cons x (IH s'))" not
    in guarded form
  *)
Admitted.

Lemma bisim_refl_8b : forall s, bisim s s.
Proof.
  cofix IH. intros [x s']. constructor.
  forwards: True. apply IH.
Qed.

Lemma bisim_refl_8c : forall s, bisim s s.
Proof.
  cofix IH. intros [x s']. constructor.
  specializes IH s'. apply IH.
  (* or one of:
  lets H: (IH s'). apply H.
  forwards H: (IH s'). apply H.
  forwards H: (IH s'). apply IH.
  *)
Qed.

Lemma refl_reproduce_1 : (forall s, bisim s s) -> (forall s, bisim s s).
Proof.
  intros IH. apply IH.
Defined.

Lemma bisim_refl_9 : forall s, bisim s s.
Proof.
  cofix IH. intros [x s'].
  apply refl_reproduce_1. apply IH.
  (*
  Unguarded recursive call in
  "refl_reproduce IH (x ::: s')".
  Recursive definition is:
  "fun s : stream =>
   match s as s0 return (bisim s0 s0) with
   | x ::: s' => refl_reproduce IH (x ::: s')
   end".
*)
Admitted.

Lemma bisim_refl_9a : forall s, bisim s s.
Proof.
  cofix IH. intros [x s']. constructor.
  apply refl_reproduce_1. apply IH.
Qed.

Lemma refl_reproduce_2 : (forall s, bisim s s) -> (forall s, bisim s s).
Proof.
  intros IH. intros [x s']. constructor. apply IH.
Defined.

Lemma bisim_refl_10 : forall s, bisim s s.
Proof.
  cofix IH. intros s. apply refl_reproduce_2. apply IH.
Qed.

Lemma refl_reproduce_3 : (forall s, bisim s s) -> (forall s, bisim s s).
Proof.
  skip.
Defined.

Lemma bisim_refl_10a : forall s, bisim s s.
Proof.
  cofix IH. intros s. apply refl_reproduce_3. apply IH.
(*
  Guarded.
Recursive call in a branch of
"match
   skip_axiom
   return ((forall s : stream, bisim s s) -> forall s : stream, bisim s s)
 with
 end".

Recursive definition is:
  "fun s : stream => refl_reproduce_3 IH s".

*)
Admitted.

Lemma bisim_refl_10b : forall s, bisim s s.
Proof.
  cofix IH. intros s. apply refl_reproduce_3. skip.
Qed.

Lemma refl_reproduce_4 : (forall s, bisim s s).
Proof.
  skip.
Defined.

Lemma bisim_refl_10c : forall s, bisim s s.
Proof.
  cofix IH. intros s. apply refl_reproduce_4.
  (* or: cofix IH. intros [x s']. constructor. apply refl_reproduce_4.*)
Qed.

Lemma bisim_refl_11 : forall s, bisim s s.
Proof.
  cofix IH. intros [x s'].
  assert (x = x). apply eq_refl.
  constructor. apply IH.
Qed.

Lemma bisim_refl_11a : forall s, bisim s s.
Proof.
  cofix IH. intros [x s'].
  assert (x = x). abstract apply eq_refl.
  constructor. apply IH.
Qed.

Lemma bisim_refl_11b : forall s, bisim s s.
Proof.
  cofix IH. intros [x s'].
  assert (x = 0 + x). apply eq_refl.
  rewrite H.
  constructor. apply IH.
Qed.

Lemma bisim_refl_11c : forall s, bisim s s.
Proof.
  cofix IH. intros [x s'].
  assert (x = 0 + x). skip.
  rewrite H.
  constructor. apply IH.
Qed.

Lemma bisim_refl_11d : forall s, bisim s s.
Proof.
  cofix IH. intros [x s'].
  assert (x = 0 + x). abstract apply eq_refl.
  rewrite H.
  constructor. apply IH.
(* Guarded.

Recursive call in the argument of cases in
"match
   match bisim_refl_11b_subproof IH x s' in (_ = y) return (y = x) with
   | eq_refl => eq_refl
   end in (_ = y)
   return
     ((fun y0 : nat => (fun x : nat => bisim (x ::: s') (x ::: s')) y0) y)
 with
 | eq_refl => bisim_cons (0 + x) (IH s')
 end".

Recursive definition is:
"fun s : stream =>
 match s as s0 return (bisim s0 s0) with
 | x ::: s' =>
     let H := bisim_refl_11b_subproof IH x s' in
     eq_ind_r (fun x0 : nat => bisim (x0 ::: s') (x0 ::: s'))
       (bisim_cons (0 + x) (IH s')) H
 end".

*)
Admitted.

(*

*)


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                             terminaison_SL.v                             *)
(****************************************************************************)

(*****************************************************************************)
(*          Projet Coq  - Calculus of Inductive Constructions V5.8           *)
(*****************************************************************************)
(*                                                                           *)
(*      Meta-theory of the explicit substitution calculus lambda-env         *)
(*      Amokrane Saibi                                                       *)
(*                                                                           *)
(*      September 1993                                                       *)
(*                                                                           *)
(*****************************************************************************)

              (* Preuve de terminaison *)

Require Import Le.
Require Import Lt.
Require Import Plus.
Require Import Gt.
Require Import Minus.
Require Import Mult.
Require Import sur_les_relations.
Require Import TS.
Require Import sigma_lift.
Require Import comparith.
Require Import Pol1.
Require Import Pol2.

Section ordre.

Variable A : Set.
Variable f g : A -> nat.

Definition e_lexfg (a b : A) := f a > f b \/ f a = f b /\ g a > g b.

Lemma lexfg_notherian : explicit_noetherian _ e_lexfg.
Proof.
unfold explicit_noetherian in |- *; unfold universal in |- *;
 unfold hereditary in |- *; unfold adjoint in |- *;
 unfold sub in |- *; unfold a_set in |- *.
intros P H.
cut (forall (n m : nat) (a : A), n > f a \/ n = f a /\ m > g a -> P a).
intros H0 x; apply (H0 (S (f x)) 0).
auto with arith.
simple induction n; simple induction m.
(* m=n=0 *)
simple induction 1; intro H1.
absurd (0 > f a); auto with arith.
elim H1; intros.
absurd (0 > g a); auto with arith.
(* n=0, m=(S y) *)
intros y H' a H0.
apply H; intros b lexfgab.
apply H'; right.
elim H0; intro H1.
absurd (0 > f a); auto with arith.
elim H1; intros H2 H3; elim lexfgab; intro H4.
absurd (0 > f b).
auto with arith.
rewrite H2; assumption.
elim H4; intros.
split.
rewrite H2; assumption.
apply le_gt_trans with (g a); auto with arith.
(* n=(S y), m=0 *)
intros a H0'; apply H; intros b lexfgab.
apply (H0 (g a) b); elim H0'; intro H1.
elim lexfgab; intro H2.
left; apply le_gt_trans with (f a); auto with arith.
elim H2; intros H3 H4; elim (gt_S n0 (f a) H1); intro H5.
left; elim H3; assumption.
right; split.
elim H3; auto with arith.
assumption.
elim H1; intros H2 H3.
absurd (0 > g a); auto with arith.
(* n=(S y), m=(S y0) *)
intros y0 H0' a H1; apply H; intros b lexfgab.
apply H0'; elim H1; elim lexfgab; intros H2 H3.
left; apply le_gt_trans with (f a); auto with arith.
elim H2; intros H4 H5; left; elim H4; assumption.
elim H3; intros H4 H5; left; rewrite H4; assumption.
elim H2; intros H4 H5; elim H3; intros H6 H7.
right; split.
apply trans_equal with (f a); assumption.
apply le_gt_trans with (g a); auto with arith.
Qed.

End ordre.

Notation lexfg := (e_lexfg _) (only parsing).
(* <Warning> : Syntax is discontinued *)

Theorem lexfg_systemSL :
 forall (b : wsort) (M N : TS b),
 e_systemSL _ M N -> e_lexfg _ (e_P1 b) (e_P2 b) M N.
Proof.
red in |- *; simple induction 1; auto with arith.
Qed.
Hint Resolve lexfg_systemSL.

Theorem lexfg_app_l :
 forall a a' b : terms,
 e_lexfg _ (e_P1 wt) (e_P2 wt) a a' ->
 e_lexfg _ (e_P1 wt) (e_P2 wt) (app a b) (app a' b).
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; auto with arith.
intros; elim H0; auto with arith.
Qed.
Hint Resolve lexfg_app_l.

Theorem lexfg_app_r :
 forall a b b' : terms,
 e_lexfg _ (e_P1 wt) (e_P2 wt) b b' ->
 e_lexfg _ (e_P1 wt) (e_P2 wt) (app a b) (app a b').
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; auto with arith.
intros; elim H0; auto with arith.
Qed.
Hint Resolve lexfg_app_r.

Theorem lexfg_lambda :
 forall a a' : terms,
 e_lexfg _ (e_P1 wt) (e_P2 wt) a a' ->
 e_lexfg _ (e_P1 wt) (e_P2 wt) (lambda a) (lambda a').
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; auto with arith.
intros; elim H0; auto with arith.
Qed.
Hint Resolve lexfg_lambda.

Theorem lexfg_env_t :
 forall (a a' : terms) (s : sub_explicits),
 e_lexfg _ (e_P1 wt) (e_P2 wt) a a' ->
 e_lexfg _ (e_P1 wt) (e_P2 wt) (env a s) (env a' s).
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; auto with arith.
intros; elim H0; auto with arith.
Qed.
Hint Resolve lexfg_env_t.

Theorem lexfg_env_s :
 forall (a : terms) (s s' : sub_explicits),
 e_lexfg _ (e_P1 ws) (e_P2 ws) s s' ->
 e_lexfg _ (e_P1 wt) (e_P2 wt) (env a s) (env a s').
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; auto with arith.
intros; elim H0; auto with arith.
Qed.
Hint Resolve lexfg_env_s.

Theorem lexfg_cons_t :
 forall (a a' : terms) (s : sub_explicits),
 e_lexfg _ (e_P1 wt) (e_P2 wt) a a' ->
 e_lexfg _ (e_P1 ws) (e_P2 ws) (cons a s) (cons a' s).
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; auto with arith.
intros; elim H0; auto with arith.
Qed.
Hint Resolve lexfg_cons_t.

Theorem lexfg_cons_s :
 forall (a : terms) (s s' : sub_explicits),
 e_lexfg _ (e_P1 ws) (e_P2 ws) s s' ->
 e_lexfg _ (e_P1 ws) (e_P2 ws) (cons a s) (cons a s').
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; auto with arith.
intros; elim H0; auto with arith.
Qed.
Hint Resolve lexfg_cons_s.

Theorem lexfg_comp_l :
 forall s s' t : sub_explicits,
 e_lexfg _ (e_P1 ws) (e_P2 ws) s s' ->
 e_lexfg _ (e_P1 ws) (e_P2 ws) (comp s t) (comp s' t).
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; auto with arith.
intros; elim H0; auto with arith.
Qed.
Hint Resolve lexfg_comp_l.

Theorem lexfg_comp_r :
 forall s t t' : sub_explicits,
 e_lexfg _ (e_P1 ws) (e_P2 ws) t t' ->
 e_lexfg _ (e_P1 ws) (e_P2 ws) (comp s t) (comp s t').
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; auto with arith.
intros; elim H0; auto with arith.
Qed.
Hint Resolve lexfg_comp_r.

Theorem lexfg_lift :
 forall s s' : sub_explicits,
 e_lexfg _ (e_P1 ws) (e_P2 ws) s s' ->
 e_lexfg _ (e_P1 ws) (e_P2 ws) (lift s) (lift s').
Proof.
unfold e_lexfg in |- *; simple induction 1; simpl in |- *; intros.
auto with arith.
elim H0; intros; right; split.
assumption.
change (4 * e_P2 _ s > 4 * e_P2 _ s') in |- *.
auto with arith.
Qed.
Hint Resolve lexfg_lift.

Theorem lexfg_relSL :
 forall (b : wsort) (M N : TS b),
 e_relSL _ M N -> e_lexfg _ (e_P1 b) (e_P2 b) M N.
Proof.
simple induction 1; auto with arith.
Qed.

(***************************************************)
(*   la relation sigma-lift (SL) est noetherienne  *)
(***************************************************)

Theorem relSL_noetherian :
 forall b : wsort, explicit_noetherian _ (e_relSL b).
Proof.
intro b; apply noether_inclus with (e_lexfg _ (e_P1 b) (e_P2 b)).
apply lexfg_notherian.
exact (lexfg_relSL b).
Qed.


Require Import Coq.ZArith.BinIntDef Coq.ZArith.BinInt coqutil.Z.Lia.
Require Import coqutil.Tactics.destr.
Require Import coqutil.sanity coqutil.Word.Interface. Import word.
Local Open Scope Z_scope.

(* TODO: move me? *)
Definition minimize_eq_proof{A: Type}(eq_dec: forall (x y: A), {x = y} + {x <> y}){x y: A}    (pf: x = y): x = y :=
  match eq_dec x y with
  | left p => p
  | right n => match n pf: False with end
  end.

Section WithWidth. Local Set Default Proof Using "All".
  Context {width : Z}.
  Let wrap_value z := z mod (2^width).
  Let swrap_value z := wrap_value (z + 2 ^ (width - 1)) - 2 ^ (width - 1).
  Record rep := mk { unsigned : Z ; _unsigned_in_range : wrap_value unsigned = unsigned }.

  Definition wrap (z:Z) : rep :=
    mk (wrap_value z) (minimize_eq_proof Z.eq_dec (Zdiv.Zmod_mod z _)).
  Definition signed w := swrap_value (unsigned w).

  Record special_cases := {
    div_by_zero: Z -> Z;
    mod_by_zero: Z -> Z;
    adjust_too_big_shift_amount: Z -> Z;
  }.

  Context {sp: special_cases}.

  Let adjust_shift_amount n :=
    if Z.ltb n width then n else sp.(adjust_too_big_shift_amount) n.

  Unset Universe Minimization ToSet.
  (* without the above option, defining "word" as below and then running

     Set Printing Universes.
     Set Printing Coercions.
     Set Printing All.
     About word.

     prints "word@{} : word.word@{Set} width" which shows that the universe param of
     word.word has been instantiated to Set, which will lead to universe inconsistencies
     later.
     If the above option is turned on, it prints "word@{Top.72} : word.word@{Top.72} width",
     and no universe inconsistencies occur, hopefully. *)
  Definition gen_word : word.word width := {|
    word.rep := rep;
    word.unsigned := unsigned;
    word.signed := signed;
    of_Z := wrap;

    add x y := wrap (Z.add (unsigned x) (unsigned y));
    sub x y := wrap (Z.sub (unsigned x) (unsigned y));
    opp x := wrap (Z.opp (unsigned x));

    or x y := wrap (Z.lor (unsigned x) (unsigned y));
    and x y := wrap (Z.land (unsigned x) (unsigned y));
    xor x y := wrap (Z.lxor (unsigned x) (unsigned y));
    not x := wrap (Z.lnot (unsigned x));
    ndn x y := wrap (Z.ldiff (unsigned x) (unsigned y));

    mul x y := wrap (Z.mul (unsigned x) (unsigned y));
    mulhss x y := wrap (Z.mul (signed x) (signed y) / 2^width);
    mulhsu x y := wrap (Z.mul (signed x) (unsigned y) / 2^width);
    mulhuu x y := wrap (Z.mul (unsigned x) (unsigned y) / 2^width);

    divu x y := wrap (if Z.eqb (unsigned y) 0 then sp.(div_by_zero) (unsigned x)
                      else Z.div (unsigned x) (unsigned y));
    divs x y := wrap (if Z.eqb (signed y) 0 then sp.(div_by_zero) (signed x)
                      else Z.quot (signed x) (signed y));
    modu x y := wrap (if Z.eqb (unsigned y) 0 then sp.(mod_by_zero) (unsigned x)
                      else Z.modulo (unsigned x) (unsigned y));
    mods x y := wrap (if Z.eqb (signed y) 0 then sp.(mod_by_zero) (signed x)
                      else Z.rem (signed x) (signed y));

    slu x y := wrap (Z.shiftl (unsigned x) (adjust_shift_amount (unsigned y)));
    sru x y := wrap (Z.shiftr (unsigned x) (adjust_shift_amount (unsigned y)));
    srs x y := wrap (Z.shiftr (signed x) (adjust_shift_amount (unsigned y)));

    eqb x y := Z.eqb (unsigned x) (unsigned y);
    ltu x y := Z.ltb (unsigned x) (unsigned y);
    lts x y := Z.ltb (signed x) (signed y);

    sextend oldwidth z := wrap ((unsigned z + 2^(oldwidth-1)) mod 2^oldwidth - 2^(oldwidth-1));
  |}.

  Lemma eq_unsigned {x y : rep} : unsigned x = unsigned y -> x = y.
  Proof.
    cbv [value]; destruct x as [x px], y as [y py]; cbn.
    intro; subst y.
    apply f_equal, Eqdep_dec.UIP_dec. eapply Z.eq_dec.
  Qed.

  Lemma of_Z_unsigned x : wrap (unsigned x) = x.
  Proof. eapply eq_unsigned; destruct x; cbn; assumption.  Qed.

  Lemma signed_of_Z z : signed (wrap z) = wrap_value (z + 2 ^ (width - 1)) - 2 ^ (width - 1).
  Proof.
    cbv [unsigned signed wrap wrap_value swrap_value].
    rewrite Zdiv.Zplus_mod_idemp_l; auto.
  Qed.

  Context (width_nonneg : Z.lt 0 width).

  Global Instance gen_ok : word.ok gen_word.
  Proof.
    split; intros;
      repeat match goal with
             | a: @word.rep _ _ |- _ => destruct a
             end;
      cbn in *;
      unfold adjust_shift_amount in *;
      repeat match goal with
             | |- context[if ?b then _ else _] => destr b
             end;
      eauto using of_Z_unsigned, signed_of_Z;
      try (exfalso; blia).
    apply eq_unsigned; assumption.
  Qed.
End WithWidth.
Arguments gen_word : clear implicits.
Arguments gen_ok : clear implicits.

Definition default_special_case_handlers width := {|
  div_by_zero x := -1;
  mod_by_zero x := x;
  adjust_too_big_shift_amount n := n mod 2 ^ Z.log2 width;
|}.

Definition word width: word.word width :=
  gen_word width (default_special_case_handlers width).
Definition ok width: 0 < width -> word.ok (word width) :=
  gen_ok width (default_special_case_handlers width).

(* NOTE: this can be moved into a separate file to build Properties and the above in parallel *)
(** [Add Ring] for sizes used in instruction sets of common processors *)
Require coqutil.Word.Properties.
Notation word1 := (word 1%Z).
#[global] Instance word1_ok : word.ok word1 := ok 1 eq_refl.
Add Ring wring1 : (Properties.word.ring_theory (word := word1))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (Properties.word.ring_morph (word := word1)),
       constants [Properties.word_cst]).
Notation word8 := (word 8%Z).
#[global] Instance word8_ok : word.ok word8 := ok 8 eq_refl.
Add Ring wring8 : (Properties.word.ring_theory (word := word8))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (Properties.word.ring_morph (word := word8)),
       constants [Properties.word_cst]).
Notation word16 := (word 16%Z).
#[global] Instance word16_ok : word.ok word16 := ok 16 eq_refl.
Add Ring wring16 : (Properties.word.ring_theory (word := word16))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (Properties.word.ring_morph (word := word16)),
       constants [Properties.word_cst]).
Notation word32 := (word 32%Z).
#[global] Instance word32_ok : word.ok word32 := ok 32 eq_refl.
Add Ring wring32 : (Properties.word.ring_theory (word := word32))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (Properties.word.ring_morph (word := word32)),
       constants [Properties.word_cst]).
Notation word64 := (word 64%Z).
#[global] Instance word64_ok : word.ok word64 := ok 64 eq_refl.
Add Ring wring64 : (Properties.word.ring_theory (word := word64))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (Properties.word.ring_morph (word := word64)),
       constants [Properties.word_cst]).
Notation word128 := (word 128%Z).
#[global] Instance word128_ok : word.ok word128 := ok 128 eq_refl.
Add Ring wring128 : (Properties.word.ring_theory (word := word128))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (Properties.word.ring_morph (word := word128)),
       constants [Properties.word_cst]).
Notation word256 := (word 256%Z).
#[global] Instance word256_ok : word.ok word256 := ok 256 eq_refl.
Add Ring wring256 : (Properties.word.ring_theory (word := word256))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (Properties.word.ring_morph (word := word256)),
       constants [Properties.word_cst]).
Notation word512 := (word 512%Z).
#[global] Instance word512_ok : word.ok word512 := ok 512 eq_refl.
Add Ring wring512 : (Properties.word.ring_theory (word := word512))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (Properties.word.ring_morph (word := word512)),
       constants [Properties.word_cst]).


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import bedrock2.Array.
Require Import bedrock2.Scalars.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Bedrock.Field.Common.Arrays.MaxBounds.
Require Import Crypto.Bedrock.Field.Common.Arrays.ByteBounds.
Local Open Scope Z_scope.

Section Bignum.
  Context {p : Types.parameters}.

  Definition Bignum
             (n : nat) (px : Semantics.word) (x : list Semantics.word)
    : Semantics.mem -> Prop :=
    sep (emp (length x = n)) (array scalar (word.of_Z word_size_in_bytes) px x).

  Definition EncodedBignum
             (n_bytes : nat) (px : Semantics.word) (x : list Byte.byte)
    : Semantics.mem -> Prop :=
    sep (emp (length x = n_bytes)) (array ptsto (word.of_Z 1) px x).

  Section Proofs.
    Context {ok : Types.ok}.
    Existing Instance semantics_ok.

    (* TODO: factor this proof into a more general form that says if subarrays
    of your arrays form a different kind of element, then you have an array of
    the other type *)
    Lemma Bignum_of_bytes n :
      forall addr bs,
        length bs = (n * Z.to_nat word_size_in_bytes)%nat ->
        Lift1Prop.impl1
          (array ptsto (word.of_Z 1) addr bs)
          (Lift1Prop.ex1 (Bignum n addr)).
    Proof.
      cbv [Bignum].
      induction n; intros.
      { destruct bs; cbn [length] in *; try lia; [ ].
        repeat intro. exists nil.
        cbn [array length] in *. sepsimpl; eauto. }
      { rewrite <-(firstn_skipn (Z.to_nat word_size_in_bytes) bs).
        rewrite array_append.
        rewrite Scalars.scalar_of_bytes with (l:=List.firstn _ _);
          lazymatch goal with
          | [ |- _ <= Semantics.width ] => destruct Semantics.width_cases; lia
          | _ => idtac
          end.
        2:{
          rewrite word_size_in_bytes_eq in *.
          etransitivity;
            [ symmetry; apply bits_per_word_eq_width;
              solve [eauto using width_0mod_8] | ].
          rewrite firstn_length, Min.min_l by lia.
          lia. }
        intros ? Hsep. destruct Hsep as [? [? [? [Hsca Harr]]]].
        cbv [Lift1Prop.impl1] in *.
        pose proof word_size_in_bytes_pos.
        rewrite word.unsigned_of_Z_1, Z.mul_1_l in Harr.
        rewrite firstn_length, Min.min_l in Harr by nia.
        rewrite Z2Nat.id in Harr by lia.
        match type of Harr with
        | array _ _ _ (List.skipn ?sz ?xs) _ =>
          match goal with
          | H : length xs = (S ?n * sz)%nat |- _ =>
            assert (length (List.skipn sz xs) = (n * sz)%nat);
              [ rewrite skipn_length, H; nia | ]
          end
        end.
        specialize (IHn _ _ ltac:(eauto) _ Harr).
        destruct IHn; sepsimpl.
        match goal with
        | Htl : array scalar _ _ ?t _,
                Hhd : scalar _ ?h _ |- _ =>
          exists (h :: t)
        end.
        cbn [length array].
        sepsimpl; eauto; [ ].
        do 2 eexists.
        eauto. }
    Qed.

    Lemma Bignum_to_bytes n :
      forall addr x,
        Lift1Prop.impl1
          (Bignum n addr x)
          (Lift1Prop.ex1
             (fun bs =>
                sep (emp (length bs = (n * Z.to_nat word_size_in_bytes)%nat))
                    (array ptsto (word.of_Z 1) addr bs))).
    Proof.
      cbv [Bignum].
      induction n; repeat intro; sepsimpl; destruct x;
        cbn [length array] in *; try lia;
        [ exists nil; cbn in *; sepsimpl; solve [eauto] | ].
      match goal with
      | H : sep _ _ _ |- _ =>
        seprewrite_in scalar_to_bytes H
      end.
      match goal with
      | H : sep _ _ _ |- _ =>
        cbv [sep] in H; cleanup
      end.
      match goal with
      | H : array scalar _ ?addr ?xs ?m |- _ =>
        specialize (IHn addr xs m);
          match type of IHn with ?P -> _ =>
                                 assert P by (sepsimpl; auto; lia) end;
          specialize (IHn ltac:(assumption))
      end.
      destruct IHn as [bs ?].
      sepsimpl.
      match goal with
      | Htl : array ptsto _ _ bs _,
              Hhd : array ptsto _ _ ?h _ |- _ =>
        exists (h ++ bs)
      end.
      sepsimpl; [ | ].
      { rewrite app_length.
        rewrite HList.tuple.length_to_list.
        rewrite word_size_in_bytes_eq in *.
        rewrite !Nat2Z.id in *. lia. }
      { apply array_append.
        pose proof word_size_in_bytes_pos.
        rewrite word.unsigned_of_Z_1, Z.mul_1_l.
        rewrite HList.tuple.length_to_list.
        rewrite <-word_size_in_bytes_eq.
        do 2 eexists. eauto. }
    Qed.
  End Proofs.
End Bignum.
Notation BignumSuchThat :=
  (fun n addr ws P =>
     let xs := map word.unsigned ws in
     sep (emp (P xs)) (Bignum n addr ws)).
Notation EncodedBignumSuchThat :=
  (fun n addr ws P =>
     let xs := map Byte.byte.unsigned ws in
     sep (emp (P xs)) (EncodedBignum n addr ws)).