Require Import List.
Require MSetProperties.
Require FMapFacts.
Require Import NArith.
Require Import ZArith.
Require Import QArith.
Require Import Qpower.
Require Import hddivsteps_base.
Require Import hddivsteps_def.
Require Import hddivsteps_convexhull.

Lemma Dred_eq : forall x, Deq (Dred x) x.
Proof.
intros x.
unfold Deq.
rewrite Dcompare_Q.
rewrite <- Qeq_alt.
destruct x as [[|m|m] e]; try reflexivity; simpl;
(revert e; induction m; try reflexivity;
 intros e; simpl;
 rewrite IHm;
 unfold inject_D; simpl;
 rewrite <- Z.add_1_l, Qpower_plus by discriminate; simpl;
 change 2 with (inject_Z 2);
 rewrite Qmult_assoc, <- inject_Z_mult, Z.mul_comm;
 reflexivity).
Qed.

Module DDSetProperties := MSetProperties.OrdProperties DDSet.

Lemma Qsum_map_partition : forall {A} f l (g : A -> Q),
 Qsum (map g l) == Qsum (map g (fst (partition f l))) + Qsum (map g (snd (partition f l))).
Proof.
intros A f l g.
induction l;[reflexivity|].
assert (Hl := surjective_pairing (partition f l)).
simpl (Qsum (map g (a :: l))).
rewrite IHl.
case (f a) eqn:H;
[rewrite (partition_cons1 f a l Hl H)
|rewrite (partition_cons2 f a l Hl H)
];simpl;ring.
Qed.

Lemma Qcombine_partition : forall f l,
 QQeq (Qcombine l) (QQplus (Qcombine (fst (partition f l))) (Qcombine (snd (partition f l)))).
Proof.
intros f l.
induction l;[split;reflexivity|].
assert (Hl := surjective_pairing (partition f l)).
simpl (Qcombine (a :: l)).
unfold QQeq.
destruct IHl as [-> ->].
cbn -[partition].
case (f a) eqn:H;
[rewrite (partition_cons1 f a l Hl H)
|rewrite (partition_cons2 f a l Hl H)
];simpl;split;ring.
Qed.

Lemma in_fst_partition : forall {A} f l (x : A),
  In x (fst (partition f l)) -> f x = true.
Proof.
intros A f l x.
induction l;[intros []|].
simpl.
destruct (partition f l) as [l1 l2].
case (f a) eqn:H;[intros [Hx|Hx]|]; auto.
congruence.
Qed.

Lemma in_snd_partition : forall {A} f l (x : A),
  In x (snd (partition f l)) -> f x = false.
Proof.
intros A f l x.
induction l;[intros []|].
simpl.
destruct (partition f l) as [l1 l2].
case (f a) eqn:H;[|intros [Hx|Hx]]; auto.
congruence.
Qed.

Lemma in_nonempty_convex_hull : forall a s (p : QQ),
  in_convex_hull p (DDSet.add a s) ->
  QQeq p (inject_DD a) \/ (exists c, exists q, 0 <= c <= 1 /\ in_convex_hull q s
                           /\ QQeq p (QQavg c (inject_DD a) q)).
Proof.
intros a s p [l [H0 [H1 H2]]].
pose (f := (fun p:Q * DD => if DDOrder.eq_dec (snd p) a then true else false)).
rewrite (Qsum_map_partition f) in H1.
assert (H2' : QQeq
        (QQplus (Qcombine (fst (partition f l)))
           (Qcombine (snd (partition f l)))) p)
 by (unfold QQeq;destruct (Qcombine_partition f l) as [<- <-]; auto).
set (l1 := fst (partition f l)) in *.
set (l2 := snd (partition f l)) in *.
set (c := Qsum (map fst l1)) in *.
set (d := Qsum (map fst l2)) in *.
assert (Hl := elements_in_partition f l (surjective_pairing (partition f l))).
assert (H0' : forall q, In q (map fst l2) -> 0 <= q).
 intros q.
 rewrite in_map_iff.
 intros [[x y] [Hx Hx0]].
 eapply or_intror in Hx0.
 apply Hl in Hx0.
 simpl in Hx.
 rewrite Hx in Hx0.
 specialize (H0 _ _ Hx0).
 tauto.
assert (Hl1 : QQeq (Qcombine l1) (QQscale c (inject_DD a))).
 unfold QQeq, QQscale.
 clear.
 assert (Hl1 := in_fst_partition f l).
 fold l1 in Hl1.
 induction l1 as [|[d p] l1 IHl1];[split;reflexivity|].
 unfold c.
 simpl.
 rewrite (Qplus_comm d), !Qmult_plus_distr_l.
 destruct (IHl1 (fun x H => Hl1 x (or_intror H))) as [-> ->].
 specialize (Hl1 _ (or_introl (refl_equal _))).
 unfold f in Hl1.
 destruct (DDOrder.eq_dec _) as [[He Hf]|];[|discriminate].
 apply Deq_Q in He.
 apply Deq_Q in Hf.
 rewrite He, Hf.
 split; reflexivity.

case (Qeq_dec d 0);intros Hd;[left|right].
* unfold QQeq.
  destruct H2' as [<- <-].
  simpl.
  rewrite Hd, Qplus_0_r in H1.
  assert (Hl1' : QQeq (Qcombine l1) (inject_DD a)).
   unfold QQeq.
   setoid_replace (fst (inject_DD a)) with (1 * fst (inject_DD a)) by ring.
   setoid_replace (snd (inject_DD a)) with (1 * snd (inject_DD a)) by ring.
   rewrite <- H1.
   apply Hl1.
  fold l1 l2 in Hl.
  assert (Hl2 : QQeq (Qcombine l2) (0,0)).
   clear -H0' Hd.
   induction l2;[split;reflexivity|].
   unfold QQeq.
   unfold d in Hd; simpl in *.
   assert (H1 : 0 <= fst a0) by firstorder.
   assert (H2 : 0 <= Qsum (map fst l2)) by firstorder using Qsum_pos.
   setoid_replace (fst a0) with 0;
    [rewrite !Qmult_0_l, !Qplus_0_r;
     apply IHl2; try firstorder|];
   apply Qle_antisym;try assumption;
   rewrite <- Hd;
   apply Qle_minus_iff;
   ring_simplify;
   assumption.
   unfold QQeq.
   destruct Hl1' as [-> ->].
   destruct Hl2 as [-> ->].
   simpl; split; ring.
* exists c.
  exists (QQscale (/d) (Qcombine l2)).
  assert (Hd0 : 0 <= d).
   apply Qsum_pos.
   intros z.
   rewrite in_map_iff.
   intros [[z1 z2] [<- Hz]].
   specialize (H0 z1 z2).
   rewrite (elements_in_partition f _ (surjective_pairing (partition f l))) in H0.
   tauto.
  split;[split|split].
+ apply Qsum_pos.
  intros z.
  rewrite in_map_iff.
  intros [[z1 z2] [<- Hz]].
  specialize (H0 z1 z2).
  rewrite (elements_in_partition f _ (surjective_pairing (partition f l))) in H0.
  tauto.
+ rewrite <- H1.
  setoid_replace c with (c + 0) at 1 by ring.
  apply Qplus_le_r.
  assumption.
+ pose (g := fun x => (/ d * fst x, snd x : DD)).
  exists (map g l2).
  apply Qle_lt_or_eq in Hd0.
  destruct Hd0 as [Hd0|Hd0];[|symmetry in Hd0;contradiction].
  split;[|split].
  - clear - H0 Hd0.
    intros q p.
    rewrite in_map_iff.
    intros [[x y] [Hxy Hqp]].
    injection Hxy; intros <- <-; clear Hxy.

    specialize (H0 x y).
    rewrite (elements_in_partition f _ (surjective_pairing (partition f l))) in H0.
    specialize (H0 (or_intror Hqp)).
    split;
     [rewrite Qmult_comm; apply Qle_shift_div_l; auto;
      ring_simplify; tauto|].
    destruct H0 as [_ H0].
    rewrite DDSet.add_spec in H0.
    destruct H0 as [H0|H0];[|assumption].
    apply in_snd_partition in Hqp.
    unfold f in Hqp.
    destruct (DDOrder.eq_dec _) as [Hy|Hy];[discriminate|].
    elim Hy.
    assumption.
  - clearbody l2; clear - Hd.
    rewrite map_map.
    pose (f := fun x => / d * x).
    change (fun x => _) with (fun x : Q * DD => f (fst x)).
    rewrite <- map_map.
    setoid_replace 1 with (d/d) by field;auto.
    unfold d at 1.
    clearbody d; clear - Hd.
    unfold f.
    rewrite Qsum_mult.
    rewrite Qmult_comm.
    reflexivity.
  - clearbody l2 d; clear.
    induction l2;[split;simpl;ring|].
    unfold QQeq; simpl.
    destruct IHl2 as [-> ->];simpl.
    unfold Qdiv.
    split; ring.
+ cut (QQeq (QQplus (Qcombine l1) (Qcombine l2))
       (QQavg c (inject_DD a) (QQscale (/ d) (Qcombine l2)))).
   destruct H2' as [H2'1 H2'2].
   symmetry in H2'1.
   symmetry in H2'2.
   intros [Ha Hb].
   split; eauto using Qeq_trans.
  unfold QQavg, QQeq.
  simpl.
  destruct Hl1 as [-> ->]; simpl.
  rewrite <- H1.
  split;field;auto.
Qed.

Lemma in_nested_convex_hull : forall s1 s2 (p : QQ),
  in_convex_hull p s1 ->
  (forall (q :DD) q', QQeq q q' -> DDSet.In q s1 -> in_convex_hull q' s2) ->
  in_convex_hull p s2.
Proof.
intros s1.
induction s1 as [H|s0 s1 IH a _ Hadd] using DDSetProperties.P.set_induction;
[intros;
 eelim in_convex_hull_Empty;
 eapply in_convex_hull_morph2;[|eassumption];
 firstorder using DDSet.empty_spec
|].
intros s2 p H1 H2.
apply DDSetProperties.P.Add_Equal in Hadd.
assert (Hp : in_convex_hull p (DDSet.add a s0)) by
 (eapply in_convex_hull_morph2;[apply Hadd|apply H1]).
apply in_nonempty_convex_hull in Hp.
destruct Hp as [Hp|[c [q [Hc [Hq Hp]]]]].
* apply H2 with a;
   [destruct Hp;split;symmetry;assumption|].
  rewrite Hadd.
  apply DDSet.add_spec; left; reflexivity.
* assert (H2' : forall (q : DD) (q' : QQ),
     QQeq q q' -> DDSet.In q s0 -> in_convex_hull q' s2).
   intros q0 q' Hq0 Hq0s.
   apply H2 with q0; auto.
   rewrite Hadd.
   apply DDSet.add_spec;right; assumption.
  specialize (IH s2 _ Hq H2').
  assert (Ha : in_convex_hull (inject_DD a) s2).
   apply H2 with a;[split;reflexivity|].
   rewrite Hadd.
   apply DDSet.add_spec; left; reflexivity.
  apply in_convex_hull_morph1 with (QQavg c (inject_DD a) q);
   [unfold QQeq in *; split; symmetry; tauto|].
  apply QQavg_in_convex_hull; auto.
Qed.

Lemma in_convex_hull_convexHull : forall s q p,
  in_convex_hull p (DDSet.add q s) ->
  in_convex_hull p (DDSet.add q (convexHull s)).
Proof.
intros s q p H.
apply in_nonempty_convex_hull in H.
destruct H as [H|[c [r [Hc [Hr Hp]]]]].
* apply QQeq_sym in H.
  eapply in_convex_hull_morph1;[apply H|].
  apply in_in_convex_hull;apply DDSet.add_spec;left;reflexivity.
* assert (H : in_convex_hull r (convexHull s)).
   apply in_nested_convex_hull with s;auto.
   intros t0 t1 Ht H.
   eapply in_convex_hull_morph1;[apply Ht|].
   auto using convexHull_sound.
  change DD in q.
  assert (Hp' : QQeq (QQavg c (q:QQ) r) p) by
   (destruct Hp;split;symmetry;assumption).
  eapply in_convex_hull_morph1;[apply Hp'|].
  apply QQavg_in_convex_hull;auto.
  + apply in_in_convex_hull;apply DDSet.add_spec;left;reflexivity.
  + apply in_convex_hull_subset with (convexHull s); auto.
    apply DDSetProperties.P.subset_add_2.
    apply DDSetProperties.P.subset_refl.
Qed.

Definition State_lookup (i : Z) (m : State) :=
  match (ZMap.find i m) with
  | None => DDSet.empty
  | Some s => s
  end.

Lemma State_lookup_join2 : forall p delta i q m,
DDSet.In p (State_lookup delta m) ->
DDSet.In p
  (State_lookup delta (State_join i q m)).
Proof.
intros p delta i q m.
unfold State_lookup.
case (ZMap.find _ _) as [t|] eqn:Hi;
[|intros H; apply DDSet.empty_spec in H; contradiction].
unfold State_join.
destruct (OrdersEx.Z_as_DT.eq_decidable i delta) as [->|Hdelta].
+ rewrite Hi,
          (ZMap.find_1 (ZMap.add_1 _ _ (refl_equal delta))),
          DDSet.union_spec.
  auto.
+ apply ZMap.find_2 in Hi.
  eapply (ZMap.add_2 _ Hdelta) in Hi.
  rewrite (ZMap.find_1 Hi).
  auto.
Qed.

Lemma State_lookup_fromList : forall l q p delta s,
 DDSet.In p (DDSet.add q s) ->
 In (delta, s) l ->
 DDSet.In p (DDSet.add q (State_lookup delta (State_fromList l))).
Proof.
intros l q p delta s Hps Hsl.
rewrite DDSet.add_spec in *.
destruct Hps as [Hps|Hps];[left;assumption|right].
unfold State_fromList.
rewrite <- fold_left_rev_right.
rewrite in_rev in Hsl.
induction (rev l);[contradiction|].
simpl.
destruct Hsl as [->|Hsl];[|auto using State_lookup_join2].
simpl.
unfold State_lookup, State_join.
rewrite (ZMap.find_1 (ZMap.add_1 _ _ (refl_equal delta))).
destruct (ZMap.find _ _);[rewrite DDSet.union_spec|];auto.
Qed.

Lemma State_in_convex_hull_fromList1 : forall l q p delta s,
 in_convex_hull p (DDSet.add q s) ->
 In (delta, s) l ->
 in_convex_hull p (DDSet.add q (State_lookup delta (State_fromList l))).
Proof.
intros l q p delta s [c [Hps1 [Hps2 [Hps3 Hps4]]]] Hsl.
exists c;split;[|repeat split;auto].
intros q' p' Hqp'.
destruct (Hps1 q' p' Hqp') as [Hps11 Hps12].
split; eauto using State_lookup_fromList.
Qed.

Definition Matrix : Set := D * D * D * D.
Definition even_matrix : Matrix :=
  (Dhalf 1, 0:D, 0:D, 1:D)%Z.
Definition odd_pos_matrix : Matrix :=
  (Dhalf 1, Dhalf (-1), 1:D, 0:D)%Z.
Definition odd_nonpos_matrix : Matrix :=
  (Dhalf 1, Dhalf 1, 0:D, 1:D)%Z.
Definition linearD_of (m : Matrix) (p : DD) : DD :=
  let '(a,b,c,d) := m in
  (Dadd (Dmult a (fst p)) (Dmult b (snd p))
  ,Dadd (Dmult c (fst p)) (Dmult d (snd p))).
Definition linearQ_of (m : Matrix) (p : QQ) : QQ :=
  let '(a,b,c,d) := m in
  (a * (fst p) + b * (snd p), c * (fst p) + d * (snd p)).

Lemma even_trans_matrix : forall p,
  DDeq (even_trans p) (linearD_of even_matrix p).
Proof.
intros [x y].
unfold DDeq; simpl.
rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, !Dhalf_Q.
change (inject_D 1%Z:Q) with 1.
change (inject_D 0%Z:Q) with 0.
split;field.
Qed.

Lemma odd_pos_trans_matrix : forall p,
  DDeq (odd_pos_trans p) (linearD_of odd_pos_matrix p).
Proof.
intros [x y].
unfold DDeq, odd_pos_trans.
rewrite Dred_eq; simpl.
rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, !Dhalf_Q, Dsub_Q.
change (inject_D (-1)%Z:Q) with (-1).
change (inject_D 1%Z:Q) with 1.
change (inject_D 0%Z:Q) with 0.
split;field.
Qed.

Lemma odd_nonpos_trans_matrix : forall p,
  DDeq (odd_nonpos_trans p) (linearD_of odd_nonpos_matrix p).
Proof.
intros [x y].
unfold DDeq, odd_nonpos_trans.
rewrite Dred_eq; simpl.
rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, !Dhalf_Q, Dadd_Q.
change (inject_D 1%Z:Q) with 1.
change (inject_D 0%Z:Q) with 0.
split;field.
Qed.

Lemma linearD_of_morph : forall m q1 q2,
  DDeq q1 q2 -> DDeq (linearD_of m q1) (linearD_of m q2).
Proof.
intros [[[a b] c] d] [x1 y1] [x2 y2] [Hx Hy].
unfold DDeq.
simpl in *.
rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, Hx, Hy in *.
split;reflexivity.
Qed.

Lemma in_DDSet_map : forall trans p s,
 (forall q1 q2, DDeq q1 q2 -> DDeq (trans q1) (trans q2)) ->
 DDSet.In p s ->
 DDSet.In (trans p) (DDSet_map trans s).
Proof.
intros trans [x y] s trans_morph Hps.
unfold DDSet_map.
rewrite DDSet.fold_spec, <- fold_left_rev_right.
rewrite <- DDSet.elements_spec1, <- SetoidList.InA_rev in Hps.
fold DDSet.elt in Hps.
induction (rev (DDSet.elements s));
 [rewrite SetoidList.InA_nil in Hps;elim Hps|simpl].
rewrite DDSet.add_spec.
rewrite SetoidList.InA_cons in Hps.
destruct Hps as [Hps|Hps];[|right;auto].
left.
apply trans_morph.
assumption.
Qed.

Lemma in_convex_hull_map_ext : forall trans m p q s,
 (forall p, DDeq (trans p) (linearD_of m p)) ->
 QQeq (linearQ_of m p) q ->
 in_convex_hull p (DDSet.add (0:D,0:D)%Z s) ->
 in_convex_hull q (DDSet.add (0:D,0:D)%Z (DDSet_map trans s)).
Proof.
intros trans m p p' s trans_ext Hp [l [Hl1 [Hl2 [Hl3 Hl4]]]].
assert (trans_morph : forall q1 q2, DDeq q1 q2 -> DDeq (trans q1) (trans q2)).
 intros q1 q2 Hq.
 destruct (trans_ext q1) as [trans_ext11 trans_ext12].
 destruct (trans_ext q2) as [trans_ext21 trans_ext22].
 unfold DDeq.
 rewrite !Deq_Q in *.
 rewrite trans_ext11, trans_ext21, trans_ext12, trans_ext22.
 rewrite <-!Deq_Q.
 apply (linearD_of_morph m _ _ Hq).
exists (map (fun cp => (fst cp, linearD_of m (snd cp))) l);split;[|split].
* intros q [f g] H.
  apply in_map_iff in H.
  destruct H as [[x y] [Hx1 Hx2]].
  simpl in Hx1.
  injection Hx1; intros <- <-.
  destruct (Hl1 _ _ Hx2).
  specialize (trans_ext y).
  change (DDOrder.eq (trans y) (linearD_of m y)) in trans_ext.
  rewrite <- trans_ext.
  split;auto.
  rewrite DDSet.add_spec in *.
  destruct H0 as [[H0l H0r]|H0];[left|right;auto using in_DDSet_map].
  destruct y as [yl yr].
  apply Deq_Q in H0l; apply Deq_Q in H0r.
  simpl in *.
  rewrite trans_ext.
  set (trans' := linearD_of m).
  change (Deq (fst (trans' (yl, yr))) 0%Z /\ Deq (snd (trans' (yl, yr))) 0%Z).
  destruct m as [[[ma mb] mc] md].
  simpl.
  rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, H0l, H0r.
  change (0%Z:Q) with 0.
  split; ring.
* rewrite <- Hl2.
  clear - l.
  induction l;[reflexivity|].
  simpl.
  rewrite IHl.
  reflexivity.
* clear - Hl3 Hl4 Hp.
  destruct p as [x y].
  destruct Hp as [Hp1 Hp2].
  destruct m as [[[a b] c] d].
  unfold QQeq.
  simpl in *.
  rewrite <- Hp1, <- Hp2, <- Hl3, <- Hl4; clear Hp1 Hp2 Hl3 Hl4.
  induction l;simpl;[split; ring|].
  destruct IHl as [-> ->].
  rewrite !Dadd_Q, !Dmult_Q.
  split; ring.
Qed.

Lemma inject_Z_half : forall a : Z, Z.Even a -> inject_Z (a / 2)%Z == inject_Z a / 2.
Proof.
intros a Ha.
rewrite <- Zeven_equiv in Ha.
rewrite (Zeven_div2 _ Ha) at 2.
rewrite inject_Z_mult.
change (inject_Z 2) with 2.
rewrite <- Qmult_comm, Qdiv_mult_l, Z.div2_div by discriminate.
reflexivity.
Qed.

Lemma inject_Z_D_Q : forall a : Z, (a:D) == inject_Z a.
intros a.
unfold inject_D.
simpl.
ring.
Qed.

Lemma Zodd_opp : forall a : Z, Zodd a -> Zodd (-a).
Proof.
intros.
rewrite Zodd_ex_iff in *.
destruct H as [m ->].
exists (-m-1)%Z.
ring.
Qed.

Lemma in_narrow : forall (M g f : Z) s,
 (0 < M)%Z ->
 narrow M s = true ->
 in_convex_hull (g / M, f / M) (DDSet.add (0:D,0:D)%Z s) ->
 g = 0%Z.
Proof.
intros M g f s HM Hs Hg.
rewrite Zlt_Qlt, <- !inject_Z_D_Q in HM.
change (0%Z:Q) with 0 in HM.
cut (-1 < M * (g / M) /\ M * (g / M) < 1).
  rewrite Qmult_div_r by auto with *.
  change (-1) with ((-1)%Z:Q).
  change 1 with (1%Z:Q).
  rewrite !inject_Z_D_Q, <- !Zlt_Qlt.
  auto with *.
set (zero := (0:D,0:D)%Z).
assert (Hnarrow : forall x y, DDSet.In (x, y) (DDSet.add zero s) -> -1 < M*x /\ M*x < 1).
 apply Qlt_le_weak in HM.
 intros x y Hxy.
 apply DDSet.add_spec in Hxy.
 destruct Hxy as [[Hxyl Hxyr]|Hxy].
  apply Deq_Q in Hxyl, Hxyr; simpl in *.
  rewrite Hxyl.
  change (0%Z:Q) with 0.
  rewrite Qmult_0_r, !Qlt_alt.
  split;reflexivity.
 unfold narrow in Hs.
 case (DDSet.min_elt s) as [[l l0]|] eqn:Hmin;
  [|apply DDSet.min_elt_spec3 in Hmin;elim (Hmin _ Hxy)].
 case (DDSet.max_elt s) as [[h h0]|] eqn:Hmax;
  [|apply DDSet.max_elt_spec3 in Hmax;elim (Hmax _ Hxy)].
 apply (fun H => DDSet.min_elt_spec2 H Hxy) in Hmin.
 apply (fun H => DDSet.max_elt_spec2 H Hxy) in Hmax.
 apply andb_prop in Hs.
 destruct Hs as [Hs1 Hs2].
 change (~(Dcompare x l = Lt \/ (Dcompare x l = Eq /\ Dcompare y l0 = Lt))) in Hmin.
 change (~(Dcompare h x = Lt \/ (Dcompare h x = Eq /\ Dcompare h0 y = Lt))) in Hmax.
 apply Dltb_Q in Hs1.
 apply Dltb_Q in Hs2.
 change ((-1)%Z:Q) with (-1) in Hs1.
 change ((1)%Z:Q) with 1 in Hs2.
 rewrite Dmult_Q, !Dcompare_Q, <- Qeq_alt, <- !Qlt_alt in *.
 assert (Hmin' : l <= x) by (apply Qnot_lt_le; tauto).
 assert (Hmax' : x <= h) by (apply Qnot_lt_le; tauto).
 apply (fun H => Qmult_le_compat_r _ _ _ H HM) in Hmin'.
 apply (fun H => Qmult_le_compat_r _ _ _ H HM) in Hmax'.
 rewrite (Qmult_comm M) in *.
 split; eauto using Qle_lt_trans, Qlt_le_trans.
clear Hs.
destruct Hg as [l [Hl1 [Hl2 [Hl3 _]]]].
simpl in Hl3.
rewrite <- Hl3.
pose (l' := filter (fun x => negb (Qle_bool (fst x) 0)) l).
assert (Hl1' : forall (q : Q) (p : DD), In (q, p) l' -> 0 < q /\ q <= 1 /\ DDSet.In p (DDSet.add zero s)).
 intros q p Hqp.
 unfold l' in Hqp.
 rewrite filter_In in Hqp.
 destruct Hqp as [Hqp Hfilter].
 destruct (Hl1 _ _ Hqp).
 repeat split; try tauto;
 [apply in_split in Hqp;
  case (Qlt_le_dec 0 q); auto;
  intros H1;
  rewrite <- Qle_bool_iff in H1;
  simpl in Hfilter;
  rewrite H1 in Hfilter;
  discriminate
 |].
 rewrite <- Hl2.
 clear -Hl1 Hqp.
 apply in_split in Hqp.
 destruct Hqp as [l1 [l2 ->]].
 rewrite map_app, Qsum_app; simpl.
 setoid_replace q with (0 + (q + 0)) at 1 by ring.
 repeat apply Qplus_le_compat; auto with *;
 apply Qsum_pos;
 intros x Hx;
 rewrite in_map_iff in Hx;
 destruct Hx as [[y1 y2] [<- Hy]];
 specialize (Hl1 y1 y2);
 assert (H := in_or_app l1 ((q,p)::l2) (y1, y2));
 simpl in H;
 tauto.
assert (Hl2' : Qsum (map fst l') == 1 /\ fst (Qcombine l') == fst (Qcombine l)).
 rewrite <- Hl2.
 clear -Hl1.
 induction l;[split;reflexivity|].
 unfold l'; simpl.
 destruct IHl as [<- <-];[firstorder|].
 specialize (Hl1 (fst a) (snd a)).
 rewrite <-surjective_pairing in Hl1.
 specialize (Hl1 (or_introl (refl_equal _))).
 destruct Hl1 as [Hl1 _].
 case (Qle_bool (fst a) 0) eqn:Ha;[|split;reflexivity].
 rewrite Qle_bool_iff in Ha.
 simpl.
 rewrite (Qle_antisym _ _ Ha Hl1).
 split;ring.
change (-1) with (Qopp 1).
destruct Hl2' as [Hl2' <-].
rewrite <- Hl2'.
case l' as [|a' l'];[discriminate|].
clear Hl1 Hl2 Hl3 Hl2'.
simpl.
rewrite Qopp_plus, Qmult_plus_distr_r, (Qplus_comm (M*_)).
cut (- Qsum (map fst l') <= M * fst (Qcombine l') <= Qsum (map fst l')).
 intros [H1 H2].
 rewrite (Qmult_comm (fst a')).
 setoid_replace (-fst a') with (-1 * fst a') by ring.
 setoid_replace (fst a') with (1 * fst a') at 4 by ring.
 rewrite Qmult_assoc.
 specialize (Hl1' (fst a') (snd a')).
 rewrite <- surjective_pairing in Hl1'.
 destruct Hl1' as [Ha1 [_ Ha2]];auto with *.
 rewrite (surjective_pairing (snd a')) in Ha2.
 specialize (Hnarrow _ _ Ha2).
 split;
 apply Qplus_lt_le_compat; auto;
 apply Qmult_lt_compat_r; tauto.
assert (Hl1 : forall (q : Q) (p : DD),
       In (q, p) l' -> 0 < q /\ q <= 1 /\ DDSet.In p (DDSet.add zero s)) by firstorder.
clear -Hnarrow Hl1.
induction l' as [|[c p] l IHl];simpl;[rewrite Qmult_0_r;auto with *|].
rewrite (Qplus_comm c), Qopp_plus, Qmult_plus_distr_r.
specialize (IHl (fun q p H => Hl1 q p (or_intror H))).
rewrite (Qmult_comm c).
setoid_replace (-c) with (-1 * c) by ring.
setoid_replace c with (1 * c) at 4 by ring.
rewrite Qmult_assoc.
specialize (Hl1 c p (or_introl (refl_equal _))).
destruct Hl1 as [Hc0 [Hc1 Hp]].
rewrite (surjective_pairing p) in Hp.
specialize (Hnarrow _ _ Hp).
split;
apply Qplus_le_compat; try tauto;
apply Qmult_le_compat_r; auto with *;
apply Qlt_le_weak; tauto.
Qed.

Definition in_State (M : Z) (ds : hddivsteps.State) (s : State) : Prop :=
  hddivsteps.g ds = 0%Z \/
  in_convex_hull (hddivsteps.g ds / M, hddivsteps.f ds / M)
   (DDSet.add (0:D,0:D)%Z (State_lookup (hddivsteps.delta ds) s)).

Lemma in_State_step : forall M ds st, (0 < M)%Z -> Z.Odd (hddivsteps.f ds) ->
 in_State M ds st -> in_State M (hddivsteps.step ds) (processDivstep M st).
Proof.
intros M [delta f g] st HM Hf [Hst|Hst];[left; auto using hddivsteps.zero_step|].
rewrite <- Zodd_equiv in Hf.
simpl in *.
set (ds' := hddivsteps.step _).
pose (delta' := hddivsteps.delta ds').
pose (f' := hddivsteps.f ds').
pose (g' := hddivsteps.g ds').
unfold processDivstep.
set (fm2 := fun kv => _).
set (fm1 := fun kv => _).
set (st1 := State_fromList (flat_map fm1 _)).
set (st2 := State_fromList (flat_map fm2 _)).
case (Z.eq_dec g 0) as [Hg0|Hg0];
 [left;unfold ds'; auto using hddivsteps.zero_step|].
case (Z.eq_dec g' 0) as [Hg'0|Hg'0];
 [left;auto|].
assert (H : {s | ZMap.MapsTo delta s st}).
  clear - Hst Hg0 HM.
  unfold State_lookup in Hst.
  case (ZMap.find delta st) as [s|] eqn:Hfind;
    [exists s; auto using ZMap.find_2|].
  apply in_convex_hull_singleton in Hst.
  destruct Hst as [Hst _].
  simpl in Hst.
  rewrite <- inject_Z_injective in Hg0.
  rewrite Zlt_Qlt in HM.
  rewrite <- !inject_Z_D_Q in *.
  apply Qinv_lt_0_compat in HM.
  apply Qmult_integral_l in Hst; auto.
  rewrite Hst in HM.
  discriminate.
destruct H as [s Hs].
pose (divstep_trans :=
  if Z.even g then even_trans
              else if (0 <? delta)%Z then odd_pos_trans else odd_nonpos_trans).
pose (divstep_matrix :=
  if Z.even g then even_matrix
              else if (0 <? delta)%Z then odd_pos_matrix else odd_nonpos_matrix).
set (zero := (0%Z:D,0%Z:D)) in *.
assert (Hst' : in_convex_hull (g' / M, f' / M) (DDSet.add zero (State_lookup delta' st1))).
  assert (Hx := ZMap.elements_1 Hs).
  apply SetoidList.InA_altdef in Hx.
  apply Exists_exists in Hx.
  destruct Hx as [x [Hx1 Hx2]].
  apply State_in_convex_hull_fromList1 with (DDSet_map divstep_trans (snd x)).
  * apply in_convex_hull_map_ext with divstep_matrix (g / M, f / M).
    - intros p. clear.
      case (Z.even g) in *;[apply even_trans_matrix|].
      case (0 <? delta)%Z in *;[apply odd_pos_trans_matrix|].
      apply odd_nonpos_trans_matrix.
    - clear -Hf.
      unfold QQeq, g', f', ds', hddivsteps.step; simpl.
      case (Z.even g) eqn:Hg in *;[apply Zeven_bool_iff in Hg
                                  |apply (f_equal negb) in Hg;
                                   rewrite Z.negb_even in Hg;
                                   apply Zodd_bool_iff in Hg;
                                   case (0 <? delta)%Z in *];simpl;
        rewrite !Dhalf_Q;
        change (inject_D (-1)%Z:Q) with (-1);
        change (inject_D 1%Z:Q) with 1;
        change (inject_D 0%Z:Q) with 0;
        split; try ring;
        unfold Z.sub;
        rewrite !inject_Z_D_Q, inject_Z_half, ?inject_Z_plus, ?inject_Z_opp;
        try (unfold Qdiv; ring);
        apply Zeven_equiv;
        auto using Zodd_plus_Zodd, Zodd_opp.
    - clear -Hst Hs Hx2.
      destruct Hx2 as [_ Hx2].
      replace (snd x) with s.
      unfold State_lookup in Hst.
      rewrite (ZMap.find_1 Hs) in Hst.
      assumption.
  * apply in_flat_map.
    exists x; split; auto.
    clear -Hx2; destruct x; destruct Hx2 as [Hx1 Hx2].
    unfold hddivsteps.step in ds'; cbn -[Z.ltb Z.add Z.sub] in *.
    rewrite <- Hx1.
    case (Z.even g) in *;[left;reflexivity|].
    right;left.
    case (0 <? delta)%Z in *;
    reflexivity.
* clear s Hs.
  assert (H : {s | ZMap.MapsTo delta' s st1}).
   clear - Hst' Hg'0 HM.
   unfold State_lookup in Hst'.
   case (ZMap.find delta' st1) as [s|] eqn:Hfind;
     [exists s; auto using ZMap.find_2|].
   apply in_convex_hull_singleton in Hst'.
   destruct Hst' as [Hst' _].
   simpl in Hst'.
   rewrite <- inject_Z_injective in Hg'0.
   rewrite Zlt_Qlt in HM.
   rewrite <- !inject_Z_D_Q in *.
   apply Qinv_lt_0_compat in HM.
   apply Qmult_integral_l in Hst'; auto.
   rewrite Hst' in HM.
   discriminate.
  destruct H as [s Hs].
  assert (Hx := ZMap.elements_1 Hs).
  apply SetoidList.InA_altdef in Hx.
  apply Exists_exists in Hx.
  destruct Hx as [x [Hx1 Hx2]].
  unfold State_lookup in Hst'.
  rewrite (ZMap.find_1 Hs) in Hst'.
  case (narrow M s) eqn:Hnarrow;
  [left;
   apply (in_narrow _ _ _ _ HM Hnarrow Hst')
  |].
  right.
  fold g' f' delta'.
  apply State_in_convex_hull_fromList1 with (convexHull s).
    auto using in_convex_hull_convexHull.
  apply in_flat_map.
  exists x.
  split; try tauto.
  destruct x as [x0 x1].
  destruct Hx2 as [Hx2 Hx3]; simpl in *.
  rewrite <- Hx2, <- Hx3, Hnarrow.
  auto with *.
Qed.

Module ZMapProperties := FMapFacts.OrdProperties ZMap.

Theorem processDivstep_correct : forall N M f g,
  Z.Odd f ->
  (f <= M)%Z -> (0 <= g <= f)%Z ->
  ZMap.Empty (N.iter N (processDivstep M) state0) ->
  hddivsteps.g (N.iter N hddivsteps.step (hddivsteps.init f g)) = 0%Z.
Proof.
intros N M f g HM Hf Hg H.
rewrite N2Nat.inj_iter.
rewrite <- N2Nat.inj_iter.
assert (HM0 : (0 < M)%Z).
 eapply Z.lt_le_trans;[|apply Hf].
 apply Z.le_neq.
 split; auto with *.
 intros <-.
 rewrite <- Zodd_equiv in HM.
 contradiction.
assert (HM2 : 0 < M).
 rewrite inject_Z_D_Q.
 change 0 with (inject_Z 0).
 rewrite <- Zlt_Qlt.
 assumption.
cut (in_State M (N.iter N hddivsteps.step (hddivsteps.init f g)) (N.iter N (processDivstep M) state0)).
 intros [H0|H0];auto.
 set (p := (_,_)) in *.
 set (st' := N.iter N hddivsteps.step _) in *.
 unfold State_lookup in H0.
 case (ZMap.find _ _) eqn:Hfind.
  apply ZMap.find_2 in Hfind.
  apply ZMap.elements_1 in Hfind.
  apply ZMapProperties.P.elements_Empty in H.
  rewrite H in Hfind.
  apply SetoidList.InA_nil in Hfind.
  contradiction.
 apply in_convex_hull_singleton in H0.
 destruct H0 as [H0 _].
 simpl in *.
 apply inject_Z_injective.
 rewrite <- !inject_Z_D_Q.
 change (0%Z:Q) with 0 in *.
 apply Qmult_integral in H0.
 destruct H0 as [H0|H0]; auto.
 apply Qinv_lt_0_compat in HM2.
 rewrite H0 in HM2.
 discriminate.
clear H.
cut (in_State M (hddivsteps.init f g) state0).
 intros H.
 apply proj2 with (Z.Odd (hddivsteps.f (N.iter N hddivsteps.step (hddivsteps.init f g)))).
 elim N using N.induction;[intros x y ->| |];try tauto.
 intros n.
 intros H0.
 rewrite !N.iter_succ.
 split;[apply hddivsteps.odd_step;tauto|].
 apply in_State_step;auto with *; try tauto.
right.
unfold State_lookup; simpl.
pose (l := ((1-f/M),(0:D,0:D)%Z)
         ::(g / M,(1:D,1:D)%Z)
         ::((f - g)/M,(0:D,1:D)%Z)
         ::nil : list (Q*DD)).
exists l.
do 2 (try split).
* destruct H as [H|[H|[H|[]]]];inversion H.
  + apply -> Qle_minus_iff.
    apply Qle_shift_div_r; auto with *.
    ring_simplify.
    rewrite !inject_Z_D_Q.
    change 0 with (inject_Z 0).
    rewrite <- Zle_Qle.
    auto with *.
  + apply Qle_shift_div_l;auto with *.
    ring_simplify.
    rewrite inject_Z_D_Q.
    change 0 with (inject_Z 0).
    rewrite <- Zle_Qle.
    auto with *.
  + apply Qle_shift_div_l;auto with *.
    ring_simplify (0 * M).
    apply -> Qle_minus_iff.
    rewrite !inject_Z_D_Q.
    rewrite <- Zle_Qle.
    auto with *.
* destruct H as [H|[H|[H|[]]]];
    inversion H;
    apply DDSet.mem_spec;
    reflexivity.
* simpl; field.
  auto with *.
* simpl.
  change (0%Z:Q) with 0.
  change (1%Z:Q) with 1.
  split; simpl; try ring.
  field.
  auto with *.
Qed.

Corollary processDivstep_gcd : forall N M f g,
  Z.Odd f ->
  (f <= M)%Z -> (0 <= g <= f)%Z ->
  ZMap.Empty (N.iter N (processDivstep M) state0) ->
  Znumtheory.Zis_gcd f g
   (hddivsteps.f (N.iter N hddivsteps.step (hddivsteps.init f g))).
Proof.
intros N M f g HM Hf Hg H.
rewrite N2Nat.inj_iter.
apply (hddivsteps.gcd_spec _ (hddivsteps.init f g)); auto.
rewrite <- N2Nat.inj_iter.
eapply processDivstep_correct; eauto.
Qed.

Corollary processDivstep_inverse : forall N M f g,
  Z.Odd f ->
  (f <= M)%Z -> (0 <= g <= f)%Z ->
  Znumtheory.rel_prime f g ->
  ZMap.Empty (N.iter N (processDivstep M) state0) ->
  let st' := N.iter N hddivsteps.step (hddivsteps.init f g) in
  Z.abs (hddivsteps.f st') = 1%Z /\
  eqm f ((hddivsteps.d st' * hddivsteps.f st') * g) 1.
Proof.
intros N M f g Hodd HM Hgf Hprime Hempty st'.
unfold st'; clear st'.
rewrite N2Nat.inj_iter.
apply hddivsteps.modulo_spec; auto using hddivsteps.modulo_init.
rewrite <- N2Nat.inj_iter.
eapply processDivstep_correct; eauto.
Qed.

Corollary processDivstep_prime_inverse : forall N M f g,
  Z.Odd f ->
  (g < f <= M)%Z ->
  Znumtheory.prime f ->
  ZMap.Empty (N.iter N (processDivstep M) state0) ->
  let st' := N.iter N hddivsteps.step (hddivsteps.init f g) in
  (g = 0 -> hddivsteps.d st' = 0)%Z /\
  (0 < g -> Z.abs (hddivsteps.f st') = 1 /\
            eqm f ((hddivsteps.d st' * hddivsteps.f st') * g) 1)%Z.
Proof.
intros N M f g Hodd Hgf Hprime Hempty st'.
split.
* intros Hg.
  rewrite Hg in *.
  unfold st'.
  rewrite N2Nat.inj_iter, hddivsteps.d_zero_spec; rewrite Hg; reflexivity.
* intros Hg.
  eapply (processDivstep_inverse N M); eauto with *.
  apply Znumtheory.prime_rel_prime; auto.
  intros Hfg.
  apply Z.divide_pos_le in Hfg; auto with *.
Qed.


Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Coq.Program.Basics.
Local Open Scope program_scope.

Require Import KA.Utilities.
Require Import KA.Finite.
Require Import KA.Booleans.
Require Import KA.Terms.
Require Import KA.Vectors.
Require Import KA.Automata.
Require Import KA.Scope.
Local Open Scope ka_scope.

Section AntimirovTypes.
  Variable (A: Type).
  Notation term := (term A).

  Inductive derivative: term -> Type :=
  | TOneOne:
      derivative 1
  | TLetterLetter:
      forall (a: A),
      derivative ($ a)
  | TLetterOne:
      forall {a: A},
      derivative ($ a)
  | TPlusLeft:
      forall {t1: term} (t2: term),
      derivative t1 ->
      derivative (t1 + t2)
  | TPlusRight:
      forall (t1: term) {t2: term},
      derivative t2 ->
      derivative (t1 + t2)
  | TTimesPre:
      forall {t1: term} (t2: term),
      derivative t1 ->
      derivative (t1 ;; t2)
  | TTimesPost:
      forall (t1: term) {t2: term},
      derivative t2 ->
      derivative (t1 ;; t2)
  | TStarInner:
      forall (t: term),
      derivative t ->
      derivative (t *)
  | TStarOne:
      forall (t: term),
      derivative (t *)
  .
  Derive Signature for derivative.

  Inductive initial:
    forall {t: term},
    derivative t ->
    Prop
  :=
  | InitialOneOne:
      initial TOneOne
  | InitialLetterLetter:
      forall (a: A),
      initial (TLetterLetter a)
  | InitialPlusLeft:
      forall (t1 t2: term) (d1: derivative t1),
      initial d1 ->
      initial (TPlusLeft t2 d1)
  | InitialPlusRight:
      forall (t1 t2: term) (d2: derivative t2),
      initial d2 ->
      initial (TPlusRight t1 d2)
  | InitialTimesPre:
      forall (t1 t2: term) (d1: derivative t1),
      initial d1 ->
      initial (TTimesPre t2 d1)
  | InitialStarStep:
      forall (t: term) (d: derivative t),
      initial d ->
      initial (TStarInner t d)
  | InitialStarOne:
      forall (t: term),
      initial (TStarOne t)
  .

  Inductive nullable:
    forall {t: term},
    derivative t ->
    Prop
  :=
  | NullableOneOne:
      nullable TOneOne
  | NullableLetterOne:
      forall (a: A),
      nullable (TLetterOne (a := a))
  | NullablePlusLeft:
      forall (t1 t2: term) (d: derivative t1),
      nullable d ->
      nullable (TPlusLeft t2 d)
  | NullablePlusRight:
      forall (t1 t2: term) (d: derivative t2),
      nullable d ->
      nullable (TPlusRight t1 d)
  | NullableTimesPre:
      forall (t1 t2: term) (d1: derivative t1) (d2: derivative t2),
      nullable d1 ->
      nullable d2 ->
      initial d2 ->
      nullable (TTimesPre t2 d1)
  | NullableTimesPost:
      forall (t1 t2: term) (d2: derivative t2),
      nullable d2 ->
      nullable (TTimesPost t1 d2)
  | NullableStarInner:
      forall (t: term) (d: derivative t),
      nullable d ->
      nullable (TStarInner t d)
  | NullableStarOne:
      forall (t: term),
      nullable (TStarOne t)
  .

  Equations derivative_write {t: term} (d: derivative t): term := {
    derivative_write TOneOne := 1;
    derivative_write (TLetterLetter a) := $ a;
    derivative_write TLetterOne := 1;
    derivative_write (TPlusLeft _ d) := derivative_write d;
    derivative_write (TPlusRight _ d) := derivative_write d;
    derivative_write (TTimesPre t2 d) := derivative_write d ;; t2;
    derivative_write (TTimesPost _ d) := derivative_write d;
    derivative_write (TStarInner t d) := derivative_write d ;; t *;
    derivative_write (TStarOne t) := 1;
  }.
End AntimirovTypes.

Arguments TOneOne {A}.
Arguments TLetterLetter {A}.
Arguments TLetterOne {A} {a}.
Arguments TPlusLeft {A} {t1} t2.
Arguments TPlusRight {A} t1 {t2}.
Arguments TTimesPre {A} {t1} t2.
Arguments TTimesPost {A} t1 {t2}.
Arguments TStarInner {A}.
Arguments TStarOne {A}.
Arguments derivative_write {A} {t}.

Section AntimirovInitial.
  Context {A: Type}.
  Notation term := (term A).
  Notation derivative := (derivative A).
  Notation initial := (initial A).

  Equations initial_b {t: term} (d: derivative t): bool := {
    @initial_b 1 TOneOne := true;
    @initial_b ($ a) (TLetterLetter a) := true;
    @initial_b (t1 + t2) (TPlusLeft _ d1) := initial_b d1;
    @initial_b (t1 + t2) (TPlusRight _ d2) := initial_b d2;
    @initial_b (t1 ;; t2) (TTimesPre _ d1) := initial_b d1;
    @initial_b (t*) (TStarInner _ d) := initial_b d;
    @initial_b (t*) (TStarOne _) := true;
    @initial_b _ _ := false;
  }.

  Lemma initial_dec (t: term) (d: derivative t):
    initial d <-> initial_b d = true
  .
  Proof.
    dependent induction d;
    autorewrite with initial_b;
    match goal with
    | |- _ <-> true = true =>
      split; intros; [reflexivity | constructor]
    | |- _ <-> false = true =>
      split; intros; [inversion H | discriminate]
    | |- _ <-> initial_b d = true =>
      split; intros; [
        dependent destruction H |
        constructor ];
      intuition
    end.
  Qed.

  Equations initial_l (t: term): list (derivative t) := {
    initial_l 0 := nil;
    initial_l 1 := TOneOne :: nil;
    initial_l ($ a) := TLetterLetter a :: nil;
    initial_l (t1 + t2) :=
      map (TPlusLeft _) (initial_l t1) ++
      map (TPlusRight _) (initial_l t2);
    initial_l (t1 ;; t2) := map (TTimesPre t2) (initial_l t1);
    initial_l (t*) := TStarOne t :: map (TStarInner t) (initial_l t);
  }.

  Lemma initial_list (t: term) (d: derivative t):
    initial d <-> In d (initial_l t)
  .
  Proof.
    dependent induction d;
    autorewrite with initial_l;
    autorewrite with initial_b;
    try (split; intros; [now left | constructor]);
    try (split; intros; [inversion H | now destruct H]).
    - rewrite in_app_iff; repeat rewrite in_map_iff.
      split; intros.
      + dependent destruction H.
        left; eexists.
        intuition.
      + constructor.
        destruct H as [[d' [? ?]] | [d' [? ?]]].
        * apply IHd.
          inversion H.
          now clean_exists.
        * discriminate.
    - rewrite in_app_iff; repeat rewrite in_map_iff.
      split; intros.
      + dependent destruction H.
        right; eexists.
        intuition.
      + constructor.
        destruct H as [[d' [? ?]] | [d' [? ?]]].
        * discriminate.
        * apply IHd.
          inversion H.
          now clean_exists.
    - rewrite in_map_iff.
      split; intros.
      + dependent destruction H.
        eexists.
        intuition.
      + constructor.
        apply IHd.
        destruct H as [d' [? ?]].
        inversion H.
        now clean_exists.
    - rewrite in_map_iff.
      split; intros.
      + dependent destruction H.
      + now destruct H as [d' [? ?]].
    - simpl.
      rewrite in_map_iff.
      split; intros.
      + dependent destruction H.
        right.
        eexists.
        intuition.
      + destruct H as [? | [d' [? ?]]];
        try discriminate.
        inversion H.
        constructor.
        clean_exists.
        intuition.
  Qed.

  Lemma initial_reconstruct (t: term):
    t == sum (map derivative_write (initial_l t))
  .
  Proof.
    induction t.
    - now vm_compute.
    - vm_compute.
      now rewrite EPlusUnit.
    - vm_compute.
      now rewrite EPlusUnit.
    - autorewrite with initial_l.
      rewrite map_app.
      rewrite sum_split.
      repeat rewrite map_map.
      rewrite map_ext
        with (f := (fun x => derivative_write (TPlusLeft t2 x)))
             (g := derivative_write)
        by easy.
      rewrite map_ext
        with (f := (fun x => derivative_write (TPlusRight t1 x)))
             (g := derivative_write)
        by easy.
      now rewrite <- IHt1, <- IHt2.
    - autorewrite with initial_l.
      rewrite map_map.
      rewrite map_ext with (g := (fun x => derivative_write x ;; t2)) by easy.
      rewrite <- map_map with (g := fun x => x ;; t2).
      rewrite sum_distribute_right.
      now rewrite <- IHt1.
    - autorewrite with initial_l.
      simpl; autorewrite with sum.
      autorewrite with derivative_write.
      rewrite map_map.
      rewrite map_ext with (g := (fun x => derivative_write x ;; t*)) by easy.
      rewrite <- map_map with (g := fun x => x ;; t*).
      rewrite sum_distribute_right.
      rewrite <- IHt.
      rewrite EStarLeft at 1.
      now rewrite EPlusComm.
  Qed.

  Lemma initial_cover (t: term) (d: derivative t):
    initial d ->
    derivative_write d <= t
  .
  Proof.
    intros.
    eapply term_lequiv_trans.
    + apply sum_lequiv_member.
      apply in_map_iff.
      eexists; split; auto.
      now apply initial_list.
    + rewrite <- initial_reconstruct.
      apply term_lequiv_refl.
  Qed.
End AntimirovInitial.

Section AntimirovNullable.
  Context {A: Type}.
  Notation term := (term A).
  Notation derivative := (derivative A).
  Notation nullable := (nullable A).

  Equations nullable_b {t: term} (d: derivative t) : bool := {
    @nullable_b 1 TOneOne := true;
    @nullable_b ($ _) TLetterOne := true;
    @nullable_b (t1 + t2) (TPlusLeft _ d) := nullable_b d;
    @nullable_b (t1 + t2) (TPlusRight _ d) := nullable_b d;
    @nullable_b (t1 ;; t2) (TTimesPre _ d) :=
      nullable_b d && disj (map nullable_b (initial_l t2));
    @nullable_b (t1 ;; t2) (TTimesPost _ d) :=
      nullable_b d;
    @nullable_b (t*) (TStarInner _ d) :=
      nullable_b d;
    @nullable_b (t*) (TStarOne _) := true;
    @nullable_b _ _ := false;
  }.

  Lemma nullable_dec (t: term) (d: derivative t):
    nullable d <-> nullable_b d = true
  .
  Proof.
    dependent induction t;
    dependent destruction d;
    autorewrite with nullable_b;
    match goal with
    | |- _ <-> true = true =>
      split; intros; [reflexivity | constructor]
    | |- _ <-> false = true =>
      split; intros; [inversion H | discriminate]
    | |- _ <-> nullable_b _ = true =>
      split; intros; [
        dependent destruction H; intuition |
        constructor ];
      intuition
    | _ => idtac
    end.
    split; intros.
    - dependent destruction H.
      apply andb_true_intro; split.
      + now apply IHt1.
      + apply disj_true.
        apply in_map_iff.
        exists d2.
        split.
        * now apply IHt2.
        * now apply initial_list.
    - apply andb_prop in H; destruct H.
      apply disj_true in H0.
      apply in_map_iff in H0.
      destruct H0 as [d' [? ?]].
      eapply NullableTimesPre.
      + now apply IHt1.
      + apply IHt2.
        apply H0.
      + now apply initial_list.
  Qed.

  Lemma nullable_one (t: term) (d: derivative t):
    nullable d ->
    1 <= derivative_write d
  .
  Proof.
    intros.
    dependent induction H;
    autorewrite with derivative_write;
    auto.
    - apply term_lequiv_refl.
    - apply term_lequiv_refl.
    - rewrite <- ETimesUnitRight with (t := 1).
      apply times_mor_mono.
      + apply IHnullable1.
      + eapply term_lequiv_trans.
        * apply IHnullable2.
        * now apply initial_cover.
    - rewrite <- ETimesUnitRight with (t := 1).
      apply times_mor_mono.
      + apply IHnullable.
      + eapply term_lequiv_trans.
        * apply term_lequiv_split_right.
          apply term_lequiv_refl.
        * rewrite EStarLeft.
          apply term_lequiv_refl.
    - apply term_lequiv_refl.
  Qed.
End AntimirovNullable.

Section AntimirovDerive.
  Context {A: Type}.
  Context `{Finite A}.
  Notation term := (term A).
  Notation derivative := (derivative A).
  Notation initial := (initial A).
  Notation nullable := (nullable A).

  Inductive derive (a: A):
    forall {t: term},
    derivative t ->
    derivative t ->
    Prop
  :=
  | DeriveLetterLetter: derive a (TLetterLetter a) TLetterOne
  | DerivePlusLeft:
      forall (t1 t2: term) (d11 d12: derivative t1),
      derive a d11 d12 ->
      derive a (TPlusLeft t2 d11) (TPlusLeft t2 d12)
  | DerivePlusRight:
      forall (t1 t2: term) (d21 d22: derivative t2),
      derive a d21 d22 ->
      derive a (TPlusRight t1 d21) (TPlusRight t1 d22)
  | DeriveTimesPre:
      forall (t1 t2: term) (d11 d12: derivative t1),
      derive a d11 d12 ->
      derive a (TTimesPre t2 d11) (TTimesPre t2 d12)
  | DeriveTimesJump:
      forall (t1 t2: term) (d1: derivative t1) (i d2: derivative t2),
      nullable d1 ->
      initial i ->
      derive a i d2 ->
      derive a (TTimesPre t2 d1) (TTimesPost t1 d2)
  | DeriveTimesPost:
      forall (t1 t2: term) (d21 d22: derivative t2),
      derive a d21 d22 ->
      derive a (TTimesPost t1 d21) (TTimesPost t1 d22)
  | DeriveStarInnerStep:
      forall (t: term) (d1 d2: derivative t),
      derive a d1 d2 ->
      derive a (TStarInner t d1) (TStarInner t d2)
  | DeriveStarInnerJump:
      forall (t: term) (d1 i d2: derivative t),
      nullable d1 ->
      initial i ->
      derive a i d2 ->
      derive a (TStarInner t d1) (TStarInner t d2)
  .

  Equations derive_b (a: A) {t: term} (d1 d2: derivative t): bool := {
    derive_b a (TLetterLetter a') TLetterOne :=
      if finite_dec a a' then true else false;
    derive_b a (TPlusLeft _ d1) (TPlusLeft _ d2) := derive_b a d1 d2;
    derive_b a (TPlusRight _ d1) (TPlusRight _ d2) := derive_b a d1 d2;
    derive_b a (TTimesPre _ d1) (TTimesPre _ d2) := derive_b a d1 d2;
    derive_b a (TTimesPre t2 d1) (TTimesPost _ d2) :=
      nullable_b d1 && disj (map (fun i => derive_b a i d2) (initial_l t2));
    derive_b a (TTimesPost _ d1) (TTimesPost _ d2) := derive_b a d1 d2;
    derive_b a (TStarInner _ d1) (TStarInner _ d2) :=
      derive_b a d1 d2 || (
        nullable_b d1 &&
        disj (map (fun i => derive_b a i d2) (initial_l t))
      );
    derive_b _ _ _ := false;
  }.

  Lemma derive_dec (t: term) (d1 d2: derivative t) (a: A):
    derive a d1 d2 <-> derive_b a d1 d2 = true
  .
  Proof.
    dependent induction t;
    dependent destruction d1;
    dependent destruction d2;
    autorewrite with derive_b;
    match goal with
    | |- _ <-> true = true =>
      split; intros; [reflexivity | constructor]
    | |- _ <-> false = true =>
      split; intros; [now inversion H0 | discriminate]
    | |- _ <-> derive_b _ _ _ = true =>
      split; intros; [
        dependent destruction H0; intuition |
        constructor ];
      intuition
    | _ => idtac
    end.
    - destruct (finite_dec a0 a); split; intros.
      + reflexivity.
      + subst; constructor.
      + now inversion H0.
      + discriminate.
    - split; intros.
      + dependent destruction H0.
        apply andb_true_intro; split.
        * now apply nullable_dec.
        * apply disj_true.
          apply in_map_iff.
          eexists.
          intuition.
          now apply initial_list.
      + apply andb_prop in H0; destruct H0.
        apply disj_true in H1.
        apply in_map_iff in H1.
        destruct H1 as [i [? ?]].
        eapply DeriveTimesJump.
        * now apply nullable_dec.
        * apply initial_list, H2.
        * now apply IHt2.
    - split; intros.
      + apply Bool.orb_true_intro.
        dependent destruction H0.
        * left.
          now apply IHt.
        * right.
          apply andb_true_intro; split.
          -- now apply nullable_dec.
          -- apply disj_true.
             apply in_map_iff.
             exists i.
             intuition.
             now apply initial_list.
      + apply Bool.orb_true_elim in H0.
        destruct H0.
        * apply DeriveStarInnerStep.
          now apply IHt.
        * apply andb_prop in e; destruct e.
          apply disj_true in H1.
          apply in_map_iff in H1.
          destruct H1 as [i [? ?]].
          eapply DeriveStarInnerJump.
          -- now apply nullable_dec.
          -- apply initial_list, H2.
          -- now apply IHt.
  Qed.

  Equations derive_list (t: term) : list (derivative t) := {
    derive_list 0 := nil;
    derive_list 1 := TOneOne :: nil;
    derive_list ($ a) := TLetterLetter a :: TLetterOne :: nil;
    derive_list (t1 + t2) :=
      map (TPlusLeft _) (derive_list t1) ++
      map (TPlusRight _) (derive_list t2);
    derive_list (t1 ;; t2) :=
      map (TTimesPre _) (derive_list t1) ++
      map (TTimesPost _) (derive_list t2);
    derive_list (t*) :=
      TStarOne _ :: map (TStarInner _) (derive_list t);
  }.

  Equations derive_eqb {t: term} (d1 d2: derivative t) : bool := {
    derive_eqb TOneOne TOneOne := true;
    derive_eqb (TLetterLetter _) (TLetterLetter _) := true;
    derive_eqb TLetterOne TLetterOne := true;
    derive_eqb (TPlusLeft _ d1) (TPlusLeft _ d2) := derive_eqb d1 d2;
    derive_eqb (TPlusRight _ d1) (TPlusRight _ d2) := derive_eqb d1 d2;
    derive_eqb (TTimesPre _ d1) (TTimesPre _ d2) := derive_eqb d1 d2;
    derive_eqb (TTimesPost _ d1) (TTimesPost _ d2) := derive_eqb d1 d2;
    derive_eqb (TStarOne _) (TStarOne _) := true;
    derive_eqb (TStarInner _ d1) (TStarInner _ d2) := derive_eqb d1 d2;
    derive_eqb _ _ := false;
  }.

  Lemma derive_eqb_correct (t: term) (d1 d2: derivative t):
    derive_eqb d1 d2 = true <-> d1 = d2
  .
  Proof.
    dependent induction t;
    dependent destruction d1;
    dependent destruction d2;
    autorewrite with derive_eqb;
    try easy.
    - rewrite IHt1.
      split; intros.
      + now subst.
      + apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
    - rewrite IHt2.
      split; intros.
      + now subst.
      + apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
    - rewrite IHt1.
      split; intros.
      + now subst.
      + apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
    - rewrite IHt2.
      split; intros.
      + now subst.
      + apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
    - rewrite IHt.
      split; intros.
      + now subst.
      + apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
  Qed.

  Global Program Instance: forall t, Finite (derivative t).
  Next Obligation.
    apply derive_list.
  Defined.
  Next Obligation.
    destruct (derive_eqb x1 x2) eqn:?.
    - left; now apply derive_eqb_correct.
    - right.
      contradict Heqb.
      apply Bool.not_false_iff_true.
      now apply derive_eqb_correct.
  Qed.
  Next Obligation.
    unfold Finite_instance_0_obligation_1.
    dependent induction x;
    autorewrite with derive_list.
    - now left.
    - now left.
    - right; now left.
    - apply in_app_iff; left.
      apply in_map_iff; now exists x.
    - apply in_app_iff; right.
      apply in_map_iff; now exists x.
    - apply in_app_iff; left.
      apply in_map_iff; now exists x.
    - apply in_app_iff; right.
      apply in_map_iff; now exists x.
    - right.
      apply in_map_iff; now exists x.
    - now left.
  Qed.
  Next Obligation.
    unfold Finite_instance_0_obligation_1.
    dependent induction t;
    autorewrite with derive_list.
    - constructor.
    - constructor; auto.
      constructor.
    - constructor.
      + intro.
        destruct H0; auto.
        discriminate.
      + constructor; auto.
        constructor.
    - apply NoDup_app.
      + apply NoDup_map; auto; intros.
        apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
      + apply NoDup_map; auto; intros.
        apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
      + intros; intro.
        apply in_map_iff in H0, H1.
        destruct H0 as [d1 [? ?]].
        destruct H1 as [d2 [? ?]].
        subst.
        discriminate.
      + intros; intro.
        apply in_map_iff in H0, H1.
        destruct H0 as [d1 [? ?]].
        destruct H1 as [d2 [? ?]].
        subst.
        discriminate.
    - apply NoDup_app.
      + apply NoDup_map; auto; intros.
        apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
      + apply NoDup_map; auto; intros.
        apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
      + intros; intro.
        apply in_map_iff in H0, H1.
        destruct H0 as [d1 [? ?]].
        destruct H1 as [d2 [? ?]].
        subst.
        discriminate.
      + intros; intro.
        apply in_map_iff in H0, H1.
        destruct H0 as [d1 [? ?]].
        destruct H1 as [d2 [? ?]].
        subst.
        discriminate.
    - constructor.
      + intro.
        apply in_map_iff in H0.
        destruct H0 as [d [? ?]].
        discriminate.
      + apply NoDup_map; auto; intros.
        apply Eqdep.EqdepTheory.inj_pair2.
        now inversion H0.
  Qed.
End AntimirovDerive.

Section AntimirovAutomaton.
  Context {A: Type}.
  Context `{Finite A}.
  Notation term := (term A).
  Notation derivative := (derivative A).
  Notation automaton := (automaton A).

  Definition automaton_antimirov (t: term) : automaton (derivative t) := {|
    aut_transitions a d1 d2 := derive_b a d1 d2;
    aut_accept := nullable_b;
  |}.
End AntimirovAutomaton.

Section AntimirovMorphisms.
  Context {A: Type}.
  Context `{Finite A}.
  Notation term := (term A).
  Notation derivative := (derivative A).
  Notation initial := (initial A).
  Notation automaton := (automaton A).

  Record term_homomorphism (t1 t2: term) := {
    term_homomorphism_automaton_homomorphism :>
      automaton_homomorphism (automaton_antimirov t1)
                             (automaton_antimirov t2);
    term_homomorphism_preserve_initial:
      forall (d1: derivative t1),
      initial d1 ->
      initial (term_homomorphism_automaton_homomorphism d1)
  }.

  Equations term_homomorphism_assoc_f
    {t1 t2 t3: term}
    (d: derivative (t1 ;; (t2 ;; t3)))
    : derivative ((t1 ;; t2) ;; t3)
  := {
    term_homomorphism_assoc_f (TTimesPre _ d) :=
      TTimesPre _ (TTimesPre _ d);
    term_homomorphism_assoc_f (TTimesPost _ (TTimesPre _ d)) :=
      TTimesPre _ (TTimesPost _ d);
    term_homomorphism_assoc_f (TTimesPost _ (TTimesPost _ d)) :=
      TTimesPost _ d;
  }.

  Program Definition term_homomorphism_assoc (t1 t2 t3: term):
    term_homomorphism (t1 ;; (t2 ;; t3)) ((t1 ;; t2) ;; t3)
  := {|
    term_homomorphism_automaton_homomorphism := {|
      automaton_homomorphism_f := term_homomorphism_assoc_f;
    |};
  |}.
  Next Obligation.
    apply derive_dec in H0.
    apply derive_dec.
    dependent destruction H0.
    - autorewrite with term_homomorphism_assoc_f.
      now repeat constructor.
    - dependent destruction H2;
      autorewrite with term_homomorphism_assoc_f.
      + dependent destruction H1.
        constructor.
        now apply DeriveTimesJump with (i := d11).
      + dependent destruction H1.
        apply DeriveTimesJump with (i := i0); auto.
        now apply NullableTimesPre with (d2 := d0).
      + dependent destruction H1.
    - dependent destruction H0;
      autorewrite with term_homomorphism_assoc_f.
      + now repeat constructor.
      + apply DeriveTimesJump with (i := i); auto.
        now constructor.
      + now constructor.
  Qed.
  Next Obligation.
    apply nullable_dec in H0.
    apply nullable_dec.
    dependent destruction q1.
    - dependent destruction H0.
      autorewrite with term_homomorphism_assoc_f.
      dependent destruction d2.
      dependent destruction H0_0.
      dependent destruction H1.
      + eapply NullableTimesPre with (d2 := d0); auto.
        now apply NullableTimesPre with (d2 := d2).
      + dependent destruction H0.
    - dependent destruction H0.
      dependent destruction q1.
      + autorewrite with term_homomorphism_assoc_f.
        dependent destruction H0.
        eapply NullableTimesPre with (d2 := d2); auto.
        now constructor.
      + autorewrite with term_homomorphism_assoc_f.
        dependent destruction H0.
        now constructor.
  Qed.
  Next Obligation.
    dependent destruction H0.
    autorewrite with term_homomorphism_assoc_f.
    now repeat constructor.
  Qed.

  Equations term_homomorphism_roll_f
    {t: term}
    (d: derivative (t ;; t* + 1))
    : derivative (t*)
  := {
    term_homomorphism_roll_f (TPlusRight _ TOneOne) := TStarOne _;
    term_homomorphism_roll_f (TPlusLeft _ (TTimesPre _ d)) := TStarInner _ d;
    term_homomorphism_roll_f (TPlusLeft _ (TTimesPost _ d)) := d;
  }.

  Program Definition term_homomorphism_roll (t: term):
    term_homomorphism (t ;; t* + 1) (t*)
  := {|
    term_homomorphism_automaton_homomorphism := {|
      automaton_homomorphism_f := term_homomorphism_roll_f;
    |};
  |}.
  Next Obligation.
    apply derive_dec in H0.
    apply derive_dec.
    dependent destruction H0.
    - dependent destruction H0;
      autorewrite with term_homomorphism_roll_f.
      + now constructor.
      + dependent destruction H2.
        * dependent destruction H1.
          now apply DeriveStarInnerJump with (i := d0).
        * dependent destruction H1.
          now apply DeriveStarInnerJump with (i := i0).
      + assumption.
    - dependent destruction H0.
  Qed.
  Next Obligation.
    apply nullable_dec in H0.
    apply nullable_dec.
    dependent destruction H0.
    - dependent destruction H0;
      autorewrite with term_homomorphism_roll_f.
      + now constructor.
      + assumption.
    - dependent destruction H0.
      autorewrite with term_homomorphism_roll_f.
      constructor.
  Qed.
  Next Obligation.
    dependent destruction H0.
    - dependent destruction H0.
      autorewrite with term_homomorphism_roll_f.
      now constructor.
    - dependent destruction H0.
      autorewrite with term_homomorphism_roll_f.
      now constructor.
  Qed.

  Program Definition term_homomorphism_inject_left
    (t1 t2: term)
  :
    term_homomorphism t1 (t1 + t2)
  := {|
    term_homomorphism_automaton_homomorphism := {|
      automaton_homomorphism_f d := TPlusLeft _ d;
    |};
  |}.
  Next Obligation.
    now constructor.
  Qed.

  Program Definition term_homomorphism_inject_right
    (t1 t2: term)
  :
    term_homomorphism t2 (t1 + t2)
  := {|
    term_homomorphism_automaton_homomorphism := {|
      automaton_homomorphism_f d := TPlusRight _ d;
    |};
  |}.
  Next Obligation.
    now constructor.
  Qed.

  Equations term_homomorphism_distribute_left_f
    {t1 t2 t3: term}
    (d: derivative (t1 ;; t3 + t2 ;; t3))
    : derivative ((t1 + t2) ;; t3)
  := {
    term_homomorphism_distribute_left_f (TPlusLeft _ (TTimesPre _ d)) :=
      TTimesPre _ (TPlusLeft _ d);
    term_homomorphism_distribute_left_f (TPlusLeft _ (TTimesPost _ d)) :=
      TTimesPost _ d;
    term_homomorphism_distribute_left_f (TPlusRight _ (TTimesPre _ d)) :=
      TTimesPre _ (TPlusRight _ d);
    term_homomorphism_distribute_left_f (TPlusRight _ (TTimesPost _ d)) :=
      TTimesPost _ d;
  }.

  Program Definition term_homomorphism_distribute_left
    (t1 t2 t3: term)
  :
    term_homomorphism (t1 ;; t3 + t2 ;; t3) ((t1 + t2) ;; t3)
  := {|
    term_homomorphism_automaton_homomorphism := {|
      automaton_homomorphism_f := term_homomorphism_distribute_left_f;
    |};
  |}.
  Next Obligation.
    apply derive_dec in H0.
    apply derive_dec.
    dependent destruction H0.
    - dependent destruction H0;
      autorewrite with term_homomorphism_distribute_left_f.
      + now repeat constructor.
      + apply DeriveTimesJump with (i := i); auto.
        now constructor.
      + now constructor.
    - dependent destruction H0;
      autorewrite with term_homomorphism_distribute_left_f.
      + now repeat constructor.
      + apply DeriveTimesJump with (i := i); auto.
        now constructor.
      + now constructor.
  Qed.
  Next Obligation.
    apply nullable_dec.
    apply nullable_dec in H0.
    dependent destruction H0.
    - dependent destruction H0;
      autorewrite with term_homomorphism_distribute_left_f.
      + apply NullableTimesPre with (d2 := d2); auto.
        now constructor.
      + now constructor.
    - dependent destruction H0;
      autorewrite with term_homomorphism_distribute_left_f.
      + apply NullableTimesPre with (d2 := d2); auto.
        now constructor.
      + now constructor.
  Qed.
  Next Obligation.
    dependent destruction H0.
    - dependent destruction H0;
      autorewrite with term_homomorphism_distribute_left_f.
      now repeat constructor.
    - dependent destruction H0;
      autorewrite with term_homomorphism_distribute_left_f.
      now repeat constructor.
  Qed.

  Equations term_homomorphism_fold_f
    {t: term}
    (d: derivative (t ;; t*))
    : derivative (t*)
  := {
    term_homomorphism_fold_f (TTimesPre _ d) := TStarInner _ d;
    term_homomorphism_fold_f (TTimesPost _ (TStarInner _ d)) := TStarInner _ d;
    term_homomorphism_fold_f (TTimesPost _ (TStarOne _)) := TStarOne _;
  }.

  Program Definition term_homomorphism_fold
    (t: term)
  :
    term_homomorphism (t ;; t*) (t*)
  := {|
    term_homomorphism_automaton_homomorphism := {|
      automaton_homomorphism_f := term_homomorphism_fold_f;
    |};
  |}.
  Next Obligation.
    apply derive_dec.
    apply derive_dec in H0.
    dependent destruction H0.
    - autorewrite with term_homomorphism_fold_f.
      now constructor.
    - dependent destruction H2;
      autorewrite with term_homomorphism_fold_f.
      + dependent destruction H1.
        now apply DeriveStarInnerJump with (i := d0).
      + dependent destruction H1.
        now apply DeriveStarInnerJump with (i := i0).
    - dependent destruction H0;
      autorewrite with term_homomorphism_fold_f.
      + now constructor.
      + now apply DeriveStarInnerJump with (i := i).
  Qed.
  Next Obligation.
    apply nullable_dec.
    apply nullable_dec in H0.
    dependent destruction H0.
    - autorewrite with term_homomorphism_fold_f.
      now constructor.
    - dependent destruction H0;
      autorewrite with term_homomorphism_fold_f.
      + now constructor.
      + constructor.
  Qed.
  Next Obligation.
    dependent destruction H0.
    autorewrite with term_homomorphism_fold_f.
    now constructor.
  Qed.

  Equations term_homomorphism_times_f
    {t1 t2 t3 t4: term}
    (h1: term_homomorphism t1 t2)
    (h2: term_homomorphism t3 t4)
    (d: derivative (t1 ;; t3))
  :
    derivative (t2 ;; t4)
  := {
    term_homomorphism_times_f h1 h2 (TTimesPre _ d) := TTimesPre _ (h1 d);
    term_homomorphism_times_f h1 h2 (TTimesPost _ d) := TTimesPost _ (h2 d);
  }.

  Program Definition term_homomorphism_times
    {t1 t2 t3 t4: term}
    (h1: term_homomorphism t1 t2)
    (h2: term_homomorphism t3 t4)
  :
    term_homomorphism (t1 ;; t3) (t2 ;; t4)
  := {|
    term_homomorphism_automaton_homomorphism := {|
      automaton_homomorphism_f := term_homomorphism_times_f h1 h2;
    |};
  |}.
  Next Obligation.
    destruct h1 as [h1a h1i].
    destruct h2 as [h2a h2i].
    apply derive_dec.
    apply derive_dec in H0.
    dependent destruction H0;
    autorewrite with term_homomorphism_times_f;
    simpl.
    - constructor.
      apply derive_dec.
      apply h1a; simpl.
      now apply derive_dec.
    - apply DeriveTimesJump with (i := h2a i); simpl.
      + apply nullable_dec.
        apply h1a; simpl.
        now apply nullable_dec.
      + now apply h2i.
      + apply derive_dec.
        apply h2a; simpl.
        now apply derive_dec.
    - constructor.
      apply derive_dec.
      apply h2a; simpl.
      now apply derive_dec.
  Qed.
  Next Obligation.
    destruct h1 as [h1a h1i].
    destruct h2 as [h2a h2i].
    apply nullable_dec.
    apply nullable_dec in H0.
    dependent destruction H0;
    autorewrite with term_homomorphism_times_f;
    simpl.
    - eapply NullableTimesPre with (d2 := h2a d2).
      + apply nullable_dec.
        apply h1a; simpl.
        now apply nullable_dec.
      + apply nullable_dec.
        apply h2a; simpl.
        now apply nullable_dec.
      + now apply h2i.
    - constructor.
      apply nullable_dec.
      apply h2a; simpl.
      now apply nullable_dec.
  Qed.
  Next Obligation.
    dependent destruction H0.
    autorewrite with term_homomorphism_times_f.
    constructor.
    now apply h1.
  Qed.

  Program Definition term_homomorphism_identity
    (t: term)
  :
    term_homomorphism t t
  := {|
    term_homomorphism_automaton_homomorphism := {|
      automaton_homomorphism_f := id;
    |};
  |}.

  Program Definition term_homomorphism_skip
    (t: term)
  :
    term_homomorphism 1 (t*)
  := {|
    term_homomorphism_automaton_homomorphism := {|
      automaton_homomorphism_f _ := TStarOne _;
    |};
  |}.
  Next Obligation.
    apply derive_dec in H0.
    dependent destruction H0.
  Qed.
  Next Obligation.
    constructor.
  Qed.
End AntimirovMorphisms.

Section AntimirovSolution.
  Context {A: Type}.
  Context `{Finite A}.
  Notation term := (term A).
  Notation derivative := (derivative A).
  Notation nullable := (nullable A).
  Notation initial := (initial A).
  Notation vector := (vector A).

  Definition antimirov_solution (t: term): vector (derivative t) :=
    compute_automaton_solution (automaton_antimirov t)
  .

  Definition term_roundtrip (t: term) : term :=
    sum (map (antimirov_solution t) (initial_l t))
  .

  Lemma antimirov_solution_upper_bound (t: term):
    antimirov_solution t <== derivative_write
  .
  Proof.
    unfold antimirov_solution.
    intro d.
    rewrite <- ETimesUnitRight with (t := compute_automaton_solution _ _).
    apply compute_automaton_solution_least_solution.
    split; intros.
    - simpl in H0.
      apply derive_dec in H0.
      dependent induction t;
      dependent destruction q1;
      dependent destruction q2;
      dependent destruction H0;
      autorewrite with derivative_write.
      + rewrite ETimesUnitRight.
        apply term_lequiv_refl.
      + now apply IHt1.
      + now apply IHt2.
      + rewrite ETimesAssoc.
        apply times_mor_mono; auto.
        * now apply IHt1.
        * apply term_lequiv_refl.
      + eapply term_lequiv_trans.
        * now apply IHt2 with (q1 := i).
        * rewrite <- ETimesUnitLeft with (t := derivative_write i).
          apply times_mor_mono.
          -- now apply nullable_one.
          -- now apply initial_cover.
      + now apply IHt2.
      + rewrite ETimesAssoc.
        apply times_mor_mono.
        * now apply IHt.
        * apply term_lequiv_refl.
      + eapply term_lequiv_trans with (t2 := t*).
        * rewrite ETimesAssoc.
          rewrite EStarLeft at 2.
          rewrite EStarLeft at 3.
          apply term_lequiv_split_left.
          apply times_mor_mono.
          -- eapply term_lequiv_trans.
             ++ now apply IHt with (q1 := i).
             ++ now apply initial_cover.
          -- apply term_lequiv_refl.
        * rewrite <- ETimesUnitLeft with (t := t*).
          apply times_mor_mono.
          -- now apply nullable_one.
          -- now rewrite <- ETimesUnitLeft with (t := t*) at 1.
    - simpl in H0.
      apply nullable_one.
      now apply nullable_dec.
  Qed.

  Lemma term_roundtrip_upper_bound (t: term):
     term_roundtrip t <= t
  .
  Proof.
    unfold term_roundtrip.
    apply sum_lequiv_all; intros.
    apply in_map_iff in H0.
    destruct H0 as [d [? ?]].
    subst.
    eapply term_lequiv_trans.
    - apply antimirov_solution_upper_bound.
    - apply initial_cover.
      now apply initial_list.
  Qed.

  Lemma antimirov_solution_homomorphism
    (t1 t2: term)
    (h: automaton_homomorphism (automaton_antimirov t1) (automaton_antimirov t2))
  :
    antimirov_solution t1 <== antimirov_solution t2 ∘ h
  .
  Proof.
    unfold antimirov_solution.
    intro.
    rewrite <- ETimesUnitRight with (t := compute_automaton_solution _ _).
    apply compute_automaton_solution_least_solution.
    apply automaton_homomorphism_solution.
    apply automaton_solution_invariant.
    apply compute_automaton_solution_least_solution.
  Qed.

  Lemma term_roundtrip_homomorphism
    (t1 t2: term) (h: term_homomorphism t1 t2)
  :
    term_roundtrip t1 <= term_roundtrip t2
  .
  Proof.
    unfold term_roundtrip.
    apply sum_lequiv_all; intros.
    apply in_map_iff in H0.
    destruct H0 as [d [? ?]]; subst.
    apply term_lequiv_trans with (t2 := antimirov_solution t2 (h d)).
    - apply antimirov_solution_homomorphism.
    - apply sum_lequiv_member.
      apply in_map_iff.
      eexists; split; auto.
      apply initial_list, h.
      now apply initial_list.
  Qed.

  Lemma term_roundtrip_assoc (t1 t2 t3: term):
    term_roundtrip (t1 ;; (t2 ;; t3)) <= term_roundtrip ((t1 ;; t2) ;; t3)
  .
  Proof.
    apply term_roundtrip_homomorphism.
    apply term_homomorphism_assoc.
  Qed.

  Lemma term_roundtrip_roll (t: term):
    term_roundtrip (t ;; t* + 1) <= term_roundtrip (t*)
  .
  Proof.
    apply term_roundtrip_homomorphism.
    apply term_homomorphism_roll.
  Qed.

  Equations term_translate_unit_right
    {t: term}
    (s: vector (derivative t))
    (d: derivative (t ;; 1))
  :
    term
  := {
    term_translate_unit_right s (TTimesPre _ d) := s d;
    term_translate_unit_right s (TTimesPost _ TOneOne) := 1;
  }.

  Lemma term_roundtrip_unit_right (t: term):
    term_roundtrip (t ;; 1) <= term_roundtrip t
  .
  Proof.
    unfold term_roundtrip.
    apply sum_lequiv_all; intros.
    apply in_map_iff in H0.
    destruct H0 as [d [? ?]]; subst.
    dependent destruction d.
    - apply term_lequiv_trans with (t2 := antimirov_solution t d).
      + clear H1.
        replace (antimirov_solution t d)
          with (term_translate_unit_right (antimirov_solution t) (TTimesPre _ d))
          by reflexivity.
        rewrite <- ETimesUnitRight with (t := antimirov_solution _ _).
        apply compute_automaton_solution_least_solution.
        split; intros.
        * simpl in H0.
          apply derive_dec in H0.
          dependent destruction H0.
          -- autorewrite with term_translate_unit_right.
             rewrite <- ETimesUnitRight with (t := antimirov_solution t d12).
             rewrite <- ETimesUnitRight with (t := antimirov_solution t d11).
             apply compute_automaton_solution_least_solution; auto.
             simpl; now apply derive_dec.
          -- dependent destruction H2.
          -- dependent destruction H0.
        * simpl in H0.
          apply nullable_dec in H0.
          dependent destruction H0.
          -- autorewrite with term_translate_unit_right.
             rewrite <- ETimesUnitRight with (t := antimirov_solution t d1).
             apply compute_automaton_solution_least_solution; auto.
             simpl; now apply nullable_dec.
          -- dependent destruction d2.
             autorewrite with term_translate_unit_right.
             apply term_lequiv_refl.
      + apply sum_lequiv_member.
        apply in_map_iff.
        exists d; split; auto.
        apply initial_list in H1.
        apply initial_list.
        now dependent destruction H1.
    - apply initial_list in H1.
      dependent destruction H1.
  Qed.

  Lemma term_roundtrip_sum_split_left (t1 t2: term):
    term_roundtrip t1 <= term_roundtrip (t1 + t2)
  .
  Proof.
    apply term_roundtrip_homomorphism.
    apply term_homomorphism_inject_left.
  Qed.

  Lemma term_roundtrip_sum_split_right (t1 t2: term):
    term_roundtrip t2 <= term_roundtrip (t1 + t2)
  .
  Proof.
    apply term_roundtrip_homomorphism.
    apply term_homomorphism_inject_right.
  Qed.

  Lemma term_roundtrip_distribute_left (t1 t2 t3: term):
    term_roundtrip (t1 ;; t3 + t2 ;; t3) <= term_roundtrip ((t1 + t2) ;; t3)
  .
  Proof.
    apply term_roundtrip_homomorphism.
    apply term_homomorphism_distribute_left.
  Qed.

  Lemma antimirov_solution_link
    (t1 t2: term)
    (d1: derivative t1)
    (d2: derivative t2)
  :
    nullable d1 ->
    initial d2 ->
    antimirov_solution (t1 ;; t2) (TTimesPost _ d2) <=
    antimirov_solution (t1 ;; t2) (TTimesPre _ d1)
  .
  Proof.
    intros.
    rewrite automaton_solution_least_converse
      with (aut := automaton_antimirov (t1 ;; t2))
    by (apply automaton_least_solution_invariant;
        apply compute_automaton_solution_least_solution).
    rewrite automaton_solution_least_converse
      with (aut := automaton_antimirov (t1 ;; t2)) (q := (TTimesPre t2 d1))
      by (apply automaton_least_solution_invariant;
          apply compute_automaton_solution_least_solution).
    apply term_lequiv_split.
    - apply term_lequiv_split_left.
      simpl.
      destruct (nullable_b _) eqn:?.
      + simpl in Heqb.
        apply nullable_dec in Heqb.
        dependent destruction Heqb.
        assert (nullable_b (TTimesPre t2 d1) = true).
        * apply nullable_dec.
          now apply NullableTimesPre with (d2 := d2).
        * simpl.
          rewrite H2.
          apply term_lequiv_refl.
      + apply term_lequiv_zero.
    - apply sum_lequiv_all; intros.
      apply in_map_iff in H2.
      destruct H2 as [d3 [? ?]].
      subst.
      apply sum_lequiv_all; intros.
      apply in_map_iff in H2.
      destruct H2 as [a [? ?]].
      subst.
      apply term_lequiv_split_right.
      simpl.
      destruct (derive_b _ _ _) eqn:?.
      + apply derive_dec in Heqb.
        eapply term_lequiv_trans; swap 1 2.
        * apply sum_lequiv_member.
          apply in_map_iff.
          exists d3.
          split; auto.
        * apply sum_lequiv_member.
          apply in_map_iff.
          exists a.
          assert (derive_b a (TTimesPre t2 d1) d3 = true).
          -- apply derive_dec.
             dependent destruction Heqb.
             now apply DeriveTimesJump with (i := d2).
          -- now rewrite H2.
      + apply term_lequiv_zero.
  Qed.

  Program Definition automaton_homomorphism_prepend
    (t1 t2: term)
  :
    automaton_homomorphism (automaton_antimirov t2)
                           (automaton_antimirov (t1 ;; t2))
  := {|
    automaton_homomorphism_f d := TTimesPost _ d;
  |}.

  Lemma antimirov_solution_prepend (t1 t2: term) (d: derivative t2):
    antimirov_solution t2 d <= antimirov_solution (t1 ;; t2) (TTimesPost _ d)
  .
  Proof.
    apply antimirov_solution_homomorphism
      with (h := automaton_homomorphism_prepend t1 t2).
  Qed.

  Lemma term_roundtrip_shift_unit (t: term):
    1 ;; term_roundtrip t <= term_roundtrip (1 ;; t)
  .
  Proof.
    rewrite ETimesUnitLeft.
    unfold term_roundtrip.
    apply sum_lequiv_all; intros.
    apply in_map_iff in H0.
    destruct H0 as [d [? ?]]; subst.
    autorewrite with initial_l.
    rewrite map_map; simpl.
    autorewrite with sum.
    repeat rewrite EPlusUnit.
    apply term_lequiv_trans
      with (t2 := antimirov_solution (1 ;; t) (TTimesPost _ d)).
    - apply antimirov_solution_prepend.
    - apply antimirov_solution_link.
      + constructor.
      + now apply initial_list.
  Qed.

  Lemma term_roundtrip_shift_letter (a: A) (t: term):
    $a ;; term_roundtrip t <= term_roundtrip ($a ;; t)
  .
  Proof.
    unfold term_roundtrip.
    rewrite <- sum_distribute_left.
    apply sum_lequiv_all; intros.
    rewrite map_map in H0.
    apply in_map_iff in H0.
    destruct H0 as [d [? ?]]; subst.
    autorewrite with initial_l.
    rewrite map_map; simpl.
    autorewrite with sum.
    repeat rewrite EPlusUnit.
    apply term_lequiv_trans
      with (t2 := $a ;; antimirov_solution ($a ;; t) (TTimesPre _ TLetterOne)).
    - apply times_mor_mono.
      + apply term_lequiv_refl.
      + unfold term_lequiv.
        apply term_lequiv_trans
          with (t2 := antimirov_solution ($a ;; t) (TTimesPost _ d)).
        * apply antimirov_solution_prepend.
        * apply antimirov_solution_link.
          -- constructor.
          -- now apply initial_list.
    - rewrite <- ETimesUnitRight
        with (t := antimirov_solution _ (TTimesPre _ TLetterOne)).
      rewrite <- ETimesUnitRight
        with (t := antimirov_solution _ (TTimesPre _ (TLetterLetter _))).
      apply compute_automaton_solution_least_solution; simpl.
      apply derive_dec.
      now repeat constructor.
  Qed.

  Lemma term_roundtrip_fold (t: term):
    term_roundtrip (t ;; t*) <= term_roundtrip (t*)
  .
  Proof.
    apply term_roundtrip_homomorphism.
    apply term_homomorphism_fold.
  Qed.

  Lemma term_roundtrip_times (t1 t2 t3 t4: term):
    term_homomorphism t1 t2 ->
    term_homomorphism t3 t4 ->
    term_roundtrip (t1 ;; t3) <= term_roundtrip (t2 ;; t4)
  .
  Proof.
    intros.
    apply term_roundtrip_homomorphism.
    now apply term_homomorphism_times.
  Qed.

  Lemma term_roundtrip_nullable (t: term) (d: derivative t):
    initial d ->
    nullable d ->
    1 <= term_roundtrip t
  .
  Proof.
    intros.
    unfold term_roundtrip.
    apply term_lequiv_trans with (t2 := antimirov_solution t d).
    - rewrite <- ETimesUnitRight with (t := antimirov_solution t d).
      apply compute_automaton_solution_least_solution; auto.
      now apply nullable_dec.
    - apply sum_lequiv_member.
      apply in_map_iff.
      eexists; split; auto.
      now apply initial_list.
  Qed.

  Lemma term_roundtrip_shift (t1 t2: term):
    t1 ;; term_roundtrip t2 <= term_roundtrip (t1 ;; t2)
  .
  Proof.
    revert t2; induction t1; intros.
    - rewrite ETimesZeroRight.
      apply term_lequiv_zero.
    - apply term_roundtrip_shift_unit.
    - apply term_roundtrip_shift_letter.
    - rewrite EDistributeRight.
      apply term_lequiv_trans
        with (t2 := term_roundtrip (t1_1 ;; t2 + t1_2 ;; t2)).
      + apply term_lequiv_split.
        * eapply term_lequiv_trans.
          -- apply IHt1_1.
          -- apply term_roundtrip_sum_split_left.
        * eapply term_lequiv_trans.
          -- apply IHt1_2.
          -- apply term_roundtrip_sum_split_right.
      + apply term_roundtrip_distribute_left.
    - eapply term_lequiv_trans.
      + rewrite <- ETimesAssoc.
        apply times_mor_mono.
        * apply term_lequiv_refl.
        * apply IHt1_2.
      + eapply term_lequiv_trans.
        * apply IHt1_1.
        * apply term_roundtrip_assoc.
    - apply EFixLeft.
      apply term_lequiv_split.
      + eapply term_lequiv_trans.
        * apply IHt1.
        * apply term_lequiv_trans
            with (t2 := term_roundtrip ((t1 ;; t1*) ;; t2)).
          -- apply term_roundtrip_assoc.
          -- apply term_roundtrip_times.
             ++ apply term_homomorphism_fold.
             ++ apply term_homomorphism_identity.
      + rewrite <- ETimesUnitLeft with (t := term_roundtrip t2).
        eapply term_lequiv_trans.
        apply term_roundtrip_shift_unit.
        apply term_roundtrip_times.
        * apply term_homomorphism_skip.
        * apply term_homomorphism_identity.
  Qed.

  Lemma term_roundtrip_one_lower:
    1 <= term_roundtrip 1
  .
  Proof.
    unfold term_roundtrip.
    eapply term_lequiv_trans with (t2 := antimirov_solution 1 TOneOne).
    - unfold antimirov_solution.
      rewrite <- ETimesUnitRight with (t := compute_automaton_solution _ _).
      apply compute_automaton_solution_least_solution.
      simpl.
      apply nullable_dec.
      constructor.
    - apply sum_lequiv_member.
      apply in_map_iff.
      eexists; split; auto.
      apply initial_list.
      constructor.
  Qed.

  Lemma term_roundtrip_lower_bound (t: term):
    t <= term_roundtrip t
  .
  Proof.
    rewrite <- ETimesUnitRight with (t := t) at 1.
    eapply term_lequiv_trans.
    - apply times_mor_mono.
      + apply term_lequiv_refl.
      + apply term_roundtrip_one_lower.
    - eapply term_lequiv_trans.
      + apply term_roundtrip_shift.
      + apply term_roundtrip_unit_right.
  Qed.

  Lemma term_roundtrip_invariant (t: term):
    t == term_roundtrip t
  .
  Proof.
    apply term_lequiv_squeeze.
    - apply term_roundtrip_lower_bound.
    - apply term_roundtrip_upper_bound.
  Qed.
End AntimirovSolution.


Require Import proofsystem.

(* A very simple example of the proof system, showing that
   the system over pairs of natural numbers where the
   steps decrement one side or the other reach zero *)

Definition cfg := prod nat nat.
Inductive step : cfg -> cfg -> Prop :=
  | stepl : forall n m, step (S n, m) (n, m)
  | stepr : forall n m, step (n, S m) (n, m)
.

CoInductive allreach (gamma : cfg) (phi : cfg -> Prop) : Prop :=
  | reach_here : phi gamma -> allreach gamma phi
  | reach_next : (exists gamma', step gamma gamma') ->
                 (forall gamma', step gamma gamma' ->
                                 allreach gamma' phi) ->
                 allreach gamma phi.

Require Import Arith.
Definition cfg_dec : forall (c c' : cfg), {c=c'}+{c<>c'}.
destruct c.
destruct c'.
destruct (eq_nat_dec n n1);[|right;congruence].
destruct (eq_nat_dec n0 n2);[|right;congruence].
left. congruence.
Qed.

Lemma steps_nonzeros : forall cfg, (0,0) <> cfg -> exists cfg', step cfg cfg'.
destruct cfg0.
destruct n;[destruct n0;[congruence|]|];(eexists;constructor).
Qed.

Lemma semantic_reach_zero : forall cfg, allreach cfg (eq (0,0)).
cofix.
intro. destruct (cfg_dec (0,0) cfg0);
constructor (solve[auto using steps_nonzeros]).
Qed.

Definition empty_system : forall {cfg}, system cfg :=
  fun _ _ _ _ => False.

Definition is_conseq_l : forall cfg Step C A (env : Type)
                (phi1 phi1' phi2 : formula cfg env),
                (forall (e : env) (g : cfg), phi1 e g -> phi1' e g) ->
                IS cfg Step C A env phi1' phi2 ->
                IS cfg Step C A env phi1 phi2.
intros. eapply is_conseq;eauto.
Defined.

Lemma split_case : forall circ ax (env : Type)
                (phi1 check phi2 : formula cfg env),

                  (forall g e, check g e \/ ~check g e) ->
                IS cfg step circ ax env (fun env cfg => check env cfg /\ phi1 env cfg) phi2 ->
                IS cfg step circ ax env (fun env cfg => (~ check env cfg) /\ phi1 env cfg) phi2 ->
                IS cfg step circ ax env phi1 phi2.
intros.
apply is_conseq_l with
  (phi1' := fun env cfg =>
            (check env cfg /\ phi1 env cfg) \/ (~check env cfg /\ phi1 env cfg))
;[clear -H;firstorder |apply is_case;assumption].
Qed.
Lemma proof_reach_zero : IS _ step None empty_system cfg
   (fun env cfg => cfg = env) (fun env cfg => cfg = (0,0)).
Proof.
apply split_case with (check := (fun env _ => env = (0,0))).
intros. destruct (cfg_dec g (0,0)); solve[auto].

eapply is_conseq_l;[|apply is_refl].
intros; intuition congruence.

(* nonzero case *)

(* incomplete *)
Admitted.


Inductive iszero : nat -> Prop :=
| iszero_0 : iszero 0
| iszero_S : forall n, iszero (S n) -> iszero n.

Definition task := forall n, iszero n <-> n = 0.


Require Import UniMath.Foundations.PartA.
Require Import UniMath.Algebra.Monoids_and_Groups.
Require Import UniMath.Combinatorics.Lists.
Require Import UniMath.Ktheory.GroupAction.

Require Import MoreLists.
Require Import PermLists.

Section PermutationGroup.
  Variable (A : UU)
           (isasetA : isaset A).

  Definition perm_op : setwithbinop.
  Proof.
    unfold setwithbinop.
    use tpair.
    - use tpair.
      + exact (weq A A).
      + simpl.
        apply isasetweqtoset.
        exact isasetA.
    - simpl.
      intros g f.
      apply (weqcomp f g).
  Defined.

  Definition perm_group : gr.
  Proof.
    unfold gr.
    exists perm_op.
    use tpair.
    - unfold ismonoidop.
      use tpair.
      + intros f g h.
        use pair_path_in2.
        apply isapropisweq.
      + simpl.
        unfold isunital, isunit, islunit, isrunit.
        exists (idweq A).
        use tpair.
        * simpl.
          intros f.
          induction f as [f wef].
          use pair_path_in2.
          apply isapropisweq.
        * simpl.
          intros f.
          induction f as [f wef].
          use pair_path_in2.
          apply isapropisweq.
    - use tpair.
      + simpl.
        apply invweq.
      + use tpair.
        * intros f.
          unfold unel_is.
          simpl.
          use total2_paths2_f.
          -- apply funextfun.
             intros z.
             apply homotinvweqweq.
          -- apply isapropisweq.
        * intros f.
          unfold unel_is.
          simpl.
          use total2_paths2_f.
          -- apply funextfun.
             intros z.
             apply homotweqinvweq.
          -- apply isapropisweq.
  Defined.
End PermutationGroup.

Section FinitePermutations.
  Context  {A : hSet}
           (dec_A : isdeceq A).

  Definition isasetA : isaset A.
  Proof.
    use isasetifdeceq.
    assumption.
  Defined.

  Definition finite_perms : hsubtype (perm_group A isasetA).
  Proof.
    intros w.
    use hexists.
    - apply (@swap_list A).
    - intros s.
      exact (w = swap_list_to_weq dec_A s).
  Defined.

  Definition is_sub_gr_finite_perms : issubgr finite_perms.
  Proof.
    use tpair.
    - use tpair.
      + intros f1 f2.
        induction f1 as [w1 l1'].
        induction f2 as [w2 l2'].
        unfold finite_perms in *.
        apply (Propositions.squash_to_hProp l1').
        intro l1.
        apply (Propositions.squash_to_hProp l2').
        intro l2.
        apply total2tohexists ; cbn.
        clear l1' l2'.
        induction l1 as [l1 p1].
        induction l2 as [l2 p2].
        rewrite p1, p2. clear p1. clear p2.
        use tpair.
        * exact (concatenate l1 l2).
        * cbn.
          apply swap_list_to_weq_concat.
      + cbn.
        apply total2tohexists.
        use tpair.
        * exact nil.
        * reflexivity.
    - intros w.
      induction w as [w we].
      intros l'.
      unfold finite_perms in *.
      apply (Propositions.squash_to_hProp l').
      intro l. clear l'.
      induction l as [l p].
      rewrite p. clear p.
      apply total2tohexists ; cbn.
      now apply weq_inverse_list.
  Defined.
End FinitePermutations.

(*
Section GroupAction.
  Definition action (A : UU) (G : gr) : UU.
  Proof.
    use (∑ (f : G -> A -> A), _ × _).
    - exact (forall (a : A), f (unel G) a = a).
    - exact (forall (g1 g2 : G) (a : A), f (op g1 g2) a = f g1 (f g2 a)).
  Defined.

  Definition mult_action (G : gr) : action G G.
  Proof.
    exists op.
    split ; [ apply lunax | apply assocax ].
  Defined.
End GroupAction.
*)

Definition finite_perm_gr : gr.
Proof.
  use carrierofasubgr.
  apply (perm_group nat isasetnat).
  unfold subgr.
  exists (@finite_perms natset isdeceqnat).
  exact (@is_sub_gr_finite_perms natset isdeceqnat).
Defined.

Definition app_action : ActionStructure finite_perm_gr natset.
Proof.
  use make.
  - intros f n.
    apply (pr1 (pr1 f) n).
  - simpl.
    apply idpath.
  - intros f1 f2 n.
    induction f1 as [f1 p1].
    induction f2 as [f2 p2].
    simpl.
    apply idpath.
Defined.

Definition member {A : UU} (deceqA : isdeceq A) : A -> list A -> bool.
Proof.
  intros a.
  use list_ind.
  - apply false.
  - simpl ; intros x xs IH.
    induction (deceqA a x).
    + apply true.
    + apply IH.
Defined.

Definition nominal_set : UU.
Proof.
  use (∑ (X : hSet) (f : ActionStructure finite_perm_gr X), ∀ (x : X),
          hexists (fun l : list nat => _)).
  induction f as [f p].
  use (∀ (π : finite_perm_gr), _).
  use himpl.
  - use (∀ (n : nat), _).
    use himpl.
    + use eqset.
      * exact boolset.
      * exact (member isdeceqnat n l).
      * exact true.
    + unfold finite_perm_gr in π.
      use eqset.
      * exact natset.
      * exact (pr1 (pr1 π) n).
      * exact n.
  - use eqset ; [ apply X | apply (f π x) | apply x].
Defined.

Definition nat_nominal_set : nominal_set.
Proof.
  unfold nominal_set.
  exists natset.
  use tpair.
  - apply app_action.
  - simpl.
    intros n.
    apply total2tohexists.
    exists (cons n nil).
    intros x H.
    apply (H n).
    cbn.
    destruct (isdeceqnat n n).
    + simpl.
      reflexivity.
    + use fromempty.
      apply n0.
      apply idpath.
Defined.


Theorem first : (forall A : Prop, A -> A).
Proof.
  intros A.
  intros proof_of_A.
  exact proof_of_A.
Qed.


Require Import Coq.Classes.Morphisms. Require Coq.Setoids.Setoid Crypto.Util.Relations.
Require Import Crypto.Algebra Crypto.Algebra.Ring Crypto.Algebra.Field.
Require Import Crypto.Util.Notations Crypto.Util.Decidable Crypto.Util.Tactics.
Require Import Coq.PArith.BinPos.

Section Edwards.
  Context {F eq zero one opp add sub mul inv div}
          {field:@Algebra.field F eq zero one opp add sub mul inv div}
          {eq_dec:DecidableRel eq}.

  Local Infix "=" := eq. Local Notation "a <> b" := (not (a = b)).
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Notation "0" := zero.  Local Notation "1" := one.
  Local Infix "+" := add. Local Infix "*" := mul.
  Local Infix "-" := sub. Local Infix "/" := div.
  Local Notation "x ^ 2" := (x*x).

  Context (a:F) (a_nonzero : a<>0) (a_square : exists sqrt_a, sqrt_a^2 = a).
  Context (d:F) (d_nonsquare : forall sqrt_d, sqrt_d^2 <> d).
  Context {char_ge_3:@Ring.char_ge F eq zero one opp add sub mul 3}.

  Local Notation onCurve x y := (a*x^2 + y^2 = 1 + d*x^2*y^2) (only parsing).
  Lemma onCurve_zero : onCurve 0 1. fsatz. Qed.

  Section Addition.
    Context (x1 y1:F) (P1onCurve: onCurve x1 y1).
    Context (x2 y2:F) (P2onCurve: onCurve x2 y2).
    Lemma denominator_nonzero : (d*x1*x2*y1*y2)^2 <> 1.
    Proof.
      destruct a_square as [sqrt_a], (dec(sqrt_a*x2+y2 = 0)), (dec(sqrt_a*x2-y2 = 0));
        try match goal with [H: ?f (sqrt_a * x2) y2 <> 0 |- _ ]
            => pose proof (d_nonsquare ((f (sqrt_a * x1) (d * x1 * x2 * y1 * y2 * y1))
                                       /(f (sqrt_a * x2) y2     *   x1 * y1        )))
            end; Field.fsatz.
    Qed.

    Lemma denominator_nonzero_x : 1 + d*x1*x2*y1*y2 <> 0.
    Proof. pose proof denominator_nonzero. Field.fsatz. Qed.
    Lemma denominator_nonzero_y : 1 - d*x1*x2*y1*y2 <> 0.
    Proof. pose proof denominator_nonzero. Field.fsatz. Qed.
    Lemma onCurve_add : onCurve ((x1*y2  +  y1*x2)/(1 + d*x1*x2*y1*y2)) ((y1*y2 - a*x1*x2)/(1 - d*x1*x2*y1*y2)).
    Proof. pose proof denominator_nonzero. Field.fsatz. Qed.
  End Addition.
End Edwards.


(**
「コンピュータの数学」合同関係の公式の証明（自然数版）
======

2020_10_24 @suharahiromichi
 *)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Modulo.
(**
Knuth先生の「コンピュータの数学」[1][2] の「4.6 合同関係」に掲載されているの公式の証明をしてみます。
ただし、被除数と除数は自然数に限定します。
また、式の番号は[2]にあわせ、「」の中は[2]からの引用です。

このソースコードは、以下にあります。

https://github.com/suharahiromichi/coq/blob/master/gkp/gkp_4_6_modulo.v

変数名 m n p q d d1 d2 の使い方は、MathComp の div.v [3]
にあわせて、被除数を``m``と``n``、除数を``d``としています。
これは、[1][2]とは異なるので注意してください。
*)

(**
# 合同式の加算

「合同な要素を足しても、合同関係は崩れない。」

$$ m = n \pmod{d} \Longrightarrow
   p = q \pmod{d} \Longrightarrow
   m + p = n + q \pmod{d} $$
 *)
  Lemma m_addn m n p q d  :
    m = n %[mod d] -> p = q %[mod d] -> m + p = n + q %[mod d].
  Proof.
    move=> Hmp Hnd.
    Check modnDm : forall m n d : nat, m %% d + n %% d = m + n %[mod d].
    rewrite -[LHS]modnDm -[RHS]modnDm.
    (* m %% d + p %% d = n %% d + q %% d %[mod d] *)

    congr (_ %% d).            (* %[mod d] を外す。 *)
    (* m %% d + p %% d = n %% d + q %% d *)

    congr (_ + _).
    (* m %%d = n %% d *)
    - done.
    (* p %%d = q %% d *)
    - done.
  Qed.

(**
``p = q`` である特別な場合について証明しておきます。後で使います。
 *)
  Lemma m_addn' m n p d  :
    m = n %[mod d] -> m + p = n + p %[mod d].
  Proof.
    move=> H.
    by apply: m_addn.
  Qed.

(**
# 合同式の乗算

「掛け算もうまくいく。」

$$ m = n \pmod{d} \Longrightarrow
   p = q \pmod{d} \Longrightarrow
   m p = n q \pmod{d} $$
 *)
  Lemma m_muln m n p q d  :
    m = n %[mod d] -> p = q %[mod d] -> m * p = n * q %[mod d].
  Proof.
    move=> Hmp Hnd.
    Check modnMm : forall m n d : nat, (m %% d) * (n %% d) = m * n %[mod d].
    rewrite -[LHS]modnMm -[RHS]modnMm.

    congr (_ %% d).            (* %[mod d] を外す。 *)
    (* Goal : m %% d * (p %% d) = n %% d * (q %% d) *)
    by congr (_ * _).
  Qed.

(**
``p = q`` である特別な場合について証明しておきます。後で使います。
 *)
  Lemma m_muln' m n p d  :
    m = n %[mod d] -> m * p = n * p %[mod d].
  Proof.
    move=> H.
    by apply: m_muln.
  Qed.

(**
まとめて、線形性が成り立ちます。
*)
  Lemma m_linear m1 n1 m2 n2 p q d  :
    m1 = n1 %[mod d] ->
    m2 = n2 %[mod d] ->
    m1 * p + m2 * q = n1 * p + n2 * q %[mod d].
  Proof.
    move=> H1 H2.
    by apply: m_addn; apply: m_muln'.
  Qed.

(**
# 合同式のべき乗

「掛け算の性質を繰り返し適用すると、べき乗することもできる。」

$$ p = q \pmod{d} \Longrightarrow p^{m} = q^{m} \pmod{d} $$
 *)
  Lemma m_exprn p q m d :
    p = q %[mod d] -> p^m = q^m %[mod d].
  Proof.
    move=> Hpq.
    Check modnXm : forall m d p : nat, (p %% d) ^ m = p ^ m %[mod d].
    rewrite -[LHS]modnXm -[RHS]modnXm.

    congr (_ %% d).           (* %[mod d] を外す。 *)
    (* Goal : (p %% d) ^ m = (q %% d) ^ m *)
    by congr (_ ^ m).
  Qed.

(**
# 合同式の除算（式(4.37)）

「(p と d が)互いに素の場合には、(dを法とする)合同関係のもとでも(pによる)割り算ができる。」

$$ m p = n p \pmod{d} \Longleftrightarrow m = n \pmod{d}, 但し p \perp d $$
*)

(**
あらかじめ補題として、p と d が互いに素のときに、
不定方程式 ``p * p' = d * d' + 1`` に解があることを補題として証明します。
[4]も参照してください。
*)
  Lemma solve_indeterminate_equation (p d : nat) :
    0 < p -> coprime p d ->
    exists (p' d' : nat), p' * p = d' * d + 1.
  Proof.
    rewrite /coprime.
    move=> p_gt0 /eqP Hco.

    Check @egcdnP p d p_gt0 : egcdn_spec p d (egcdn p d).
    case: (@egcdnP p d p_gt0). (* 拡張ユーグリッドの互除法の定義を前提に積む。 *)
    (* egcdn_spec は inductive に定義されているので、条件がひとつでも case が要る。 *)
    (* km * p = kn * d + gcdn p d と kn * gcdn p d < p *)

    move=> p' d' Hdef _.
    exists p', d'.
    rewrite Hco in Hdef.
    done.
  Qed.

(**
説明：[1]の式(4.37) の→を証明します。
 *)
  Lemma m_divn_d_1 m n p d :
    coprime p d -> m * p = n * p %[mod d] -> m = n %[mod d].
  Proof.
    (* p = 0 と 0 < p に場合分けする。 *)
    case: (posnP p).

    (* p = 0 の場合 *)
    - move=> ->.                       (* p = 0 で書き換える。 *)
      rewrite /coprime => /eqP.        (* 前提を gcdn p d = 1 *)
      rewrite gcd0n.                   (* 前提から d = 1 でもある。 *)
      move=> ->.                       (* d = 1 で書き換える。 *)
      by rewrite !modn1.

    (* 0 < p の場合 *)
    - move=> p_gt0 Hco H.
      (* 補題を使って、不定方程式の解を p' と d' とします。 *)
      move: (solve_indeterminate_equation p_gt0 Hco) => [p' [d' Hdef]].

      (* H の 両辺に p' をかける。 *)
      Check @m_muln' (m * p) (n * p) p' d
        : m * p = n * p %[mod d] -> m * p * p' = n * p * p' %[mod d].
      move/(@m_muln' (m * p) (n * p) p' d) in H.
      (* ``H : m * p * p' = n * p * p' %[mod d]`` *)

      (* 不定方程式 Hdef を H に代入して整理する。 *)
      rewrite -2!mulnA -[p * p']mulnC in H.
      rewrite Hdef in H.
      (* p' が p の逆数のような働きをする。 *)
      rewrite 2!mulnDr 2!muln1 2!mulnA 2!modnMDl in H.
      done.
  Qed.

(**
[1]の式(4.37) の←は、掛け算の合同の公式から明らかなので、<->が証明できます。
*)
  Lemma m_divn_d' m n p d :
    coprime p d -> (m * p = n * p %[mod d] <-> m = n %[mod d]).
  Proof.
    move=> Hco.
    split.
    - by apply: m_divn_d_1.                 (* -> *)
    - by apply: m_muln'.                    (* <- *)
  Qed.

(**
MathCompらしく、bool値の同値で証明しておきます。
 *)
  Lemma m_divn_d m n p d :
    coprime p d -> (m * p == n * p %[mod d]) = (m == n %[mod d]).
  Proof.
    move=> Hco.
    apply/idP/idP; move/eqP => H; apply/eqP.
    - by apply: (@m_divn_d_1 _ _ p _).      (* -> *)
    - by apply: m_muln'.                    (* <- *)
  Qed.

(**
# 合同式の除算（式(4.38)、法を割る）

「合同関係で割り算をするもうひとつの方法は、法とする自身も他の数と同じように割ることである。
これは、modの分配則だけに依存している。」

$$ m d_1 = n d_1 \pmod{d_2 d_1} \Longleftrightarrow m = n \pmod{d_2}, 但し 0 \lt d_1 $$
 *)
  Lemma m_divn_dp m n d1 d2 :
    0 < d1 -> (m * d1 == n * d1 %[mod d2 * d1]) = (m == n %[mod d2]).
  Proof.
    move=> Hd1.

    (* 右側の両辺に、d1を掛ける。 d1≠0なので可能である。 *)
    Check @eqn_pmul2r d1 m n Hd1 : (m * d1 == n * d1) = (m == n).
    rewrite -[RHS](eqn_pmul2r Hd1).

    (* 右側： (m %% d2 * d1 == n %% d2 * d1) *)

    (* 右側の両辺に、d1による剰余の分配則を適用する。これも d1≠0なので可能である。 *)
    Check @muln_modl d1 :
      forall m d : nat, 0 < d1 -> (m %% d) * d1 = (m * d1) %% (d * d1).

    rewrite 2!(muln_modl Hd1). (* MathCompの最新版で条件 0 < p 条件が削除されている。 *)
    done.
  Qed.

(**
# 最小公倍数LCMを法とする合同式（式(4.41)）

$$ m = n \pmod{lcm(d_1,d_2)} \Longleftrightarrow \\
   m = n \pmod{d_1} \ かつ\ m = n \pmod{d_2} $$

説明：最小公倍数LCMとdivisibleの関係、ふたつの自然数d1とd2の両方で割りきれることと、
その最小公倍数でも割りきれることは同値です。このこをとを使いやすい補題にしておきます。
 *)
  Lemma lcmn_dvdn d1 d2 m : lcmn d1 d2 %| m -> d1 %| m.
  Proof.
    Check dvdn_lcm d1 d2 m : (lcmn d1 d2 %| m) = (d1 %| m) && (d2 %| m).
    rewrite dvdn_lcm => /andP.
    by case.
  Qed.

  Lemma dvdn_lcmn d1 d2 m : d1 %| m -> d2 %| m -> lcmn d1 d2 %| m.
  Proof.
    rewrite dvdn_lcm => H1 H2.
    apply/andP.
    by split.
  Qed.

(**
次いで、式(4.41)の→の共通部分です。d1とd2の最小公倍数を法として合同なら、
d1を法として合同です。一般性を失わずに ``m ≦ n`` としています。
*)
  Lemma m_divn_lcmn_1_1_1 m n d1 d2 :
    n <= m -> m = n %[mod lcmn d1 d2] -> m = n %[mod d1].
  Proof.
    Check eqn_mod_dvd : forall d m n : nat, n <= m -> (m == n %[mod d]) = (d %| m - n).

    move=> Hnm /eqP H.
    rewrite eqn_mod_dvd in H; last done.
    move/lcmn_dvdn in H.
    (* ``H : d1 %| m - n`` *)

    apply/eqP.
    rewrite eqn_mod_dvd; last done.
    done.
  Qed.

(**
式(4.41)の→の補題で、証明の中核となる部分です。
場合分けしてそれぞれに共通部分を適用します。
*)
  Lemma m_divn_lcm_1_1 m n d1 d2 :
    m = n %[mod lcmn d1 d2] -> m = n %[mod d1].
  Proof.
    move=> H.
    Check (leq_total m n) : (m <= n) || (n <= m).
    case/orP: (leq_total n m) => Hnm.

    (* n <= m である場合 *)
    - by apply: m_divn_lcmn_1_1_1 H.

    (* m <= n である場合 *)
    - apply/esym.               (* 合同式の左辺と右辺を入れ替える。 *)
      move/esym in H.           (* 合同式の左辺と右辺を入れ替える。 *)
      by apply: m_divn_lcmn_1_1_1 H.
  Qed.

(**
式(4.41)の→の証明です。
*)
  Lemma m_divn_lcm_1 m n d1 d2 :
    m = n %[mod lcmn d1 d2] -> m = n %[mod d1] /\ m = n %[mod d2].
  Proof.
    split.
    Check @m_divn_lcm_1_1 m n d1 d2 : m = n %[mod lcmn d1 d2] -> m = n %[mod d1].
    - by apply: m_divn_lcm_1_1 H.
    - rewrite lcmnC in H.
      by apply: m_divn_lcm_1_1 H.
  Qed.

(**
式(4.41)の←の補題です。d1とd2を法として合同なら、d1とd2の最小公倍数を法として合同です。
一般性を失わずに ``n ≦ m`` としています。
*)
  Lemma m_divn_lcm_2_1 m n d1 d2 :
    n <= m -> m = n %[mod d1] -> m = n %[mod d2] -> m = n %[mod lcmn d1 d2].
  Proof.
    move=> Hnm /eqP H1 /eqP H2.
    apply/eqP.

    rewrite eqn_mod_dvd in H1; last done.
    rewrite eqn_mod_dvd in H2; last done.
    rewrite eqn_mod_dvd; last done.

    Check dvdn_lcmn : forall d1 d2 m : nat, d1 %| m -> d2 %| m -> lcmn d1 d2 %| m.
    by apply: dvdn_lcmn.
  Qed.

(**
式(4.41)の←の証明です。
*)
  Lemma m_divn_lcm_2 m n d1 d2 :
    m = n %[mod d1] -> m = n %[mod d2] -> m = n %[mod lcmn d1 d2].
  Proof.
    move=> H1 H2.
    case/orP: (leq_total n m) => Hnm.
    (* n <= m の場合 *)
    - by apply: m_divn_lcm_2_1.       (* 先の補題がそのまま使える。 *)

    (* m <= n の場合 *)
    - apply/esym. (* ゴールと条件の合同式の左辺と右辺を入れ替える。 *)
      move/esym in H1.
      move/esym in H2.
      by apply: m_divn_lcm_2_1.   (* 先の補題が使えるようになった。 *)
  Qed.

(**
式(4.41)の証明です。MathComp風に、bool値の同値の式としました。
*)
  Lemma m_divn_lcm m n d1 d2 :
    (m == n %[mod lcmn d1 d2]) = (m == n %[mod d1]) && (m == n %[mod d2]).
  Proof.
    apply/idP/idP => [/eqP H | /andP [/eqP H1 /eqP H2]].
    - move/m_divn_lcm_1 in H.
      case: H => [H1 H2].
      by apply/andP; split; apply/eqP.
    - apply/eqP.
      by apply: m_divn_lcm_2.
  Qed.

(**
# 中国人の剰余定理の特別な場合（式(4.42)）

d1 と d2 が互いに素のとき、ある数を``d1 * d2``で割って余る数と、d1で割って
余る数と、d2で割って余る数が同じであることを証明します。

$$ m = n \pmod{d_1 d_2} \Longleftrightarrow \\
   m = n \pmod{d_1}\ かつ\ m = n \pmod{d_2}, 但し d_1 \perp d_2 $$

中国人の剰余定理の一般の場合は、これらの剰余が異なっていても成立するので、
その特別な場合であるといえます。``div.v`` の補題 ``chinese_remainder`` と同内容です。
*)

(**
説明：まず補題として、互いに素なら最小公倍数LCMは積であることを証明します。
補題 ``muln_lcm_gcd m n : lcmn m n * gcdn m n = m * n`` を使います。
m と n が互いに素であることから、``gcdn m n = 1`` を代入して gcdn を消します。
*)
  Lemma coprime_lcm d1 d2 : coprime d1 d2 -> lcmn d1 d2 = d1 * d2.
  Proof.
    rewrite /coprime.
    move=> /eqP Hco.
    Check muln_lcm_gcd : forall m n : nat, lcmn m n * gcdn m n = m * n.
    by rewrite -muln_lcm_gcd Hco muln1.
  Qed.

(**
証明したい定理は、補題 coprime_lcm で左側の法の積を lcm に書き換え、
式(4.41) m_divn_lcm を適用することで証明できます。
*)
  Lemma m_chinese_remainder m n d1 d2 :
    coprime d1 d2 ->
    (m == n %[mod d1 * d2]) = (m == n %[mod d1]) && (m == n %[mod d2]).
  Proof.
    move=> Hco.
    rewrite -coprime_lcm; last done.
    by apply: m_divn_lcm.
  Qed.

(**
最後に ProofCafe で教えてもらった別の証明を``chinese_remainder_lite``として記載しておきます。
（なお、一部修正しました）。

eqn_mod_dvd を使って、合同式を整除可能に書き換えたあと、
Gauss_dvd を使って、整除可能の * と && の同値関係で証明をします。
Gauss_dvd の証明には mulm_lcm_gcd を使っています(div.vにて)。

なお、eqn_mod_dvd を使うために ``(m <= n)`` と ``(n <= m)`` の場合分けしています。
これは、前提によらず使用することができますので、覚えておくと便利です。

補足説明：bool式の真偽での場合分け ``case H : (m <= n)`` では、``(m <= n)`` と ``(n < m)``
となり、後者の条件を ``(n <= m)`` に書き換えるには補題 ltnW が必要になります。
*)
  Check eqn_mod_dvd
    : forall d m n : nat, n <= m -> (m == n %[mod d]) = (d %| m - n).

  Check Gauss_dvd
    : forall d1 d2 p : nat, coprime d1 d2 -> (d1 * d2 %| p) = (d1 %| p) && (d2 %| p).

  Lemma chinese_remainder_lite : forall d1 d2 m n : nat,
      coprime d1 d2 ->
      (m == n %[mod d1 * d2]) = (m == n %[mod d1]) && (m == n %[mod d2]).
  Proof.
    move=> d1 d2 m n co_mn.
    case/orP: (leq_total m n) => geq_mn. (* || を && にリフレクトして場合分けする。 *)

    - (* (m <= n) の場合 *)
      rewrite 3![m == n %[mod _]]eq_sym. (* 右辺と左辺を入れ替える。 *)
      rewrite !eqn_mod_dvd //.
      by rewrite Gauss_dvd.

    - (* (n <= m) の場合*)
      rewrite !eqn_mod_dvd //.
      by rewrite Gauss_dvd.
  Qed.

(**
中国人の剰余定理の一般的な場合の証明は、``div.v`` の ``chinese_mod`` を参照してください。
 *)
End Modulo.

(**
# 文献

[1] Graham, Knuth, Patashnik "Concrete Mathematics", Second Edition, A.W.

[2] 有澤、安村、萩野、石畑訳、「コンピュータの数学」共立出版

[3] math-comp/mathcomp/ssreflect/div.v

https://github.com/math-comp/math-comp/blob/master/mathcomp/ssreflect/div.v

[4] 中国人の剰余定理

https://qiita.com/suharahiromichi/items/1a135d9648a0f55f020a

 *)

(* END *)