(** This file shows that the following two formulations of the
"uniproc" condition are equivalent.

- first formulation : [po ⊓ loc ⊔ com] is acyclic

- second formulation : [po ⋅ com^+] is irreflexive

This equivalence assumes that [po] must be irreflexive and that [com]
is acyclic, to repeatedly contract cycles. The part most specific to
memory models is Lemma [cases_uniproc] were [poloc] in [com;poloc;com]
is absorbed by [com]s *)

From RelationAlgebra Require Import lattice prop monoid rel all.
From Coq Require Import Relations String.

(* proof of irrefl(po;com+) <-> acyclic(poloc+com) *)

Definition relation X := hrel X X.
Definition irreflexive {X} (R : relation X) := R ⊓ 1 ≦ 0.
Definition acyclic {X} (R : relation X) := irreflexive (R^+).

Lemma irreflexive_incl {X} (R S : relation X) : R ≦ S -> irreflexive S -> irreflexive R.
Proof.
  unfold irreflexive.
  intros ->; auto.
Qed.

Lemma irreflexive_union {X} (R S : relation X) :
  irreflexive (R ⊔ S) <-> irreflexive R /\ irreflexive S.
Proof.
  unfold irreflexive.
  compute; intuition eauto.
Qed.

Lemma irreflexive_spec {X} (R : relation X) : irreflexive R <-> forall x, ~ R x x.
Proof.
  compute; intuition eauto; subst; eauto.
Qed.

Lemma irreflexive_compose {X} (R S : relation X) : irreflexive (R⋅S) <-> irreflexive (S⋅R).
Proof.
  rewrite 2irreflexive_spec.
  split; intros H x [y xy yx]; apply (H y); exists x; eauto.
Qed.

Instance leq_irreflexive A : Proper (@leq (hrel_lattice_ops A A) ==> flip impl) irreflexive.
Proof.
  unfold irreflexive.
  intros R S -> e. auto.
Qed.

Instance leq_acyclic A : Proper (@leq (hrel_lattice_ops A A) ==> flip impl) acyclic.
Proof.
  intros R S e.
  apply leq_irreflexive.
  rewrite e; auto.
Qed.

Lemma is_transitive_ {X} (R : relation X) `{TR : Transitive _ R} : is_transitive R.
Proof.
  intros a b [c ? ?].
  eapply TR with c; auto.
Qed.

Lemma is_transitive_cap {X} (R S : relation X) : is_transitive R -> is_transitive S -> is_transitive (R ⊓ S).
Proof.
  unfold is_transitive.
  intros e f.
  transitivity (R⋅R ⊓ S⋅S).
  - apply leq_xcap.
    + rewrite !dotcapx, !dotxcap. lattice.
    + rewrite !dotcapx, !dotxcap. lattice.
  - lattice.
Qed.

Instance weq_acyclic A : Proper (@weq (hrel_lattice_ops A A) ==> iff) irreflexive.
Proof.
  intros R S; unfold irreflexive; intros ->; intuition auto.
Qed.

Instance same_relation_irreflexive A : Proper (@weq (hrel_lattice_ops A A) ==> iff) irreflexive.
Proof.
  intros R S; unfold irreflexive; intros ->; intuition auto.
Qed.

Lemma induction_uniproc {X} (R S : relation X) :
  R ⋅ S ⋅ R ≦ R^+ ->
  R^+ ⋅ (S ⋅ R^+)^+ ≦ R^+.
Proof.
  intros H.
  apply itr_ind_r.
  - transitivity (R^*⋅(R⋅S⋅R)⋅R^*).
    + ka.
    + rewrite H. ka.
  - transitivity (R^*⋅(R⋅S⋅R)⋅R^*).
    + ka.
    + rewrite H. ka.
Qed.

Lemma leq_spec {X} (R S : relation X) : R ≦ S -> forall x y, R x y -> S x y.
Proof.
  compute; auto.
Qed.

(* the proof below has been moved in lib/aycyclic *)
Lemma cycle_break {X} (R S : relation X) :
  is_transitive R ->
  is_transitive S ->
  (acyclic (R ⊔ S) <->
   irreflexive R /\
   irreflexive S /\
   acyclic (R ⋅ S)).
Proof.
  intros TR TS. unfold acyclic.
  split.
  - (* easy direction *)
    intros A; repeat split; revert A; apply irreflexive_incl; ka.
  - intros (r & s & rs).
    assert (E : (R ⊔ S)^+ ≡ R^+ ⊔ S^+
                       ⊔ (R^+⋅S^+)^+ ⊔ S^+⋅(R^+⋅S^+)^*⋅R^+
                       ⊔ (R^+⋅S^+)^+⋅R^+ ⊔ S^+⋅(R^+⋅S^+)^+)
      by ka.
    rewrite E.
    rewrite (itr_transitive TR), (itr_transitive TS).
    repeat rewrite irreflexive_union; repeat split; auto.
    + rewrite irreflexive_compose.
      ra_normalise.
      apply rs.
    + rewrite irreflexive_compose.
      apply irreflexive_incl with ((R⋅S)^+); auto.
      rewrite <-(itr_transitive TR).
      ka.
    + rewrite irreflexive_compose.
      apply irreflexive_incl with ((R⋅S)^+); auto.
      rewrite <-(itr_transitive TS).
      ka.
Qed.

Section uniproc.
Variable events : Type.
Variables po rf co loc : relation events.

Definition fr := rf° ⋅ co.
Definition com := co ⊔ rf ⊔ fr.
Definition poloc := po ⊓ loc.

Variable R W : dset events.
Variable rw_0 : [R] ⋅ [W] ≦ 0.
Variable rf_wr : rf ≦ [W] ⋅ rf ⋅ [R].
Variable co_ww : co ≦ [W] ⋅ co ⋅ [W].
Variable rf_loc : rf ≦ loc.
Variable co_loc : co ≦ loc.
Variable co_total : [W] ⋅ loc ⋅ [W]  ≦ 1 ⊔ co ⊔ co°.
Variable R_rf : [R] ≦ rf° ⋅ [W] ⋅ rf.
Variable rf_unique : rf ⋅ rf° ≦ 1.
Variable loc_refl : 1 ≦ loc.
Variable loc_sym : loc° ≦ loc.
Variable loc_trans : loc ⋅ loc ≦ loc.
Variable po_trans : po ⋅ po ≦ po.
(* Variable po_trans : is_transitive po. *)

Lemma rf_wr' : rf ≡ [W] ⋅ rf ⋅ [R].
Proof.
  apply antisym.
  - assumption.
  - kat.
Qed.

Lemma co_ww' : co ≡ [W] ⋅ co ⋅ [W].
Proof.
  apply antisym.
  - assumption.
  - kat.
Qed.

Lemma injcnv {X} (a : dset X) : [a]° ≡ [a].
Proof.
  compute; intuition congruence.
Qed.

Lemma fr_wr' : fr ≡ [R] ⋅ fr ⋅ [W].
Proof.
  unfold fr. rewrite co_ww', rf_wr'.
  ra_normalise.
  rewrite !injcnv.
  kat.
Qed.

Lemma com_mm : com ≡ [R ⊔ W] ⋅ com ⋅ [R ⊔ W].
Proof.
  unfold com, fr, M.
  rewrite rf_wr', co_ww'.
  ra_normalise.
  rewrite !injcnv.
  kat.
Qed.

Lemma com_loc : com ≦ loc.
Proof.
  unfold com, fr. rewrite rf_loc, co_loc.
  rewrite loc_sym, loc_trans.
  ka.
Qed.

Lemma R_rf' : [R] ≡ [R] ⊓ (rf° ⋅ [W] ⋅ rf).
Proof.
  lattice.
Qed.

Lemma rf_unique' w1 w2 r : rf w1 r -> rf w2 r -> w1 = w2.
Proof.
  intros H1 H2.
  change ((1 : relation events) w1 w2).
  apply rf_unique.
  exists r; eauto.
Qed.

Lemma com_read_r x r : R r -> com x r -> rf x r.
Proof.
  intros Hr Hcom.
  assert (A : (com ⋅ [R]) x r). exists r; auto. constructor; auto.
  revert A. apply leq_spec.
  unfold com.
  rewrite rf_wr', co_ww', fr_wr'.
  ra_normalise.
  rewrite <-!dotA.
  rewrite rmov_inj.
  rewrite rw_0.
  kat.
Qed.

Lemma com_read_l x r : R r -> com r x -> fr r x.
Proof.
  intros Hr Hcom.
  assert (A : ([R] ⋅ com) r x). exists r; auto. constructor; auto.
  revert A. apply leq_spec.
  unfold com.
  rewrite rf_wr', co_ww', fr_wr'.
  ra_normalise.
  rewrite rw_0.
  kat.
Qed.

Lemma co_total' w1 w2 : W w1 -> W w2 -> loc w1 w2 -> w1 = w2 \/ co w1 w2 \/ co w2 w1.
Proof.
  intros ? ? ?.
  assert (H12 : ([W] ⋅ loc ⋅ [W]) w1 w2) by (compute; eauto).
  apply co_total in H12.
  compute in *; intuition.
Qed.

Open Scope string_scope.
Definition tag (s : string) (X : Type) := X.
Lemma tag_ s X : X = tag s X. reflexivity. Qed.
Ltac tag s x := let ty := type of x in change ty with (tag s ty) in x.
Ltac untag x := unfold tag in x.
Ltac introtag s := let x := fresh "__" in intros x; tag s x.

Ltac step :=
  match goal with
  | |- _ ≦ _ => introtag "nameme"; introtag "nameme"; introtag "destructme"
  | H : tag "destructme" ((_ ⋅ _) _ _) |- _ =>
    let H1 := fresh "H" in
    let H2 := fresh "H" in
    let x := fresh "ev" in
    destruct H as [x H1 H2];
    tag "nameme" x;
    tag "destructme" H1;
    tag "destructme" H2
  | H : tag "destructme" ((_ ⊓ _) _ _) |- _ =>
    let H1 := fresh "H" in
    let H2 := fresh "H" in
    destruct H as [H1 H2];
    tag "destructme" H1;
    tag "destructme" H2
  | H : tag "destructme" ([R] ?x _) |- _ =>
    let H1 := fresh "isread" in
    let x' := fresh "r" in
    destruct H as [<- H1];
    clear H;
    rename x into x'; untag x'
  | H : tag "destructme" ([W] ?x _) |- _ =>
    let H1 := fresh "iswrite" in
    let x' := fresh "w" in
    destruct H as [<- H1];
    clear H;
    rename x into x'; untag x'
  | H1 : com ?x ?y, H2 : R ?y |- _ => apply com_read_r in H1; auto
  | H2 : is_true (R ?y), H1 : tag _ (com ?x ?y)  |- _ => apply com_read_r in H1; auto
  | H2 : is_true (R ?y), H1 :        com ?x ?y   |- _ => apply com_read_r in H1; auto
  | H2 : is_true (R ?x), H1 : tag _ (com ?x ?y)  |- _ => apply com_read_l in H1; auto
  | H2 : is_true (R ?x), H1 :        com ?x ?y   |- _ => apply com_read_l in H1; auto
  | H : tag _ (?R° ?x ?y) |- _ => change (R° x y) with (R y x) in H
  | H : ?R° ?x ?y |- _ => change (R° x y) with (R y x) in H
  | H : ?A ?B ?C, H' : ?A ?B ?C |- _ => clear H'
  | H1 : tag _ (rf ?w1 ?r), H2 :        rf ?w2 ?r  |- _ => apply (rf_unique' _ _ _ H1) in H2; subst w2
  | H1 : tag _ (rf ?w1 ?r), H2 : tag _ (rf ?w2 ?r) |- _ => apply (rf_unique' _ _ _ H1) in H2; subst w2
  | H1 :        rf ?w1 ?r , H2 : tag _ (rf ?w2 ?r) |- _ => apply (rf_unique' _ _ _ H1) in H2; subst w2
  | H1 :        rf ?w1 ?r , H2 :        rf ?w2 ?r  |- _ => apply (rf_unique' _ _ _ H1) in H2; subst w2
  | x : tag "nameme" events |- _ =>
    let x' := fresh "x" in rename x into x'; untag x'
  | H : tag "destructme" _ |- _ =>
    let H' := fresh in rename H into H'; untag H'
  end.

Lemma cases_uniproc :
  irreflexive (poloc ⋅ com^+) ->
  com ⋅ poloc ⋅ com ≦ com^+.
Proof.
  assert (loc_eq : Equivalence loc) by (split; intros x; compute in *; eauto).
  intros U.
  transitivity (com ⋅ [R ⊔ W] ⋅ poloc ⋅ [R ⊔ W] ⋅ com).
  now rewrite com_mm; kat. rewrite kat.inj_cup. ra_normalise.
  ra_normalise. (* second time, because identifiers are reversed *)
  repeat apply join_leq.
  - (* R R *)
    transitivity (com⋅([R]⋅poloc⋅[R])⋅com); [ ka | ].
    rewrite R_rf'.
    repeat step.
    assert (ww0 : loc w w0).
    { transitivity r. apply rf_loc; auto.
      transitivity r0. symmetry. apply H1.
      symmetry; apply rf_loc; auto. } apply symmetry in ww0.
    destruct (co_total' w0 w ltac:(auto) ltac:(auto) ltac:(auto)) as [<- | [? | ?]].
    + apply leq_spec with (rf ⋅ fr). now unfold com; ka. now compute; eauto.
    + apply leq_spec with (co ⋅ rf ⋅ fr). now unfold com; ka. now compute; eauto.
    + exfalso.
      assert (Hr0 : (poloc ⋅ (fr ⋅ rf)) r0 r0).
      now (exists r; try solve [compute; eauto]).
      apply (U r0 r0). split; [ | compute; auto].
      eapply leq_spec; [ | apply Hr0 ].
      unfold com; ka.
  - (* R W *)
    rewrite R_rf'.
    repeat step.
    assert (ww0 : loc w w0).
    { symmetry. transitivity r. apply rf_loc; auto. apply H0. }
    symmetry in ww0.
    destruct (co_total' w0 w ltac:(auto) ltac:(auto) ltac:(auto)) as [<- | [? | ?]].
    + eapply leq_spec with com; auto. ka.
    + apply leq_spec with (co ⋅ com). now unfold com; ka. now compute; eauto.
    + exfalso.
      assert (Hr : (poloc ⋅ (co ⋅ rf)) r r). exists w. auto. exists w0; auto.
      apply (U r r). split; [ | compute; auto ]. eapply leq_spec; [ | apply Hr ].
      unfold com; ka.
  - (* W R *)
    rewrite R_rf'.
    repeat step.
    assert (ww0 : loc w0 w).
    { transitivity r. apply H2. symmetry. apply rf_loc; auto. }
    destruct (co_total' w0 w ltac:(auto) ltac:(auto) ltac:(auto)) as [<- | [? | ?]].
    + apply leq_spec with (com ⋅ (rf ⋅ fr)). now unfold com; ka. exists w0. auto. exists r; auto.
    + apply leq_spec with (com ⋅ (co ⋅ (rf ⋅ fr))). now unfold com; ka. exists w0; compute; eauto.
    + exfalso.
      assert (Hw0 : (poloc ⋅ fr) w0 w0). exists r; auto. exists w; auto.
      apply (U w0 w0). split; [ | compute; auto ]. eapply leq_spec; [ | apply Hw0 ].
      unfold com; ka.
  - (* W W *)
    repeat step.
    destruct (co_total' w0 w) as [<- | [? | ?]]; auto. apply H0.
    + apply leq_spec with (com ⋅ com). now unfold com; ka. exists w0; auto.
    + apply leq_spec with (com ⋅ (com ⋅ com)). now unfold com; ka. exists w0; auto. exists w; eauto.
      left; left; auto.
    + exfalso.
      apply (U w0 w0). split; [ | reflexivity ]. exists w; auto.
      eapply leq_spec with co. unfold com; ka. auto.
Qed.

Theorem uniproc :
  irreflexive po ->
  acyclic com ->
  (acyclic (poloc ⊔ com) <-> irreflexive (po ⋅ com^+)).
Proof.
  intros Hpo Hcom.
  transitivity (irreflexive (poloc⋅com^+)).
  - split.
    (* main part *)
    + (* easy direction *)
      unfold acyclic, irreflexive.
      assert (E : poloc ⋅ com^+ ≦ (poloc ⊔ com)^+) by ka.
      rewrite E.
      easy.
    + (* direction involving contracting a cycle *)
      intros Hirr.
      cut (acyclic (poloc ⊔ com^+)). apply leq_acyclic. ka.
      apply cycle_break.
      { apply is_transitive_cap; auto. }
      { apply transitive_itr. }
      repeat split.
      { intros x; rewrite <-(Hpo x); unfold poloc. lattice. }
      { apply Hcom. }
      change (poloc⋅com^+⋅(poloc⋅com^+)^* ⊓ 1 ≦ 0).
      rewrite str_itr, dotxpls, capcup'. ra_normalise.
      apply join_leq.
      * apply Hirr.
      * unfold irreflexive in Hirr. rewrite <-Hirr.
        cut (poloc⋅com^+⋅(poloc⋅com^+)^+ ≦ poloc⋅com^+). intros ->; auto.
        rewrite <-dotA. apply dot_leq. reflexivity.
        apply induction_uniproc.
        apply cases_uniproc. auto.
  - (* irrefl(poloc;com+) <-> irrefl(po;com+) *)
    split.
    + intros H x x_ [[y xy yx] <-]; apply H; split. 2:reflexivity. exists y; auto.
      split; auto.
      Fail rewrite com_loc in yx.
      (* TODO: why can't we do: rewrite com_loc in yx. *)
      apply loc_sym. change (loc y x). clear xy. revert y x yx.
      change (com^+ ≦ loc). rewrite com_loc.
      apply itr_ind_l1; auto.
    + apply leq_irreflexive. unfold poloc. rewrite leq_cap_l; auto.
Qed.

End uniproc.


(* This file contains an earlier version of state-related definitions.  The theory from this file should be moved to Procedure.v *)

Set Implicit Arguments.

Require Import Crypto.
Require Import ProgramLogic_old.

Definition stateful_comp_spec (S D R: Set)(inv : S -> S -> Prop)(pre : (S * D) -> (S * D) -> Prop)(post : (S * R) -> (S * R) -> Prop)(c1 c2 : (S * D) -> Comp (S * R)):=
  comp_spec_old (fun a1 a2 => pre a1 a2 /\ inv (fst a1) (fst a2)) (fun b1 b2 => post b1 b2 /\ inv (fst b1) (fst b2)) c1 c2 .

Section CompLoop.

  Variable D R State : Set.
  Hypothesis S_EqDec : EqDec State.

  Fixpoint compLoop (c : (State * D) -> Comp (State * R))(count : nat)(s : State)(d : D) : Comp State :=
    match count with
      | 0 => ret s
      | S count' =>
        [s', _] <-$2 c (s, d);
        compLoop c count' s' d
    end.

  Lemma compLoop_wf : forall (o : (State * D) -> Comp (State * R)) count (s : State) (d : D),
    (forall x y, well_formed_comp (o (x, y))) ->
    well_formed_comp (compLoop o count s d).

    induction count; intuition;
      unfold compLoop; wftac.

  Qed.

  Lemma compLoop_inv : forall (c : (State * D) -> Comp (State * R)) (inv : State -> Prop) d,
    (forall s s' r,  In (s', r) (getSupport (c (s, d))) -> inv s -> inv s') ->
    forall count s s',
    inv s ->
    In s' (getSupport (compLoop c count s d)) -> inv s'.

    induction count; intuition; simpl in *.
    intuition; subst.
    trivial.

    eapply in_getUnique_if in H1.
    apply in_flatten in H1.
    destruct H1.
    intuition.
    apply in_map_iff in H2.
    destruct H2.
    intuition.
    subst.
    destruct x0.
    eapply IHcount.
    eapply H.
    eauto.
    trivial.
    trivial.

  Qed.

End CompLoop.

Class AdversaryWithOracle_concrete
  (D_A R_A D_O R_O : Set)
  (S_A : Set)
  (A1 : D_A -> Comp (S_A * D_O))
  (A2 : S_A -> R_O -> Comp (S_A * D_O))
  (A3 : S_A -> Comp R_A) := {

  S_A_EqDec : EqDec S_A;

  A1_wf : forall x, well_formed_comp (A1 x);
  A2_wf : forall x y, well_formed_comp (A2 x y);
  A3_wf : forall x, well_formed_comp (A3 x)

}.

Definition StatefulProc (S D R : Set) :=
  S * D -> Comp (S * R).

Section AdversaryWithOracle_concrete.

  Context `{A : AdversaryWithOracle_concrete }.
  Variable S_O : Set.
 (*  Definition Oracle := StatefulProc S_O D_O R_O. *)

  Instance eqd_S_A : EqDec S_A.
  eapply S_A_EqDec.
  Defined.

  Hypothesis R_A_EqDec : EqDec R_A.
  Hypothesis D_A_EqDec : EqDec D_A.
  Hypothesis S_O_EqDec : EqDec S_O.
  Hypothesis D_O_EqDec : EqDec D_O.
  Hypothesis R_O_EqDec : EqDec R_O.

  Fixpoint loopA (oracleF : StatefulProc S_O D_O R_O)(count : nat)(s_A : S_A)(s_O : S_O)(d_O : D_O) : Comp (S_A * S_O) :=
    match count with
      | 0 => ret (s_A, s_O)
      | S count' =>
        [s_O', r_O] <-$2 oracleF (s_O, d_O);
        [s_A', d_O'] <-$2 (A2 s_A r_O);
        loopA oracleF count' s_A' s_O' d_O'
    end.

  Lemma loopA_wf_inv : forall oracleF inv count s_A s_O d_O,
    inv s_O ->
    (forall s d s' r, In (s', r) (getSupport (oracleF (s, d))) -> inv s -> inv s') ->
    (forall s d, inv s -> well_formed_comp (oracleF (s, d))) ->
    well_formed_comp (loopA oracleF count s_A s_O d_O).

    induction count; intuition; simpl in *; wftac.
    eapply A2_wf.
  Qed.

  Lemma loopA_wf : forall oracleF count s_A s_O d_O,
    (forall s d, well_formed_comp (oracleF (s, d))) ->
    well_formed_comp (loopA oracleF count s_A s_O d_O).

    intuition.
    eapply (loopA_wf_inv oracleF (fun x => True)); intuition.

  Qed.

  Definition runA oracleF (count : nat)(s_O : S_O)(d_A : D_A) :=
    p <-$ A1 d_A;
    p' <-$ loopA oracleF count (fst p) s_O (snd p);
    r <-$ A3 (fst p');
    ret (r, (snd p')).

  Lemma loopA_eq_compLoop : forall inv o,
    stateful_comp_spec inv (fun a b => True) (fun s b => True) o o ->
    forall count s_O1 s_O2 s_A d_O1 d_O2 (C : Set) f1 f2 (x1 x2 : C),
    inv s_O1 s_O2 ->
    (forall s_O1' s_A s_O2', inv s_O1' s_O2' -> eqRat (evalDist (f1 (s_A, s_O1')) x1) (evalDist (f2 s_O2') x2)) ->
    eqRat (evalDist (p <-$ loopA o count s_A s_O1 d_O1; f1 p) x1) (evalDist (p <-$ compLoop _ o count s_O2 d_O2; f2 p) x2).

    induction count; intuition;
    unfold loopA, compLoop.

    comp_simp.
    eauto.

    fold loopA.
    inline_first.

    eapply H; intuition.

    inline_first.
    comp_irr_l.
    eapply A2_wf.

    comp_simp.
    eapply IHcount; intuition.
  Qed.

  Lemma runA_eq_compLoop : forall o inv,
    stateful_comp_spec inv (fun a b => True) (fun s b => True) o o ->
    forall count s_O1 s_O2 d_A d_O (C : Set) f1 f2 (x : C),
    inv s_O1 s_O2 ->
    (forall s_O1' s_O2' s_A, inv s_O1' s_O2' -> evalDist (f1 (s_A, s_O1')) x == evalDist (f2 s_O2') x) ->
    evalDist (p <-$ runA o count s_O1 d_A; f1 p) x == evalDist (p <-$ compLoop _ o count s_O2 d_O; f2 p) x.

    intuition.
    unfold runA.
    inline_first.
    comp_irr_l.
    eapply A1_wf.
    inline_first.
    eapply (loopA_eq_compLoop H); intuition.
    inline_first.
    comp_irr_l; wftac.
    eapply A3_wf.
  Qed.

  Lemma loopA_spec_eq : forall (A : Set)(inv : S_O -> S_O -> Prop)(o1 o2 : StatefulProc S_O D_O R_O)(count : nat)(s_O1 s_O2 : S_O)(s_A : S_A)(d_O : D_O) f1 f2 (x : A),
    inv s_O1 s_O2 ->
    stateful_comp_spec inv (fun p1 p2 => snd p1 = snd p2) (fun p1 p2 => snd p1 = snd p2) o1 o2 ->
    (forall r1 r2 o1 o2 y, inv o1 o2 -> eq r1 r2 ->evalDist (f1 (r1, o1)) y == evalDist (f2 (r2, o2)) y) ->
    evalDist (p <-$ loopA o1 count s_A s_O1 d_O; f1 p) x == evalDist (p <-$ loopA o2 count s_A s_O2 d_O; f2 p) x.

    induction count; intuition.

    comp_ute.

    unfold loopA.
    fold loopA.
    inline_first.

    eapply H0;
    intuition.
    inline_first.

    simpl in H5.
    subst.
    comp_simp.
    inline_first.
    comp_skip.
    simpl.
    intuition.

  Qed.

  Lemma loopA_spec :
    forall (A : Set)(inv : S_O -> S_O -> Prop)(o1 o2 : StatefulProc S_O D_O R_O)(count : nat)(s_O1 s_O2 : S_O)(s_A : S_A)(d_O : D_O) f1 f2 rel (x : A),
      SpecRel rel ->
      inv s_O1 s_O2 ->
      stateful_comp_spec inv (fun p1 p2 => snd p1 = snd p2) (fun p1 p2 => snd p1 = snd p2) o1 o2 ->
      (forall r1 r2 o1 o2, inv o1 o2 -> eq r1 r2 -> rel (evalDist (f1 (r1, o1)) x) (evalDist (f2 (r2, o2)) x)) ->
      rel (evalDist (p <-$ loopA o1 count s_A s_O1 d_O; f1 p) x) (evalDist (p <-$ loopA o2 count s_A s_O2 d_O; f2 p) x).

    induction count; intuition.
    comp_ute.
    eapply add_proper.
    comp_ute.
    eapply mult_proper; comp_ute.

    unfold loopA.
    fold loopA.
    inline_first.

    eapply H1; intuition.
    inline_first.
    simpl in H6.
    subst.
    comp_simp.
    inline_first.
    comp_skip.
    simpl; intuition.
    eapply IHcount; intuition.
  Qed.

  (*
  Lemma loopA_spec : forall (A : Set)(inv : S_O -> S_O -> Prop)(o1 o2 : Oracle)(count : nat)(s_O1 s_O2 : S_O)(s_A : S_A)(d_O : D_O) f1 f2 (x : A),
    inv s_O1 s_O2 ->
    stateful_comp_spec inv (fun p1 p2 => snd p1 = snd p2) (fun p1 p2 => snd p1 = snd p2) o1 o2 ->
    (forall r1 r2 o1 o2, inv o1 o2 -> eq r1 r2 ->evalDist (f1 (r1, o1)) x <= evalDist (f2 (r2, o2)) x) ->
    evalDist (p <-$ loopA o1 count s_A s_O1 d_O; f1 p) x <= evalDist (p <-$ loopA o2 count s_A s_O2 d_O; f2 p) x.

    induction count; intuition.
    comp_ute.
    eapply leRat_trans.
    Focus 2.
    eapply eqRat_impl_leRat.
    eapply ratAdd_0_l.
    repeat pairInv.
    eapply H1; intuition.

    unfold loopA.
    fold loopA.

    eapply leRat_trans.
    eapply eqRat_impl_leRat.
    comp_inline O O.
    eapply eqRat_refl.

    eapply leRat_trans.
    Focus 2.
    eapply eqRat_impl_leRat.
    comp_inline 1%nat O.
    eapply eqRat_refl.

    eapply H0;
    intuition.

    simpl in H3.
    subst.

    eapply leRat_trans.
    eapply eqRat_impl_leRat.
    comp_inline O O.
    eapply eqRat_refl.

    comp_simp.
    eapply leRat_trans.
    Focus 2.
    eapply eqRat_impl_leRat.
    comp_inline 1%nat O.
    eapply eqRat_refl.

    eapply evalDist_Bind_id_le; intuition.
    simpl. intuition.
  Qed.
*)

  Lemma loopA_spec_irr :
    forall rel (A : Set)(pre : (S_O * D_O) -> (S_O * D_O) -> Prop) post (o1 o2 : StatefulProc S_O D_O R_O),
      SpecRel rel ->
      comp_spec_old pre post o1 o2 ->
      (forall s1 s2 r1 r2 d1 d2, post (s1, r1) (s2, r2) -> pre (s1, d1) (s2, d2)) ->
      forall (count : nat)(s_O1 s_O2 : S_O)(s_A1 s_A2 : S_A)(d_O1 d_O2 : D_O) f1 f2 (x : A),
        pre (s_O1, d_O1) (s_O2, d_O2) ->
        (forall s_O1' s_O2' r1 r2 d1 d2 s_A1' s_A2' s_A1'' s_A2'',
           post (s_O1', r1) (s_O2', r2) ->
        In (s_A1'', d1) (getSupport (A2 s_A1' r1)) ->
        In (s_A2'', d2) (getSupport (A2 s_A2' r2)) ->
        pre (s_O1', d1) (s_O2', d2)) ->
        (forall s_O1' s_O2' d_O1' d_O2' s_A1' s_A2',
           pre (s_O1', d_O1') (s_O2', d_O2') ->
           rel (evalDist (f1 (s_A1', s_O1')) x) (evalDist (f2 (s_A2', s_O2')) x)) ->
        rel (evalDist (p <-$ loopA o1 count s_A1 s_O1 d_O1; f1 p) x) (evalDist (p <-$ loopA o2 count s_A2 s_O2 d_O2; f2 p) x).

    induction count; intuition.

    comp_ute.
    repeat pairInv.
    eapply add_proper.
    eapply refl.
    intuition.
    eapply mult_proper.
    eapply refl;intuition.
    eapply H4; eauto.

    unfold loopA.  fold loopA.

    inline_first.
    eapply H0;
    intuition.
    inline_first.

    comp_irr_l.
    eapply A2_wf.
    comp_simp.
    inline_first.
    comp_irr_r.
    eapply A2_wf.

    comp_simp.
    eapply IHcount; intuition; eauto.
  Qed.

  Lemma loopA_spec_irr_eq :
    forall (A : Set)(pre : (S_O * D_O) -> (S_O * D_O) -> Prop) post (o1 o2 : StatefulProc S_O D_O R_O),
      comp_spec_old pre post o1 o2 ->
      (forall s1 s2 r1 r2 d1 d2,
         post (s1, r1) (s2, r2) -> pre (s1, d1) (s2, d2)) ->
      forall (count : nat)(s_O1 s_O2 : S_O)(s_A1 s_A2 : S_A)(d_O1 d_O2 : D_O) f1 f2 (x : A),
        pre (s_O1, d_O1) (s_O2, d_O2) ->
        (forall s_O1' s_O2' r1 r2 d1 d2 s_A1' s_A2' s_A1'' s_A2'',
           post (s_O1', r1) (s_O2', r2) ->
        In (s_A1'', d1) (getSupport (A2 s_A1' r1)) ->
        In (s_A2'', d2) (getSupport (A2 s_A2' r2)) ->
        pre (s_O1', d1) (s_O2', d2)) ->
        (forall s_O1' s_O2' d_O1' d_O2' s_A1' s_A2',
           pre (s_O1', d_O1') (s_O2', d_O2') ->
           eqRat (evalDist (f1 (s_A1', s_O1')) x) (evalDist (f2 (s_A2', s_O2')) x)) ->
        eqRat (evalDist (p <-$ loopA o1 count s_A1 s_O1 d_O1; f1 p) x) (evalDist (p <-$ loopA o2 count s_A2 s_O2 d_O2; f2 p) x).

    intuition.
    eapply loopA_spec_irr; intuition; eauto.
    eauto.
    eauto.
  Qed.

  Lemma loopA_spec_2 :
    forall rel (A : Set)(pre1 pre2 : (S_O * D_O) -> (S_O * D_O) -> Prop) post1 post2 post3 (o1 o2 : StatefulProc S_O D_O R_O),
      SpecRel rel ->
      comp_spec_old pre1 (fun p1 p2 => (post1 p1 p2) \/ (post2 p1 p2)) o1 o2 ->
      comp_spec_old pre2 post3 o1 o2 ->
      (forall s1 s2 r1 r2, post1 (s1, r1) (s2, r2) -> r1 = r2) ->
      (forall s1 s2 r1 r2 d, post1 (s1, r1) (s2, r2) -> pre1 (s1, d) (s2, d)) ->
      (forall s1 s2 r1 r2 d1 d2, post2 (s1, r1) (s2, r2) -> pre2 (s1, d1) (s2, d2)) ->
      forall (count : nat)(s_O1 s_O2 : S_O)(s_A1 s_A2 : S_A)(d_O1 d_O2 : D_O) f1 f2 (x : A),
        (pre1 (s_O1, d_O1) (s_O2, d_O2) /\ s_A1 = s_A2) \/ pre2 (s_O1, d_O1) (s_O2, d_O2) ->
        (forall s_O1' s_O2' r1 r2 d1 d2 s_A1' s_A2' s_A1'' s_A2'',
        post3 (s_O1', r1) (s_O2', r2) ->
        In (s_A1'', d1) (getSupport (A2 s_A1' r1)) ->
        In (s_A2'', d2) (getSupport (A2 s_A2' r2)) ->
        pre2 (s_O1', d1) (s_O2', d2)) ->
        (forall s_O1' s_O2' d_O1' d_O2' s_A',
           pre1 (s_O1', d_O1') (s_O2', d_O2') ->
           rel (evalDist (f1 (s_A', s_O1')) x) (evalDist (f2 (s_A', s_O2')) x)) ->
        (forall s_O1' s_O2' d_O1' d_O2' s_A1' s_A2',
           pre2 (s_O1', d_O1') (s_O2', d_O2') ->
           rel (evalDist (f1 (s_A1', s_O1')) x) (evalDist (f2 (s_A2', s_O2')) x)) ->
        rel (evalDist (p <-$ loopA o1 count s_A1 s_O1 d_O1; f1 p) x) (evalDist (p <-$ loopA o2 count s_A2 s_O2 d_O2; f2 p) x).

    induction count; intros.

    comp_ute.
    repeat pairInv.
    eapply add_proper.
    eapply refl; intuition.
    eapply mult_proper.
    eapply refl; intuition.
    eauto.

    repeat pairInv.
    eapply add_proper.
    eapply refl; intuition.
    eapply mult_proper.
    eapply refl; intuition.
    eauto.

    unfold loopA.
    fold loopA.
    inline_first.

    destruct H5; intuition.
    subst.
    eapply H0;
      intuition.
    comp_simp.
    inline_first.
    assert (b = r).
    eauto.
    subst.
    comp_skip.

    eapply IHcount; intuition.
    left.
    intuition.
    eauto.

    comp_simp.
    inline_first.
    comp_irr_l.
    eapply A2_wf.
    comp_irr_r.
    eapply A2_wf.
    comp_simp.
    eapply IHcount; intuition.
    right.
    eauto.

    eapply H1; intuition.
    comp_simp.
    inline_first.
    comp_irr_l.
    eapply A2_wf.
    comp_irr_r.
    eapply A2_wf.
    comp_simp.
    eapply IHcount; intuition.
    right.
    eauto.
  Qed.

  Lemma loopA_inv_eq :
    forall rel (inv : S_O -> Prop)(o1 o2 : StatefulProc S_O D_O R_O)(count : nat) s_O s_A d_A x,
      SpecRel rel ->
      inv s_O ->
      (forall s d p, inv s -> In p (getSupport (o1 (s, d))) -> inv (fst p)) ->
      (forall s d p, inv s -> In p (getSupport (o2 (s, d))) -> inv (fst p)) ->
      (forall s d x, inv s -> (evalDist (o1 (s, d)) x) == (evalDist (o2 (s, d)) x)) ->
      rel (evalDist (loopA o1 count s_A s_O d_A) x) (evalDist (loopA o2 count s_A s_O d_A) x).

    induction count; intuition.
    comp_ute.

    unfold loopA.
    fold loopA.
    comp_skip.
    comp_skip.
    eapply IHcount; intuition.
    specialize (H1 s_O d_A (a0, b0)).
    simpl in H1.
    eapply H1; intuition.
  Qed.

  Lemma A_query_spec_eq : forall (inv : S_O -> S_O -> Prop)(o1 o2 : StatefulProc S_O D_O R_O),
    stateful_comp_spec inv (fun p1 p2 => (snd p1) = (snd p2)) (fun p1 p2 => (snd p1) = (snd p2)) o1 o2 ->
    forall (count : nat) s_O1 s_O2 d_A (C : Set) f1 f2 (x : C),
    inv s_O1 s_O2 ->
    (forall r1 r2 o1 o2 y, inv o1 o2 -> eq r1 r2 ->evalDist (f1 (r1, o1)) y == evalDist (f2 (r2, o2)) y) ->
    evalDist (p <-$ runA o1 count s_O1 d_A; f1 p) x == evalDist (p <-$ runA o2 count s_O2 d_A; f2 p) x.

    intuition.
    unfold runA.
    inline_first.
    comp_skip.
    inline_first.
    eapply loopA_spec_eq; eauto; intuition.
    subst.
    inline_first.
    comp_skip.
    simpl.
    intuition.
    comp_simp.
    simpl.
    intuition.
  Qed.

  Lemma A_query_spec :
    forall rel (inv : S_O -> S_O -> Prop)(o1 o2 : StatefulProc S_O D_O R_O),
      SpecRel rel ->
      stateful_comp_spec inv (fun p1 p2 => (snd p1) = (snd p2)) (fun p1 p2 => (snd p1) = (snd p2)) o1 o2 ->
      forall (count : nat) s_O1 s_O2 d_A (C : Set) f1 f2 (x : C),
        inv s_O1 s_O2 ->
        (forall r1 r2 o1 o2, inv o1 o2 -> eq r1 r2 -> rel (evalDist (f1 (r1, o1)) x) (evalDist (f2 (r2, o2)) x)) ->
        rel (evalDist (p <-$ runA o1 count s_O1 d_A; f1 p) x) (evalDist (p <-$ runA o2 count s_O2 d_A; f2 p) x).

    intuition.
    unfold runA.
    inline_first.
    comp_skip.
    inline_first.
    eapply loopA_spec; eauto; intuition.
    subst.
    inline_first.
    comp_skip.
    simpl.
    intuition.
    comp_simp.
    simpl.
    intuition.
  Qed.

  Lemma A_query_spec_irr_eq : forall (inv : S_O -> S_O -> Prop) (pre : (S_O * D_O) -> (S_O * D_O) -> Prop) post (o1 o2 : StatefulProc S_O D_O R_O),
    stateful_comp_spec inv pre post o1 o2 ->
    forall (count : nat) s_O1 s_O2 d_A (C : Set) f1 f2 (x : C),
    inv s_O1 s_O2 ->
    (forall d, pre (s_O1, d) (s_O2, d)) ->
    (forall s_O1' s_O2' r1 r2 d1 d2 (* s_A1' s_A2' s_A1'' s_A2'' *),
      inv s_O1' s_O2' ->
      post (s_O1', r1) (s_O2', r2) ->
 (*     In (s_A1'', d1) (getSupport (A2 s_A1' r1)) ->
      In (s_A2'', d2) (getSupport (A2 s_A2' r2)) -> *)
      pre (s_O1', d1) (s_O2', d2)) ->
    (forall s_O1' s_O2' x1 x2 z, inv s_O1' s_O2' -> evalDist (f1 (x1, s_O1')) z == evalDist (f2 (x2, s_O2')) z) ->
    evalDist (p <-$ runA o1 count s_O1 d_A; f1 p) x == evalDist (p <-$ runA o2 count s_O2 d_A; f2 p) x.

    intuition.
    unfold runA.
    inline_first.
    comp_skip.

    unfold fst, snd.
    inline_first.
    eapply loopA_spec_irr_eq; intuition.
    eapply H.
    intuition.
    intuition.
    eapply H2.
    simpl in H8.
    trivial.
    eapply H7.

    intuition.
    intuition.
    intuition.
    eapply H2.
    simpl in H10.
    trivial.
    eapply H9.

    inline_first.
    comp_irr_l.
    eapply A3_wf.
    comp_irr_r.
    eapply A3_wf.
    comp_simp.
    intuition.
  Qed.

  Lemma A_query_spec_irr :
    forall rel (A : Set)(pre : (S_O * D_O) -> (S_O * D_O) -> Prop) post (o1 o2 : StatefulProc S_O D_O R_O),
      SpecRel rel ->
      comp_spec_old pre post o1 o2 ->
      (forall s1 s2 r1 r2 d1 d2, post (s1, r1) (s2, r2) -> pre (s1, d1) (s2, d2)) ->
      forall count (s_O1 s_O2 : S_O) d_A f1 f2 (x : A),
        (forall d, pre (s_O1, d) (s_O2, d)) ->
        (forall s_O1' s_O2' r1 r2 d1 d2 (* s_A1' s_A2' s_A1'' s_A2'' *),
           post (s_O1', r1) (s_O2', r2) ->
    (*     In (s_A1'', d1) (getSupport (A2 s_A1' r1)) ->
        In (s_A2'', d2) (getSupport (A2 s_A2' r2)) -> *)
        pre (s_O1', d1) (s_O2', d2)) ->
        (forall s_O1' s_O2' d_O1' d_O2' s_A1' s_A2',
           pre (s_O1', d_O1') (s_O2', d_O2') ->
           rel (evalDist (f1 (s_A1', s_O1')) x) (evalDist (f2 (s_A2', s_O2')) x)) ->
        rel (evalDist (p <-$ runA o1 count s_O1 d_A; f1 p) x)  (evalDist (p <-$ runA o2 count s_O2 d_A; f2 p) x).

    intuition.
    unfold runA.
    inline_first.
    comp_skip.

    unfold fst, snd.
    inline_first.
    eapply loopA_spec_irr; intuition.
    eapply H0.
    eapply H3.
    eauto.
    intuition.
    eauto.

    inline_first.
    comp_irr_l.
    eapply A3_wf.
    comp_irr_r.
    eapply A3_wf.
    comp_simp.
    eauto.
  Qed.

  Lemma A_query_inv :
    forall rel (o1 o2 : StatefulProc S_O D_O R_O)(inv : S_O -> Prop)(count : nat) s_O d_A x,
      SpecRel rel ->
      inv s_O ->
      (forall s d p, inv s -> In p (getSupport (o1 (s, d))) -> inv (fst p)) ->
      (forall s d p, inv s -> In p (getSupport (o2 (s, d))) -> inv (fst p)) ->
      (forall s d x, inv s -> eqRat (evalDist (o1 (s, d)) x) (evalDist (o2 (s, d)) x)) ->
      rel (evalDist (p <-$ runA o1 count s_O d_A; ret fst p) x) (evalDist (p <-$ runA o2 count s_O d_A; ret fst p) x).

    intuition.
    unfold runA.
    inline_first.
    comp_skip.
    inline_first.
    comp_skip.
    simpl.
    eapply loopA_inv_eq; intuition; eauto.
    eauto.
    eauto.

    inline_first.
    comp_skip.
    comp_simp.
    comp_ute.
  Qed.

  (* This is a two-specification version of the "adversary with oracle" specification.  The first specification shows that the outputs of the oracle are the same when the inputs are the same, and the state hasn't gone bad yet.  The second specification corresponds to the case when the computation has gone "bad," and shows that badness is preserved as an invariant.  *)

  Lemma A_query_spec_2_eq : forall (A : Set)(pre1 pre2 : (S_O * D_O) -> (S_O * D_O) -> Prop) post1 post2 post3 (o1 o2 : StatefulProc S_O D_O R_O),
    comp_spec_old pre1 (fun p1 p2 => (post1 p1 p2) \/ (post2 p1 p2)) o1 o2 ->
    comp_spec_old pre2 post3 o1 o2 ->
    (forall s1 s2 r1 r2, post1 (s1, r1) (s2, r2) -> r1 = r2) ->
    (forall s1 s2 r1 r2 d, post1 (s1, r1) (s2, r2) -> pre1 (s1, d) (s2, d)) ->
    (forall s1 s2 r1 r2 d1 d2, post2 (s1, r1) (s2, r2) -> pre2 (s1, d1) (s2, d2)) ->
    forall (count : nat)(s_O1 s_O2 : S_O) d_A f1 f2 (x : A),
      (forall d, pre1 (s_O1, d) (s_O2, d)) ->
      (forall s_O1' s_O2' r1 r2 d1 d2 (* s_A1' s_A2' s_A1'' s_A2'' *),
        post3 (s_O1', r1) (s_O2', r2) ->
      (*   In (s_A1'', d1) (getSupport (A2 s_A1' r1)) ->
        In (s_A2'', d2) (getSupport (A2 s_A2' r2)) -> *)
        pre2 (s_O1', d1) (s_O2', d2)) ->
      (forall s_O1' s_O2' d_O1' d_O2' s_A',
        pre1 (s_O1', d_O1') (s_O2', d_O2') ->
        evalDist (f1 (s_A', s_O1')) x == evalDist (f2 (s_A', s_O2')) x) ->
      (forall s_O1' s_O2' d_O1' d_O2' s_A1' s_A2',
        pre2 (s_O1', d_O1') (s_O2', d_O2') ->
        evalDist (f1 (s_A1', s_O1')) x == evalDist (f2 (s_A2', s_O2')) x) ->
    evalDist (p <-$ runA o1 count s_O1 d_A; f1 p) x == evalDist (p <-$ runA o2 count s_O2 d_A; f2 p) x.

    intros.
    unfold runA.
    inline_first.
    comp_skip.

    inline_first.
    eapply (loopA_spec_2 _ _ _ H H0); intuition.
    eapply H5; eauto.

    inline_first.
    comp_skip.
    simpl.
    intuition.

    comp_simp.
    simpl.
    eauto.

    inline_first.
    comp_irr_l.
    eapply A3_wf.
    comp_irr_r.
    eapply A3_wf.
    comp_simp.
    simpl.
    eauto.
  Qed.

  Lemma A_query_spec_2 :
    forall rel (A : Set)(pre1 pre2 : (S_O * D_O) -> (S_O * D_O) -> Prop) post1 post2 post3 (o1 o2 : StatefulProc S_O D_O R_O),
      SpecRel rel ->
      comp_spec_old pre1 (fun p1 p2 => (post1 p1 p2) \/ (post2 p1 p2)) o1 o2 ->
      comp_spec_old pre2 post3 o1 o2 ->
      (forall s1 s2 r1 r2, post1 (s1, r1) (s2, r2) -> r1 = r2) ->
      (forall s1 s2 r1 r2 d, post1 (s1, r1) (s2, r2) -> pre1 (s1, d) (s2, d)) ->
      (forall s1 s2 r1 r2 d1 d2, post2 (s1, r1) (s2, r2) -> pre2 (s1, d1) (s2, d2)) ->
      forall (count : nat)(s_O1 s_O2 : S_O) d_A f1 f2 (x : A),
      (forall d, pre1 (s_O1, d) (s_O2, d)) ->
      (forall s_O1' s_O2' r1 r2 d1 d2 (* s_A1' s_A2' s_A1'' s_A2'' *),
         post3 (s_O1', r1) (s_O2', r2) ->
         (*   In (s_A1'', d1) (getSupport (A2 s_A1' r1)) ->
        In (s_A2'', d2) (getSupport (A2 s_A2' r2)) -> *)
         pre2 (s_O1', d1) (s_O2', d2)) ->
      (forall s_O1' s_O2' d_O1' d_O2' s_A',
         pre1 (s_O1', d_O1') (s_O2', d_O2') ->
         rel (evalDist (f1 (s_A', s_O1')) x) (evalDist (f2 (s_A', s_O2')) x)) ->
      (forall s_O1' s_O2' d_O1' d_O2' s_A1' s_A2',
         pre2 (s_O1', d_O1') (s_O2', d_O2') ->
         rel (evalDist (f1 (s_A1', s_O1')) x) (evalDist (f2 (s_A2', s_O2')) x)) ->
      rel (evalDist (p <-$ runA o1 count s_O1 d_A; f1 p) x) (evalDist (p <-$ runA o2 count s_O2 d_A; f2 p) x).

    intros.
    unfold runA.
    inline_first.
    comp_skip.

    inline_first.
    eapply (loopA_spec_2 _ _ _ H0 H1); intuition.
    eapply H6; eauto.

    inline_first.
    comp_skip.
    simpl.
    intuition.

    comp_simp.
    simpl.
    eauto.

    inline_first.
    comp_irr_l.
    eapply A3_wf.
    comp_irr_r.
    eapply A3_wf.

    comp_simp.
    simpl.
    eauto.
  Qed.

End AdversaryWithOracle_concrete.

Notation "A 'queries' f" := (@runA _ _ _ _ _ A _ _ f)
  (at level 75) : comp_scope.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** A type class-based library for working with decidable equality. *)

Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Logic.Decidable.

(* *********************************************************************** *)
(** * Hints for [equiv] *)

#[global]
Hint Extern 0 (?x === ?x) => reflexivity : core.
#[global]
Hint Extern 1 (_ === _) => (symmetry; trivial; fail) : core.
#[global]
Hint Extern 1 (_ =/= _) => (symmetry; trivial; fail) : core.

(* *********************************************************************** *)
(** * Facts about [EqDec] *)

(** The [EqDec] class is defined in Coq's standard library. *)

Lemma equiv_reflexive' : forall (A : Type) `{EqDec A} (x : A),
  x === x.
Proof. intros. apply equiv_reflexive. Qed.

Lemma equiv_symmetric' : forall (A : Type) `{EqDec A} (x y : A),
  x === y ->
  y === x.
Proof. intros. apply equiv_symmetric; assumption. Qed.

Lemma equiv_transitive' : forall (A : Type) `{EqDec A} (x y z : A),
  x === y ->
  y === z ->
  x === z.
Proof. intros. eapply @equiv_transitive; eassumption. Qed.

Lemma equiv_decidable : forall (A : Type) `{EqDec A} (x y : A),
  decidable (x === y).
Proof. intros. unfold decidable. destruct (x == y); auto. Defined.

(* *********************************************************************** *)
(** * Specializing [EqDec] *)

(** It is convenient to be able to use a single notation for decidable
    equality on types.  This can naturally be done using a type class.
    However, the definition of [EqDec] in the EquivDec library is
    overly general for cases where the equality is [eq]: the extra
    layer of abstraction provided by abstracting over the equivalence
    relation gets in the way of smooth reasoning.  To get around this,
    we define a version of that class where the equivalence relation
    is hard-coded to be [eq].

    Implementation note: One should not declare an instance for
    [EqDec_eq A] directly.  First, declare an instance for [@EqDec A
    eq eq_equivalence].  Second, let class inference build an instance
    for [EqDec_eq A] using the instance declaration below.

    Implementation note (BEA): Specifying [eq_equivalence] explicitly
    is important.  Following Murphy's Law, if type class inference can
    find multiple ways of inferring the [@Equivalence A eq] argument,
    it will do so in the most inconvenient way possible.
    Additionally, I choose to infer [EqDec_eq] instances from [EqDec]
    instances because the standard library already defines instances
    for [EqDec]. *)

Class EqDec_eq (A : Type) :=
  eq_dec : forall (x y : A), {x = y} + {x <> y}.

#[export] Instance EqDec_eq_of_EqDec (A : Type) `(@EqDec A eq eq_equivalence) : EqDec_eq A.
Proof. trivial. Defined.

(** We can also provide a reflexivity theorem for rewriting with, since types
    with decidable equality satisfy UIP/Axiom K and so we know that we can
    rewrite the equality proof to `eq_refl`. *)

Theorem eq_dec_refl {A : Type} `{EqDec_eq A} (x : A) : eq_dec x x = left eq_refl.
Proof.
  destruct (eq_dec x x); [|contradiction].
  f_equal; apply (Eqdep_dec.UIP_dec eq_dec).
Qed.

(* ********************************************************************** *)
(** * Decidable equality *)

(** We prefer that "==" refer to decidable equality at [eq], as
    defined by the [EqDec_eq] class from the CoqEqDec library. *)

Declare Scope coqeqdec_scope.

Notation " x  == y " := (eq_dec x y) (at level 70) : coqeqdec_scope.

Open Scope coqeqdec_scope.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice.
Require Import fintype tuple finfun bigop prime ssralg finset fingroup morphism.
Require Import perm automorphism quotient action zmodp finalg center commutator.
Require Import poly cyclic pgroup nilpotent matrix mxalgebra mxrepresentation.
Require Import vector falgebra fieldext ssrnum algC rat algnum galois.
Require Import classfun character inertia integral_char vcharacter.
Require ssrint.

(******************************************************************************)
(* This file covers Peterfalvi, Section 1: Preliminary results.               *)
(******************************************************************************)

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

Import GroupScope GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Local Notation algCF := [fieldType of algC].

Section Main.

Variable gT : finGroupType.

(* This is Peterfalvi (1.1). *)
Lemma odd_eq_conj_irr1 (G : {group gT}) t :
  odd #|G| -> (('chi[G]_t)^*%CF == 'chi_t) = ('chi_t == 1).
Proof.
rewrite -coprimen2 => oddG; pose A := <[1 : 'Z_2]>.
have Z2P (a : 'Z_2): a = 0 \/ a = 1 by apply/pred2P; case: a => -[|[]].
pose Ito (t : Iirr G) := [fun a : 'Z_2 => iter a (@conjC_Iirr _ G) t].
pose Cto (C : {set gT}) := [fun a : 'Z_2 => iter a invg C].
have IactP: is_action A Ito.
  split=> [|i /Z2P[]->] /Z2P[]-> //=; last by rewrite conjC_IirrK.
  exact/inv_inj/conjC_IirrK.
have CactP: is_action A Cto.
  by split=> [|C /Z2P[]->] /Z2P[]-> //=; [apply: invg_inj | rewrite invgK].
pose Iact := Action IactP; pose Cact := Action CactP.
have n_cG_A: [acts A, on classes G | Cact].
  rewrite cycle_subG !inE cycle_id; apply/subsetP=> _ /imsetP[x Gx ->].
  by rewrite !inE /= -classVg mem_classes ?groupV.
transitivity (t \in [set 0]); last by rewrite inE irr_eq1.
suffices{t} /eqP->: [set 0] == 'Fix_Iact[1].
  by rewrite !inE sub1set inE -(inj_eq irr_inj) conjC_IirrE.
rewrite eqEcard !(sub1set, inE) conjC_Iirr_eq0 eqxx /=.
rewrite (card_afix_irr_classes (cycle_id _) n_cG_A) => [|i x xy Gx]; last first.
  rewrite inE => {xy}/imsetP[y Gy /(canRL invgK)->].
  by rewrite -conjVg cfunJ {y Gy}//= conjC_IirrE cfunE -irr_inv invgK.
have ->: #|[set 0 : Iirr G]| = #|[1 {set gT}]| by rewrite !cards1.
apply/subset_leq_card/subsetP=> _ /setIdP[/imsetP[x Gx ->] /afix1P-DxGV].
have /imsetP[y Gy DxV]: x^-1%g \in x ^: G by rewrite -DxGV memV_invg class_refl.
have{Gy} cxy: y \in 'C[x].
  suffices cxy2: (y ^+ 2)%g \in 'C[x] by rewrite -(expgK oddG Gy) groupX.
  by rewrite cent1C cent1E conjgC conjgM -DxV conjVg -DxV invgK.
rewrite inE classG_eq1 -in_set1 -(expgK oddG Gx) groupX // inE.
by rewrite -eq_invg_mul DxV conjgE -(cent1P cxy) mulKg.
Qed.

Variables G H : {group gT}.

(* This is Peterfalvi (1.2). *)
Lemma irr_reg_off_ker_0 t g : g \in G ->
  H <| G -> ~~ (H \subset cfker 'chi[G]_t) -> 'C_H[g] = 1%g -> 'chi_t g = 0.
Proof.
pose kerH i := H \subset cfker 'chi[G]_i => Gg nsHG kerH't regHg; apply/eqP.
pose sum_norm2 x := \sum_i `|'chi_i x| ^+ 2.
have norm2_ge0 a: 0 <= `|a| ^+ 2 :> algC by rewrite exprn_ge0 ?normr_ge0.
have{regHg}: sum_norm2 gT G g <= sum_norm2 _ (G / H)%G (coset H g).
  rewrite ![sum_norm2 _ _ _](eq_bigr _ (fun _ _ => normCK _)).
  rewrite !second_orthogonality_relation ?mem_quotient // !class_refl ler_nat.
  suffices /card_isog->: 'C_G[g] \isog 'C_G[g] / H.
    exact/subset_leq_card/quotient_subcent1.
  by apply/quotient_isog; rewrite ?subIset 1?normal_norm // setICA regHg setIg1.
rewrite /sum_norm2 (bigID kerH) ?sum_norm_irr_quo //= -ler_subr_addl subrr.
rewrite ler_eqVlt psumr_eq0 ?ler_gtF ?sumr_ge0 // orbF => /allP/(_ t)/implyP.
by rewrite mem_index_enum kerH't expf_eq0 normr_eq0.
Qed.

(* This is Peterfalvi (1.3)(a). *)
Lemma equiv_restrict_compl A m (Phi : m.-tuple 'CF(H)) (mu : 'CF(G)) d :
    H \subset G -> A <| H -> basis_of 'CF(H, A) Phi ->
  ({in A, mu =1 \sum_i d i *: 'chi_i} <->
    (forall j : 'I_m,
        \sum_i '[Phi`_j, 'chi_i] * (d i)^* = '['Ind[G] Phi`_j, mu])).
Proof.
move=> sHG nsAH BPhi; have [sAH nAH] := andP nsAH.
have APhi (i : 'I_m) : Phi`_i \in 'CF(H, A).
  by apply: (basis_mem BPhi _); apply: mem_nth; rewrite size_tuple.
pose D := 'Res[H] mu - \sum_i d i *: 'chi_i.
transitivity (D \in 'CF(H, H :\: A)).
  split=> [A'D | /cfun_onP A'D x Ax].
    apply/cfun_onP=> x; rewrite inE negb_and negbK.
    case/orP=> [Ax | /cfun0-> //]; rewrite !cfunE -A'D //.
    by rewrite cfResE ?subrr ?(subsetP sAH).
  have:= A'D x; rewrite !cfunE !inE Ax => /(_ isT)/(canRL (subrK _)).
  by rewrite add0r cfResE // ?(subsetP sAH).
have F0 (j : 'I_m) :
   (\sum_i '[Phi`_j, 'chi_i] * (d i)^* == '['Ind Phi`_j, mu])
      = ('[Phi`_j, D] == 0).
  rewrite raddfB raddf_sum /= Frobenius_reciprocity subr_eq0 eq_sym.
  by congr (_ == _); apply: eq_bigr=> i _; rewrite cfdotZr mulrC.
split=> [HH j | HH].
  by apply/eqP; rewrite F0; apply/eqP; apply: cfdot_complement.
have{F0} F1 (j : 'I_m) : '[Phi`_j, D]_H = 0.
  by have/eqP := HH j; rewrite F0 => /eqP.
have: (D \in 'CF(H))%VS by rewrite memvf.
rewrite -(cfun_complement nsAH) => /memv_addP[f Cf [g Cg defD]].
have: '[f, f + g] = 0.
  rewrite -defD (coord_basis BPhi Cf) cfdot_suml.
  by rewrite big1 // => i _; rewrite cfdotZl F1 mulr0.
rewrite raddfD /= {1}(cfdot_complement Cf Cg) addr0 => /eqP.
by rewrite cfnorm_eq0 defD => /eqP->; rewrite add0r.
Qed.

(* This is Peterfalvi (1.3)(b). *)
Lemma equiv_restrict_compl_ortho A m (Phi : m.-tuple 'CF(H)) mu_ :
    H \subset G -> A <| H -> basis_of 'CF(H, A) Phi ->
     (forall i j, '[mu_ i, mu_ j] = (i == j)%:R) ->
     (forall j : 'I_m, 'Ind[G] Phi`_j = \sum_i '[Phi`_j, 'chi_i] *: mu_ i) ->
   [/\ forall i, {in A, mu_ i =1 'chi_i}
     & forall mu, (forall i, '[mu, mu_ i] = 0) -> {in A, forall x, mu x = 0}].
Proof.
move=> HsG nsAH /equiv_restrict_compl Phi_A Mo IP; split=> [/= i | mu Cmu x Ax].
  have->: 'chi[H]_i = \sum_j (j == i)%:R *: 'chi_j.
    rewrite (bigD1 i) //= eqxx scale1r big1 ?addr0 // => j /negPf->.
    by rewrite scale0r.
  apply/Phi_A=> // j; rewrite IP cfdot_suml.
  by apply: eq_bigr=> k _; rewrite cfdotZl rmorph_nat Mo.
transitivity ((\sum_j 0 *: 'chi[H]_j) x); last first.
  by rewrite sum_cfunE big1 // => j _; rewrite cfunE mul0r.
move: x Ax; apply/Phi_A=> // j.
rewrite -mulr_suml rmorph0 mulr0 IP cfdot_suml big1 // => k _.
by rewrite cfdotZl [d in _ * d]cfdotC Cmu rmorph0 mulr0.
Qed.

Let vchar_isometry_base3 f f' :
  f \in 'Z[irr G, G^#] -> '[f]_G = 2%:R ->
  f' \in 'Z[irr G, G^#] -> '[f']_G = 2%:R ->
  '[f, f'] = 1 ->
   exists es : _ * bool, let: (i, j, k, epsilon) := es in
     [/\  f = (-1) ^+ epsilon *: ('chi_j - 'chi_i),
          f' = (-1) ^+ epsilon *: ('chi_j - 'chi_k)
        & uniq [:: i; j; k]].
Proof.
move=> Hf H2f Hf1 H2f1.
have [j [i neq_ij ->]] := vchar_norm2 Hf H2f.
have [j' [k neq_kj' ->]] := vchar_norm2 Hf1 H2f1.
rewrite cfdotBl !cfdotBr !cfdot_irr opprB addrAC !addrA.
do 2!move/(canRL (subrK _)); rewrite -(natrD _ 1) -!natrD => /eqP.
rewrite eqr_nat; have [eq_jj' | neq_jj'] := altP (j =P j').
  rewrite (eq_sym j) -eq_jj' {1}eq_jj' (negbTE neq_ij) (negbTE neq_kj').
  rewrite eqSS (can_eq oddb) => /eqP neq_ik; exists (i, j, k, false).
  by rewrite !scaler_sign /= !inE neq_ik orbF neq_ij eq_sym eq_jj' neq_kj'.
case: (i =P k) => // eq_ik; exists (j, i, j', true).
rewrite !scaler_sign !opprB /= !inE eq_sym negb_or neq_ij neq_jj'.
by rewrite eq_ik neq_kj'.
Qed.

Let vchar_isometry_base4 (eps : bool) i j k n m :
    let f1 := 'chi_j - 'chi_i in
    let f2 := 'chi_k - 'chi_i in
    let f3 := 'chi_n - 'chi_m in
    j != k -> '[f3, f1]_G = (-1) ^+ eps -> '[f3, f2] = (-1) ^+ eps ->
  if eps then n == i else m == i.
Proof.
move=> /= Hjk; wlog ->: eps n m / eps = false.
  case: eps; last exact; move/(_ false m n)=> IH nm_ji nm_ki.
  by apply: IH; rewrite // -opprB cfdotNl (nm_ji, nm_ki) opprK.
rewrite !cfdotBl !cfdotBr !cfdot_irr !opprB addrAC addrA.
do 2!move/(canRL (subrK _)); rewrite -(natrD _ 1) -!natrD.
move/(can_inj natCK); case: (m == i) => //.
case: eqP => // ->; case: (j == i) => // _.
rewrite subr0 add0r => /(canRL (subrK _)); rewrite -(natrD _ 1).
by move/(can_inj natCK); rewrite (negbTE Hjk).
Qed.

(* This is Peterfalvi (1.4). *)
Lemma vchar_isometry_base m L (Chi : m.-tuple 'CF(H))
                            (tau : {linear 'CF(H) -> 'CF(G)}) :
    (1 < m)%N -> {subset Chi <= irr H} -> free Chi ->
    (forall chi, chi \in Chi -> chi 1%g = Chi`_0 1%g) ->
    (forall i : 'I_m, (Chi`_i - Chi`_0) \in 'CF(H, L)) ->
    {in 'Z[Chi, L], isometry tau, to 'Z[irr G, G^#]} ->
    exists2 mu : m.-tuple (Iirr G),
      uniq mu
    & exists epsilon : bool, forall i : 'I_m,
      tau (Chi`_i - Chi`_0) = (-1) ^+ epsilon *: ('chi_(mu`_i) - 'chi_(mu`_0)).
Proof.
case: m Chi => [|[|m]] // Chi _ irrChi Chifree Chi1 ChiCF [iso_tau Ztau].
rewrite -(tnth_nth 0 _ 0); set chi := tnth Chi.
have chiE i: chi i = Chi`_i by rewrite -tnth_nth.
have inChi i: chi i \in Chi by apply: mem_tnth.
have{irrChi} irrChi i: chi i \in irr H by apply: irrChi.
have eq_chi i j: (chi i == chi j) = (i == j).
  by rewrite /chi !(tnth_nth 0) nth_uniq ?size_tuple ?free_uniq.
have dot_chi i j: '[chi i, chi j] = (i == j)%:R.
  rewrite -eq_chi; have [/irrP[{i}i ->] /irrP[{j}j ->]] := (irrChi i,irrChi j).
  by rewrite cfdot_irr inj_eq //; apply: irr_inj.
pose F i j := chi i - chi j.
have DF i j : F i j =  F i 0 - F j 0 by rewrite /F opprB addrA subrK.
have ZF i j: F i j \in 'Z[Chi, L].
  by rewrite zchar_split rpredB ?mem_zchar // DF memvB // /F !chiE.
have htau2 i j: i != j -> '[tau (F i j)] = 2%:R.
  rewrite iso_tau // cfnormB -cfdotC !dot_chi !eqxx eq_sym => /negbTE->.
  by rewrite -!natrD subr0.
have htau1 i j: j != 0 -> j != i -> i != 0 -> '[tau (F i 0), tau (F j 0)] = 1.
  rewrite iso_tau // cfdotBl !cfdotBr opprB !dot_chi !(eq_sym j).
  by do 3!move/negbTE->; rewrite !subr0 add0r.
have [m0 | nz_m] := boolP (m == 0%N).
  rewrite -2!eqSS eq_sym in m0; move: (htau2 1 0 isT).
  case/(vchar_norm2 (Ztau _ (ZF 1 0))) => [k1 [k0 neq_k01 eq_mu]].
  pose mu := @Tuple _ _ [:: k0; k1] m0.
  exists mu; first by rewrite /= andbT inE.
  exists false => i; rewrite scale1r chiE.
  have: (i : nat) \in iota 0 2 by rewrite mem_iota (eqP m0) (valP i).
  rewrite !inE; case/pred2P=> ->; first by rewrite !subrr linear0.
  by rewrite -eq_mu /F !chiE.
have m_gt2: (2 < m.+2)%N by rewrite !ltnS lt0n.
pose i2 := Ordinal m_gt2.
case: (@vchar_isometry_base3 (tau (F 1 0)) (tau (F i2 0))); auto.
case=> [[[k1 k0] k2] e] []; set d := (-1) ^+ e => eq10 eq20.
rewrite /= !inE => /and3P[/norP[nek10 nek12]]; rewrite eq_sym => nek20 _.
have muP i:
  {k | (i == 0) ==> (k == k0) & tau (F i 0) == d *: ('chi_k0 - 'chi_k)}.
- apply: sig2W; have [-> | nei0] := altP (i =P 0).
    by exists k0; rewrite ?eqxx // /F !subrr !linear0.
  have /(vchar_norm2 (Ztau _ (ZF i 0)))[k [k' nekk' eqFkk']] := htau2 i 0 nei0.
  have [-> | neq_i1] := eqVneq i 1; first by exists k1; rewrite // -eq10.
  have [-> | neq_i2] := eqVneq i i2; first by exists k2; rewrite // -eq20.
  have:= @vchar_isometry_base4 (~~ e) k0 k1 k2 k k' nek12.
  have ZdK u v w: '[u, v - w]_G = (-1) ^+ (~~ e) * '[u, d *: (w - v)].
    rewrite cfdotZr rmorph_sign mulrA -signr_addb addNb addbb mulN1r.
    by rewrite -cfdotNr opprB.
  rewrite -eqFkk' ZdK -eq10 {}ZdK -eq20 !htau1 //; try by rewrite eq_sym.
  move/(_ (mulr1 _) (mulr1 _)); rewrite /d eqFkk'.
  by case e => /eqP <-; [exists k | exists k']; rewrite ?scaler_sign ?opprB.
pose mu := [tuple of [seq s2val (muP i) | i <- ord_tuple m.+2]]; exists mu.
  rewrite map_inj_uniq ?enum_uniq // => i j.
  case: (muP i) (muP j) => /= ki _ /eqP eq_i0 [/= kj _ /eqP eq_j0] eq_kij.
  apply/eqP; rewrite -eq_chi -subr_eq0 -cfnorm_eq0 -iso_tau ?ZF //.
  rewrite -[chi i](subrK (chi 0)) -addrA linearD eq_i0 eq_kij -eq_j0.
  by rewrite -linearD -opprB subrr !raddf0.
exists (~~ e) => i; rewrite -addbT signr_addb -/d -scalerA scaleN1r opprB.
rewrite -!tnth_nth -/(F i 0) tnth_map tnth_ord_tuple.
suffices /= ->: mu`_0 = k0 by case: (muP i) => /= k _ /eqP.
rewrite -(tnth_nth 0 _ 0) tnth_map tnth_ord_tuple.
by case: (muP 0) => /= k /(k =P k0).
Qed.

(* This is Peterfalvi (1.5)(a). *)
Lemma cfResInd_sum_cfclass t : H <| G ->
  'Res[H] ('Ind[G] 'chi_t)
     = #|'I_G['chi_t] : H|%:R *: \sum_(xi <- ('chi_t ^: G)%CF) xi.
Proof.
set T := 'I_G['chi_t] => nsHG; have [sHG nHG] := andP nsHG.
apply/cfun_inP=> h Hh; rewrite cfResE ?cfIndE // cfunE sum_cfunE.
apply: (canLR (mulKf (neq0CG H))).
rewrite mulrA -natrM Lagrange ?sub_Inertia //= -/T reindex_cfclass //=.
rewrite mulr_sumr [s in _ = s]big_mkcond /= (reindex_inj invg_inj).
rewrite (partition_big (conjg_Iirr t) xpredT) //=; apply: eq_bigr => i _.
have [[y Gy chi_i] | not_i_t] := cfclassP _ _ _; last first.
  apply: big1 => z; rewrite groupV => /andP[Gz /eqP def_i].
  by case: not_i_t; exists z; rewrite // -def_i conjg_IirrE.
rewrite  -(card_rcoset _ y) mulr_natl -sumr_const; apply: eq_big => z.
  rewrite -(inj_eq irr_inj) conjg_IirrE chi_i mem_rcoset inE groupMr ?groupV //.
  apply: andb_id2l => Gz; rewrite eq_sym (cfConjg_eqE _ nsHG) //.
  by rewrite mem_rcoset inE groupM ?groupV.
rewrite groupV => /andP[Gz /eqP <-].
by rewrite conjg_IirrE cfConjgE ?(subsetP nHG).
Qed.

(* This is Peterfalvi (1.5)(b), main formula. *)
Lemma cfnorm_Ind_irr t :
  H <| G -> '['Ind[G] 'chi[H]_t] = #|'I_G['chi_t] : H|%:R.
Proof.
set r := _%:R => HnG; have HsG := normal_sub HnG.
rewrite -Frobenius_reciprocity cfResInd_sum_cfclass //= cfdotZr rmorph_nat -/r.
rewrite reindex_cfclass // cfdot_sumr (bigD1 t) ?cfclass_refl //= cfnorm_irr.
rewrite big1 ?addr0 ?mulr1 // => j /andP[_ /negbTE].
by rewrite eq_sym cfdot_irr => ->.
Qed.

(* This is Peterfalvi (1.5)(b), irreducibility remark. *)
Lemma inertia_Ind_irr t :
  H <| G -> 'I_G['chi[H]_t] \subset H -> 'Ind[G] 'chi_t \in irr G.
Proof.
rewrite -indexg_eq1 => nsHG /eqP r1.
by rewrite irrEchar cfInd_char ?irr_char //= cfnorm_Ind_irr ?r1.
Qed.

(* This is Peterfalvi (1.5)(c). *)
Lemma cfclass_Ind_cases t1 t2 : H <| G ->
   if 'chi_t2 \in ('chi[H]_t1 ^: G)%CF
   then 'Ind[G] 'chi_t1 = 'Ind[G] 'chi_t2
   else '['Ind[G] 'chi_t1, 'Ind[G] 'chi_t2] = 0.
Proof.
move=> nsHG; have [/cfclass_Ind-> // | not_ch1Gt2] := ifPn.
rewrite -Frobenius_reciprocity cfResInd_sum_cfclass // cfdotZr rmorph_nat.
rewrite cfdot_sumr reindex_cfclass // big1 ?mulr0 // => j; rewrite cfdot_irr.
case: eqP => // <- /idPn[]; apply: contra not_ch1Gt2 => /cfclassP[y Gy ->].
by apply/cfclassP; exists y^-1%g; rewrite ?groupV ?cfConjgK.
Qed.

(* Useful consequences of (1.5)(c) *)
Lemma not_cfclass_Ind_ortho i j :
    H <| G -> ('chi_i \notin 'chi_j ^: G)%CF ->
  '['Ind[G, H] 'chi_i, 'Ind[G, H] 'chi_j] = 0.
Proof. by move/(cfclass_Ind_cases i j); rewrite cfclass_sym; case: ifP. Qed.

Lemma cfclass_Ind_irrP i j :
    H <| G ->
  reflect ('Ind[G, H] 'chi_i = 'Ind[G, H] 'chi_j) ('chi_i \in 'chi_j ^: G)%CF.
Proof.
move=> nsHG; have [sHG _] := andP nsHG.
case: ifP (cfclass_Ind_cases j i nsHG) => [|_ Oji]; first by left.
right=> eq_chijG; have /negP[]: 'Ind[G] 'chi_i != 0 by apply: Ind_irr_neq0.
by rewrite -cfnorm_eq0 {1}eq_chijG Oji.
Qed.

Lemma card_imset_Ind_irr (calX : {set Iirr H}) :
    H <| G -> {in calX, forall i, 'Ind 'chi_i \in irr G} ->
    {in calX & G, forall i y, conjg_Iirr i y \in calX} ->
  #|calX| = (#|G : H| * #|[set cfIirr ('Ind[G] 'chi_i) | i in calX]|)%N.
Proof.
move=> nsHG irrIndX sXGX; have [sHG _] := andP nsHG; set f := fun i => cfIirr _.
rewrite -sum1_card (partition_big_imset f) /= mulnC -sum_nat_const.
apply: eq_bigr => _ /imsetP[i Xi ->]; transitivity (size (cfclass 'chi_i G)).
  rewrite -sum1_size reindex_cfclass //; apply: eq_bigl => j.
  case Xj: (j \in calX).
    rewrite -(inj_eq irr_inj) !(cfIirrPE irrIndX) //.
    exact/eqP/cfclass_Ind_irrP.
  apply/esym/(contraFF _ Xj)=> /cfclassP[y Gy Dj].
  by rewrite -conjg_IirrE in Dj; rewrite (irr_inj Dj) sXGX.
rewrite -(Lagrange_index (Inertia_sub G 'chi_i)) ?sub_Inertia //.
rewrite -size_cfclass ((#|_ : _| =P 1)%N _) ?muln1 // -eqC_nat.
by rewrite -cfnorm_Ind_irr // -(cfIirrPE irrIndX) ?cfnorm_irr.
Qed.

(* This is Peterfalvi (1.5)(d). *)
Lemma scaled_cfResInd_sum_cfclass t : H <| G ->
  let chiG := 'Ind[G] 'chi_t in
  (chiG 1%g / '[chiG]) *: 'Res[H] chiG
     = #|G : H|%:R *: (\sum_(xi <- ('chi_t ^: G)%CF) xi 1%g *: xi).
Proof.
move=> nsHG chiG; have [sHG _] := andP nsHG.
rewrite cfResInd_sum_cfclass // cfnorm_Ind_irr // scalerA cfInd1 //.
rewrite divfK ?pnatr_eq0 -?lt0n // -scalerA linear_sum !reindex_cfclass //=.
congr (_ *: _); apply: eq_bigr => _ /cfclassP[y _ ->].
by rewrite cfConjg1.
Qed.

(* This is Peterfalvi (1.5)(e). *)
Lemma odd_induced_orthogonal t :
     H <| G -> odd #|G| -> t != 0 ->
  '['Ind[G, H] 'chi_t, ('Ind[G] 'chi_t)^*] = 0.
Proof.
move=> nsHG oddG nz_t; have [sHG _] := andP nsHG.
have:= cfclass_Ind_cases t (conjC_Iirr t) nsHG.
rewrite conjC_IirrE conj_cfInd; case: cfclassP => // [[g Gg id_cht]].
have oddH: odd #|H| := pgroup.oddSg sHG oddG.
case/eqP: nz_t; apply: irr_inj; rewrite irr0.
apply/eqP; rewrite -odd_eq_conj_irr1 // id_cht; apply/eqP.
have F1: ('chi_t ^ (g ^+ 2))%CF = 'chi_t.
  rewrite (cfConjgM _ nsHG) // -id_cht -conj_cfConjg -id_cht.
  exact: cfConjCK.
suffices /eqP->: g == ((g ^+ 2) ^+ #|G|./2.+1)%g.
  elim: _./2.+1 => [|n IHn]; first exact: cfConjgJ1.
  by rewrite expgS (cfConjgM _ nsHG) ?groupX // F1.
rewrite eq_mulVg1 expgS -expgM mul2n -mulgA mulKg -expgS -order_dvdn.
by rewrite -add1n -[1%N](congr1 nat_of_bool oddG) odd_double_half order_dvdG.
Qed.

(* This is Peterfalvi (1.6)(a). *)
Lemma sub_cfker_Ind_irr A i :
    H \subset G -> G \subset 'N(A) ->
  (A \subset cfker ('Ind[G, H] 'chi_i)) = (A \subset cfker 'chi_i).
Proof. by move=> sHG nAG; rewrite cfker_Ind_irr ?sub_gcore. Qed.

(* Some consequences and related results. *)
Lemma sub_cfker_Ind (A : {set gT}) chi :
    A \subset H -> H \subset G -> G \subset 'N(A) -> chi \is a character ->
  (A \subset cfker ('Ind[G, H] chi)) = (A \subset cfker chi).
Proof.
move=> sAH sHG nAG Nchi; have [-> | nz_chi] := eqVneq chi 0.
  by rewrite raddf0 !cfker_cfun0 !(subset_trans sAH).
by rewrite cfker_Ind ?sub_gcore.
Qed.

Lemma cfInd_irr_eq1 i :
  H <| G -> ('Ind[G, H] 'chi_i == 'Ind[G, H] 1) = (i == 0).
Proof.
case/andP=> sHG nHG; apply/eqP/idP=> [chi1 | /eqP->]; last by rewrite irr0.
rewrite -subGcfker -(sub_cfker_Ind_irr _ sHG nHG) chi1 -irr0.
by rewrite sub_cfker_Ind_irr ?cfker_irr0.
Qed.

Lemma sub_cfker_constt_Res_irr (A : {set gT}) i j :
    j \in irr_constt ('Res[H, G] 'chi_i) ->
    A \subset H -> H \subset G -> G \subset 'N(A) ->
  (A \subset cfker 'chi_j) = (A \subset cfker 'chi_i).
Proof.
move=> iHj sAH sHG nAG; apply/idP/idP=> kerA.
  have jGi: i \in irr_constt ('Ind 'chi_j) by rewrite constt_Ind_Res.
  rewrite (subset_trans _ (cfker_constt _ jGi)) ?cfInd_char ?irr_char //=.
  by rewrite sub_cfker_Ind_irr.
rewrite (subset_trans _ (cfker_constt _ iHj)) ?cfRes_char ?irr_char //=.
by rewrite cfker_Res ?irr_char // subsetI sAH.
Qed.

Lemma sub_cfker_constt_Ind_irr (A : {set gT}) i j :
    i \in irr_constt ('Ind[G, H] 'chi_j) ->
    A \subset H -> H \subset G -> G \subset 'N(A) ->
  (A \subset cfker 'chi_j) = (A \subset cfker 'chi_i).
Proof. by rewrite constt_Ind_Res; apply: sub_cfker_constt_Res_irr. Qed.

(* This is a stronger version of Peterfalvi (1.6)(b). *)
Lemma cfIndMod (K : {group gT}) (phi : 'CF(H / K)) :
    K \subset H -> H \subset G -> K <| G ->
  'Ind[G] (phi %% K)%CF = ('Ind[G / K] phi %% K)%CF.
Proof. by move=> sKH sHG /andP[_ nKG]; rewrite cfIndMorph ?ker_coset. Qed.

Lemma cfIndQuo (K : {group gT}) (phi : 'CF(H)) :
    K \subset cfker phi -> H \subset G -> K <| G ->
  'Ind[G / K] (phi / K)%CF = ('Ind[G] phi / K)%CF.
Proof.
move=> kerK sHG nsKG; have sKH := subset_trans kerK (cfker_sub phi).
have nsKH := normalS sKH sHG nsKG.
by apply: canRL (cfModK nsKG) _; rewrite -cfIndMod // cfQuoK.
Qed.

Section IndSumInertia.

Variable s : Iirr H.

Let theta := 'chi_s.
Let T := 'I_G[theta].
Let calA := irr_constt ('Ind[T] theta).
Let calB := irr_constt ('Ind[G] theta).
Let AtoB (t : Iirr T) := Ind_Iirr G t.
Let e_ t := '['Ind theta, 'chi[T]_t].

Hypothesis nsHG: H <| G.
(* begin hide *)
Let sHG : H \subset G. Proof. exact: normal_sub. Qed.
Let nHG : G \subset 'N(H). Proof. exact: normal_norm. Qed.
Let nsHT : H <| T. Proof. exact: normal_Inertia. Qed.
Let sHT : H \subset T. Proof. exact: normal_sub. Qed.
Let nHT : T \subset 'N(H). Proof. exact: normal_norm. Qed.
Let sTG : T \subset G. Proof. exact: subsetIl. Qed.
(* end hide *)

(* This is Peterfalvi (1.7)(a). *)
Lemma cfInd_sum_Inertia :
  [/\ {in calA, forall t, 'Ind 'chi_t \in irr G},
      {in calA, forall t, 'chi_(AtoB t) = 'Ind 'chi_t},
      {in calA &, injective AtoB},
      AtoB @: calA =i calB
    & 'Ind[G] theta = \sum_(t in calA) e_ t *: 'Ind 'chi_t].
Proof.
have [AtoBirr AtoBinj defB _ _] := constt_Inertia_bijection s nsHG.
split=> // [i Ai|]; first exact/cfIirrE/AtoBirr.
rewrite -(cfIndInd _ sTG sHT) {1}['Ind theta]cfun_sum_constt linear_sum.
by apply: eq_bigr => i _; rewrite linearZ.
Qed.

Hypothesis abTbar : abelian (T / H).

(* This is Peterfalvi (1.7)(b). *)
Lemma cfInd_central_Inertia :
   exists2 e, [/\ e \in Cnat, e != 0 & {in calA, forall t, e_ t = e}]
           & [/\ 'Ind[G] theta = e *: \sum_(j in calB) 'chi_j,
                 #|calB|%:R = #|T : H|%:R / e ^+ 2
               & {in calB, forall i, 'chi_i 1%g = #|G : T|%:R * e * theta 1%g}].
Proof.
have [t1 At1] := constt_cfInd_irr s sHT; pose psi1 := 'chi_t1.
pose e := '['Ind theta, psi1].
have NthT: 'Ind[T] theta \is a character by rewrite cfInd_char ?irr_char.
have Ne: e \in Cnat by rewrite Cnat_cfdot_char_irr.
have Dpsi1H: 'Res[H] psi1 = e *: theta.
  have psi1Hs: s \in irr_constt ('Res psi1) by rewrite -constt_Ind_Res.
  rewrite (Clifford_Res_sum_cfclass nsHT psi1Hs) cfclass_invariant ?subsetIr //.
  by rewrite big_seq1 cfdot_Res_l cfdotC conj_Cnat.
have linL j: 'chi[T / H]_j \is a linear_char by apply/char_abelianP.
have linLH j: ('chi_j %% H)%CF \is a linear_char := cfMod_lin_char (linL j).
pose LtoT (j : Iirr (T / H)) := mul_mod_Iirr t1 j.
have LtoTE j: 'chi_(LtoT j) = ('chi_j %% H)%CF * psi1.
  by rewrite !(mod_IirrE, cfIirrE) // mul_lin_irr ?mem_irr ?cfMod_lin_char.
have psiHG: 'Ind ('Res[H] psi1) = \sum_j 'chi_(LtoT j).
  transitivity ((cfReg (T / H) %% H)%CF * psi1); last first.
    rewrite cfReg_sum linear_sum /= mulr_suml; apply: eq_bigr => i _.
    by rewrite LtoTE // lin_char1 ?scale1r.
  apply/cfun_inP=> x Tx; rewrite cfunE cfModE // cfRegE mulrnAl mulrb.
  rewrite (sameP eqP (kerP _ (subsetP nHT x Tx))) ker_coset.
  case: ifPn => [Hx | H'x]; last by rewrite (cfun_on0 (cfInd_normal _  _)).
  rewrite card_quotient // -!(cfResE _ sHT) // cfRes_Ind_invariant ?cfunE //.
  by rewrite -subsetIidl (subset_trans _ (sub_inertia_Res _ _)) ?sub_Inertia.
have imLtoT: {subset calA <= codom LtoT}.
  move=> t At; apply/codomP/exists_eqP.
  have{At}: t \in irr_constt ('Ind ('Res[H] 'chi_t1)).
    by rewrite Dpsi1H linearZ irr_consttE cfdotZl mulf_neq0.
  apply: contraR; rewrite negb_exists => /forallP imL't.
  by rewrite psiHG cfdot_suml big1 // => j _; rewrite cfdot_irr mulrb ifN_eqC.
have De_ t: t \in calA -> e_ t = e.
  case/imLtoT/codomP=> j ->; rewrite /e_ LtoTE /e -!cfdot_Res_r rmorphM /=.
  by rewrite cfRes_sub_ker ?cfker_mod // mulr_algl lin_char1 ?scale1r.
have{imLtoT} A_1 t: t \in calA -> 'chi_t 1%g = e * theta 1%g.
  case/imLtoT/codomP=> j ->; rewrite LtoTE //= cfunE.
  by rewrite (lin_char1 (linLH j)) mul1r -(cfRes1 H) Dpsi1H cfunE.
exists e => //; have [_ defAtoB injAtoB imAtoB ->] := cfInd_sum_Inertia.
rewrite -(eq_bigl _ _ imAtoB) -(eq_card imAtoB) big_imset //= scaler_sumr.
split=> [||i]; first by apply: eq_bigr => t2 At2; rewrite De_ ?defAtoB.
  apply: (mulIf (irr1_neq0 s)); rewrite mulrAC -cfInd1 // mulr_natl mulrC invfM.
  rewrite ['Ind _]cfun_sum_constt sum_cfunE mulr_sumr card_in_imset //.
  rewrite -sumr_const; apply: eq_bigr => t At.
  by rewrite -mulrA -/(e_ t) De_ // cfunE A_1 ?mulKf.
by rewrite -imAtoB => /imsetP[t At ->]; rewrite defAtoB ?cfInd1 ?A_1 ?mulrA.
Qed.

(* This is Peterfalvi (1.7)(c). *)
Lemma cfInd_Hall_central_Inertia :
     Hall T H ->
  [/\ 'Ind[G] theta = \sum_(i in calB) 'chi_i, #|calB| = #|T : H|
    & {in calB, forall i, 'chi_i 1%g = #|G : T|%:R * theta 1%g}].
Proof.
case/andP=> _ hallH; have [e [_ _ De]] := cfInd_central_Inertia.
suffices ->: e = 1.
  by case=> -> /eqP; rewrite scale1r expr1n divr1 mulr1 eqC_nat => /eqP.
suffices{De} [t Dtheta]: exists i, 'Res[H, T] 'chi_i = theta.
  have e_t_1: e_ t = 1 by rewrite /e_ -cfdot_Res_r Dtheta cfnorm_irr.
  by rewrite -(De t) // irr_consttE -/(e_ t) e_t_1 oner_eq0.
have ITtheta: T \subset 'I[theta] := subsetIr _ _.
have solT: solvable (T / H) := abelian_sol abTbar.
have [|t []] := extend_solvable_coprime_irr nsHT solT ITtheta; last by exists t.
rewrite coprime_sym coprime_mull !(coprime_dvdl _ hallH) ?cfDet_order_dvdG //.
by rewrite -dvdC_nat !CdivE truncCK ?Cnat_irr1 // dvd_irr1_cardG.
Qed.

End IndSumInertia.

(* This is Peterfalvi (1.8). *)
Lemma irr1_bound_quo (B C D : {group gT}) i :
    B <| C -> B \subset cfker 'chi[G]_i ->
    B \subset D -> D \subset C -> C \subset G -> (D / B \subset 'Z(C / B))%g ->
  'chi_i 1%g <= #|G : C|%:R * sqrtC #|C : D|%:R.
Proof.
move=> BnC BsK BsD DsC CsG QsZ.
case: (boolP ('Res[C] 'chi_i == 0))=> [HH|].
  have: ('Res[C] 'chi_i) 1%g = 0 by rewrite (eqP HH) cfunE.
  by rewrite cfResE // => HH1; case/eqP: (irr1_neq0 i).
have IC := cfRes_char C (irr_char i).
case/neq0_has_constt=> i1 Hi1.
have CIr: i \in irr_constt ('Ind[G] 'chi_i1).
  by rewrite inE /= -Frobenius_reciprocity /= cfdotC conjC_eq0.
have BsKi : B \subset cfker 'chi_i1.
  suff BsKri: B \subset cfker ('Res[C] 'chi_i).
    by apply: (subset_trans BsKri); apply: (cfker_constt _ Hi1).
  apply/subsetP=> g GiG.
  have F: g \in C by rewrite (subsetP (subset_trans BsD _)).
  rewrite cfkerEchar // inE F !cfResE //.
  by move: (subsetP BsK _ GiG); rewrite cfkerEirr inE.
pose i2 := quo_Iirr B i1.
have ZsC: 'Z(C / B)%g \subset 'Z('chi_i2)%CF.
    by rewrite -(cap_cfcenter_irr (C / B)); apply: bigcap_inf.
have CBsH: C :&: B \subset D.
    apply/subsetP=> g; rewrite inE; case/andP=> _ HH.
    by apply: (subsetP (BsD)).
have I1B: 'chi_i1 1%g ^+ 2 <= #|C : D|%:R.
  case: (irr1_bound i2)=> HH _; move: HH.
  have ->: 'chi_i2 1%g = 'chi_i1 1%g.
    by rewrite quo_IirrE // -(coset_id (group1 B)) cfQuoE.
  move/ler_trans; apply.
  rewrite ler_nat // -(index_quotient_eq CBsH) ?normal_norm //.
  rewrite -(@leq_pmul2l #|'Z('chi_i2)%CF|) ?cardG_gt0 ?cfcenter_sub //.
  rewrite  Lagrange ?quotientS ?cfcenter_sub //.
  rewrite -(@leq_pmul2l #|(D / B)%g|) ?cardG_gt0 //.
  rewrite mulnA mulnAC Lagrange ?quotientS //.
  rewrite mulnC leq_pmul2l ?cardG_gt0 // subset_leq_card //.
  exact: subset_trans QsZ ZsC.
have IC': 'Ind[G] 'chi_i1 \is a character := cfInd_char G (irr_char i1).
move: (char1_ge_constt IC' CIr); rewrite cfInd1 //= => /ler_trans-> //.
have chi1_1_ge0: 0 <= 'chi_i1 1%g by rewrite ltrW ?irr1_gt0.
rewrite ler_pmul2l ?gt0CiG //.
by rewrite -(@ler_pexpn2r _ 2) -?topredE /= ?sqrtC_ge0 ?ler0n ?sqrtCK.
Qed.

(* This is Peterfalvi (1.9)(a). *)
Lemma extend_coprime_Qn_aut a b (Qa Qb : fieldExtType rat) w_a w_b
          (QaC : {rmorphism Qa -> algC}) (QbC : {rmorphism Qb -> algC})
          (mu : {rmorphism algC -> algC}) :
    coprime a b ->
    a.-primitive_root w_a /\ <<1; w_a>>%VS = {:Qa}%VS ->
    b.-primitive_root w_b /\ <<1; w_b>>%VS = {:Qb}%VS ->
  {nu : {rmorphism algC -> algC} | forall x, nu (QaC x) = mu (QaC x)
                                 & forall y, nu (QbC y) = QbC y}.
Proof.
move=> coab [pr_w_a genQa] [pr_w_b genQb].
have [k co_k_a Dmu]: {k | coprime k a & mu (QaC w_a) = QaC (w_a ^+ k)}.
  have prCw: a.-primitive_root (QaC w_a) by rewrite fmorph_primitive_root.
  by have [k coka ->] := aut_prim_rootP mu prCw; rewrite -rmorphX; exists k.
pose k1 := chinese a b k 1; have /Qn_aut_exists[nu Dnu]: coprime k1 (a * b).
  rewrite coprime_mulr -!(coprime_modl k1) chinese_modl ?chinese_modr //.
  by rewrite !coprime_modl co_k_a coprime1n.
exists nu => [x | y].
  have /Fadjoin_polyP[p Qp ->]: x \in <<1; w_a>>%VS by rewrite genQa memvf.
  rewrite -!horner_map -!map_poly_comp !map_Qnum_poly // Dmu Dnu -rmorphX /=.
    by rewrite -(prim_expr_mod pr_w_a) chinese_modl // prim_expr_mod.
  by rewrite exprM (prim_expr_order pr_w_a) expr1n rmorph1.
have /Fadjoin_polyP[p Qp ->]: y \in <<1; w_b>>%VS by rewrite genQb memvf.
rewrite -!horner_map -!map_poly_comp !map_Qnum_poly // Dnu -rmorphX /=.
  by rewrite -(prim_expr_mod pr_w_b) chinese_modr // prim_expr_mod.
by rewrite mulnC exprM (prim_expr_order pr_w_b) expr1n rmorph1.
Qed.

(* This intermediate result in the proof of Peterfalvi (1.9)(b) is used in    *)
(* he proof of (3.9)(c).                                                      *)
Lemma dvd_restrict_cfAut a (v : {rmorphism algC -> algC}) :
  exists2 u : {rmorphism algC -> algC},
    forall gT0 G0 chi x,
      chi \in 'Z[irr (@gval gT0 G0)] -> #[x] %| a -> u (chi x) = v (chi x)
  & forall chi x, chi \in 'Z[irr G] -> coprime #[x] a -> u (chi x) = chi x.
Proof.
have [-> | a_gt0] := posnP a.
  exists v => // chi x Zchi; rewrite /coprime gcdn0 order_eq1 => /eqP->.
  by rewrite aut_Cint ?Cint_vchar1.
pose b := (#|G|`_(\pi(a)^'))%N.
have co_a_b: coprime a b := pnat_coprime (pnat_pi a_gt0) (part_pnat _ _).
have [Qa _ [QaC _ [w_a genQa memQa]]] := group_num_field_exists [group of Zp a].
have [Qb _ [QbC _ [w_b genQb memQb]]] := group_num_field_exists [group of Zp b].
rewrite !card_Zp ?part_gt0 // in Qa QaC w_a genQa memQa Qb QbC w_b genQb memQb.
have [nu nuQa nuQb] := extend_coprime_Qn_aut QaC QbC v co_a_b genQa genQb.
exists nu => [gt0 G0 chi x Zchi x_dv_a | chi x Zchi co_x_a].
  without loss{Zchi} Nchi: chi / chi \is a character.
    move=> IH; case/vcharP: Zchi => [chi1 Nchi1 [chi2 Nchi2 ->]].
    by rewrite !cfunE !rmorphB !IH.
  by have [xa <-] := memQa _ _ _ Nchi x x_dv_a; rewrite nuQa.
without loss{Zchi} Nchi: chi / chi \is a character.
  move=> IH; case/vcharP: Zchi => [chi1 Nchi1 [chi2 Nchi2 ->]].
  by rewrite !cfunE rmorphB !IH.
have [Gx | /cfun0->] := boolP (x \in G); last by rewrite rmorph0.
have{Gx} x_dv_b: (#[x] %| b)%N.
  rewrite coprime_sym coprime_pi' // in co_x_a.
  by rewrite -(part_pnat_id co_x_a) partn_dvd ?order_dvdG.
by have [xb <-] := memQb _ _ _ Nchi x x_dv_b; rewrite nuQb.
Qed.

(* This is Peterfalvi (1.9)(b). *)
(* We have strengthened the statement of this lemma so that it can be used    *)
(* rather than reproved for Peterfalvi (3.9). In particular we corrected a    *)
(* quantifier inversion in the original statement: the automorphism is        *)
(* constructed uniformly for all (virtual) characters. We have also removed   *)
(* the spurrious condition that a be a \pi(a) part of #|G| -- the proof works *)
(* for all a, and indeed the first part holds uniformaly for all groups!      *)
Lemma make_pi_cfAut a k :
    coprime k a ->
  exists2 u : {rmorphism algC -> algC},
    forall (gT0 : finGroupType) (G0 : {group gT0}) chi x,
      chi \in 'Z[irr G0] -> #[x] %| a -> cfAut u chi x = chi (x ^+ k)%g
  & forall chi x, chi \in 'Z[irr G] -> coprime #[x] a -> cfAut u chi x = chi x.
Proof.
move=> co_k_a; have [v Dv] := Qn_aut_exists co_k_a.
have [u Du_a Du_a'] := dvd_restrict_cfAut a v.
exists u => [gt0 G0 | ] chi x Zchi a_x; last by rewrite cfunE Du_a'.
rewrite cfunE {u Du_a'}Du_a //.
without loss{Zchi} Nchi: chi / chi \is a character.
  move=> IH; case/vcharP: Zchi => [chi1 Nchi1 [chi2 Nchi2 ->]].
  by rewrite !cfunE rmorphB !IH.
have [sXG0 | G0'x] := boolP (<[x]> \subset G0); last first.
  have /(<[x]> =P _) gen_xk: generator <[x]> (x ^+ k).
    by rewrite generator_coprime coprime_sym (coprime_dvdr a_x).
  by rewrite !cfun0 ?rmorph0 -?cycle_subG -?gen_xk.
rewrite -!(cfResE chi sXG0) ?cycle_id ?mem_cycle //.
rewrite ['Res _]cfun_sum_cfdot !sum_cfunE rmorph_sum; apply: eq_bigr => i _.
have chiX := lin_charX (char_abelianP _ (cycle_abelian x) i) _ (cycle_id x).
rewrite !cfunE rmorphM aut_Cnat ?Cnat_cfdot_char_irr ?cfRes_char //.
by congr (_ * _); rewrite Dv -chiX // -expg_mod_order (eqnP a_x) chiX.
Qed.

Section ANT.
Import ssrint.

(* This section covers Peterfalvi (1.10). *)
(* We have simplified the statement somewhat by substituting the global ring  *)
(* of algebraic integers for the specific ring Z[eta]. Formally this amounts  *)
(* to strengthening (b) and weakening (a) accordingly, but since actually the *)
(* Z[eta] is equal to the ring of integers of Q[eta] (cf. Theorem 6.4 in J.S. *)
(* Milne's course notes on Algebraic Number Theory), the simplified statement *)
(* is actually equivalent to the textbook one.                                *)
Variable (p : nat) (eps : algC).
Hypothesis (pr_eps : p.-primitive_root eps).
Local Notation e := (1 - eps).

(* This is Peterfalvi (1.10) (a). *)
Lemma vchar_ker_mod_prim : {in G & G & 'Z[irr G], forall x y (chi : 'CF(G)),
  #[x] = p -> y \in 'C[x] -> chi (x * y)%g == chi y %[mod e]}%A.
Proof.
move=> x y chi Gx Gy Zchi ox cxy; pose X := <<[set x; y]>>%G.
have [Xx Xy]: x \in X /\ y \in X by apply/andP; rewrite -!sub1set -join_subG.
have sXG: X \subset G by rewrite join_subG !sub1set Gx.
suffices{chi Zchi} IHiX i: ('chi[X]_i (x * y)%g == 'chi_i y %[mod e])%A.
  rewrite -!(cfResE _ sXG) ?groupM //.
  have irr_free := (free_uniq (basis_free (irr_basis X))).
  have [c Zc ->] := (zchar_expansion irr_free (cfRes_vchar X Zchi)).
  rewrite !sum_cfunE /eqAmod -sumrB big_seq rpred_sum // => _  /irrP[i ->].
  by rewrite !cfunE [(_ %| _)%A]eqAmodMl // rpred_Cint.
have lin_chi: 'chi_i \is a linear_char.
  apply/char_abelianP; rewrite -[gval X]joing_idl -joing_idr abelianY.
  by rewrite !cycle_abelian cycle_subG /= cent_cycle.
rewrite lin_charM // -{2}['chi_i y]mul1r eqAmodMr ?Aint_irr //.
have [|k ->] := (prim_rootP pr_eps) ('chi_i x).
  by rewrite -lin_charX // -ox expg_order lin_char1.
rewrite -[_ ^+ k](subrK 1) subrX1 -[_ - 1]opprB mulNr -mulrN mulrC.
rewrite eqAmod_addl_mul // rpredN rpred_sum // => n _.
by rewrite rpredX ?(Aint_prim_root pr_eps).
Qed.

(* This is Peterfalvi (1.10)(b); the primality condition is only needed here. *)
Lemma int_eqAmod_prime_prim n :
  prime p -> n \in Cint -> (n == 0 %[mod e])%A -> (p %| n)%C.
Proof.
move=> p_pr Zn; rewrite /eqAmod unfold_in subr0.
have p_gt0 := prime_gt0 p_pr.
case: ifPn => [_ /eqP->// | nz_e e_dv_n].
suffices: (n ^+ p.-1 == 0 %[mod p])%A.
  rewrite eqAmod0_rat ?rpredX ?rpred_nat 1?rpred_Cint // !dvdC_int ?rpredX //.
  by rewrite floorCX // abszX Euclid_dvdX // => /andP[].
rewrite /eqAmod subr0 unfold_in pnatr_eq0 eqn0Ngt p_gt0 /=.
pose F := \prod_(1 <= i < p) ('X - (eps ^+ i)%:P).
have defF: F = \sum_(i < p) 'X^i.
  apply: (mulfI (monic_neq0 (monicXsubC 1))); rewrite -subrX1.
  by rewrite -(factor_Xn_sub_1 pr_eps) big_ltn.
have{defF} <-: F.[1] = p :> Algebraics.divisor.
  rewrite -[p]card_ord -[rhs in _ = rhs]sumr_const defF horner_sum.
  by apply: eq_bigr => i _; rewrite hornerXn expr1n.
rewrite -[p.-1]card_ord {F}horner_prod big_add1 big_mkord -prodfV.
rewrite -prodr_const -big_split rpred_prod //= => k _; rewrite !hornerE.
rewrite -[n](divfK nz_e) -[_ * _ / _]mulrA rpredM {e_dv_n}//.
have p'k: ~~ (p %| k.+1)%N by rewrite gtnNdvd // -{2}(prednK p_gt0) ltnS.
have [r {1}->]: exists r, eps = eps ^+ k.+1 ^+ r.
  have [q _ /dvdnP[r Dr]] := Bezoutl p (ltn0Sn k); exists r; apply/esym/eqP.
  rewrite -exprM (eq_prim_root_expr pr_eps _ 1) mulnC -Dr addnC gcdnC.
  by rewrite -prime_coprime // in p'k; rewrite (eqnP p'k) modnMDl.
rewrite -[1 - _]opprB subrX1 -mulNr opprB mulrC.
rewrite mulKf; last by rewrite subr_eq0 eq_sym -(prim_order_dvd pr_eps).
by apply: rpred_sum => // i _; rewrite !rpredX ?(Aint_prim_root pr_eps).
Qed.

End ANT.

End Main.


Set Implicit Arguments.
Require Import Shared.
Require Import String.
Open Scope string_scope.

(************************************************************)
(* * Extra stuff *)

(** For lists *)

Generalizable Variables A.

Fixpoint mem_decide `{Comparable A} x (l:list A) :=
  match l with
  | nil => false
  | x'::l' => if decide (x = x') then true else mem_decide x l'
  end.

Instance Mem_decidable : forall `{Comparable A} x (l:list A),
  Decidable (Mem x l).
Proof.
  introv C. intros. applys decidable_make (mem_decide x l).
  induction l; simpl; extens; rew_refl in *.
  iff M.
    false.
    inverts M.
  rewrite IHl. case_if; fold_bool; rew_refl in *.
    subst. iff M. constructors*. auto.
    iff M. constructors*. inverts* M.
Qed.

Notation " [ ] " := nil : list_scope.
Notation " [ x ] " := (cons x nil) : list_scope.
Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope.
Open Scope list_scope.

(** For int *)

Require Import Zcompare.

Instance lt_decidable : forall (n m : int),
  Decidable (n < m).
Proof.
  intros.
  sets b: (match Zcompare n m with Datatypes.Lt => true | _ => false end).
  applys decidable_make b.
  skip. (* TODO *)
Qed.

(** For string *)

(** [l1 ~ l2] concatenates two strings *)

Infix "~~" := append (right associativity, at level 60) : mystring_scope.
Open Scope mystring_scope.

Definition char := Ascii.ascii.
Definition char_dec := Ascii.ascii_dec.

Instance char_comparable : Comparable char.
Proof. applys comparable_of_dec char_dec. Qed.

Axiom append_empty_r : forall s,
  s ~~ EmptyString = s.
Axiom append_empty_l : forall s,
  EmptyString ~~ s = s.
Axiom append_assoc : assoc append.

Parameter string_of_int : int -> string.

Definition empty_string := "".

Definition concat (ss:list string) : string :=
  fold_right append empty_string ss.

Coercion string_of_char (c:char) : string :=
  String c EmptyString.

(************************************************************)
(* * Grammar of arithmetic expressions *)

Inductive binop :=
  | binop_add : binop
  | binop_mul : binop
  | binop_sub : binop.

Inductive unop :=
  | unop_neg : unop.

Inductive exp :=
  | exp_int : int -> exp
  | exp_unop : unop -> exp -> exp
  | exp_binop : binop -> exp -> exp -> exp.

Implicit Types e : exp.

(************************************************************)
(* * Evaluation of arithmetic expressions *)

(** --Not used in this file-- *)

Fixpoint value e :=
  match e with
  | exp_int n => n
  | exp_unop op e =>
     let v := value e in
     match op with
     | unop_neg => - v
     end
  | exp_binop op e1 e2 =>
     let v1 := value e1 in
     let v2 := value e2 in
     match op with
     | binop_add => v1 + v2
     | binop_sub => v1 - v2
     | binop_mul => v1 * v2
     end
  end.

(************************************************************)
(* * Syntax of arithmetic expressions *)

(** Priorities (use only even ones) *)

(** Alan: I'd put prio_neg as smallest priority:
# -2 * 3;;
- : int = -6
# 3 * -2;;
- : int = -6
 *)

Definition prio := int.
Definition prio_max := 8.
Definition prio_neg := 6.
Definition prio_add := 4.
Definition prio_sub := 4.
Definition prio_mul := 2.
Definition prio_par := 0.

(** String representation of symbols *)

Definition symb_neg := "-".
Definition symb_add := "+".
Definition symb_sub := "-".
Definition symb_mul := "*".

Definition symb_space := " ".
Definition symb_tab := "	".
Definition symb_par_open := "(".
Definition symb_par_close := ")".

(** Spacing characters *)

Definition spacing_tokens :=
  [ symb_space ; symb_tab ].

Definition spacing s :=
  Mem s spacing_tokens.

(** [spacings s] asserts that [s] is a string made only
     of spacing tokens *)

Inductive spacings : string -> Prop :=
  | spacings_empty :
     spacings EmptyString
  | spacings_string : forall s ss,
     spacing s ->
     spacings ss ->
     spacings (s ~~ ss).

(** [separ ss r] asserts that the list [r] is equal
    obtained as the concatenation of the strings in [ss],
    possibly separated by strings satisfying [spacings],
    including separations at the front and at the tail. *)

Inductive separ : list string -> string -> Prop :=
  | separ_nil : forall g,
      spacings g ->
      separ nil g
  | separ_cons : forall s ss g r,
      separ ss r ->
      spacings g ->
      separ (s::ss) (g ~~ s ~~ r).

(** Specification of a valide representation of an expresion:
    [repr p e s] asserts that [s] is a valid representation of
    [e], in a context where operators with priority less than
    [p] can be represented without parenthesis. *)

Inductive repr : int -> exp -> string -> Prop :=
  | repr_int : forall p n r,
      separ [string_of_int n] r ->
      repr p (exp_int n) r
  | repr_neg : forall p e1 r1 r,
      repr prio_neg e1 r1 ->
      prio_neg < p ->
      separ [symb_neg ; r1] r ->
      repr p (exp_unop unop_neg e1) r
  | repr_add : forall p e1 e2 r1 r2 r,
      repr (prio_add+1) e1 r1 ->
      repr (prio_add+1) e2 r2 ->
      prio_add < p ->
      separ [r1 ; symb_add ; r2] r ->
      repr p (exp_binop binop_add e1 e2) r
  | repr_sub : forall p e1 e2 r1 r2 r,
      repr (prio_sub+1) e1 r1 ->
      repr prio_sub e2 r2 ->
      prio_add < p ->
      separ [r1 ; symb_sub ; r2] r ->
      repr p (exp_binop binop_sub e1 e2) r
  | repr_mul : forall p e1 e2 r1 r2 r,
      repr (prio_mul+1) e1 r1 ->
      repr (prio_mul+1) e2 r2 ->
      prio_mul < p ->
      separ [r1 ; symb_mul ; r2] r ->
      repr p (exp_binop binop_mul e1 e2) r
  | repr_par : forall p e r1 r,
      repr prio_max e r1 ->
      separ [symb_par_open ; r1 ; symb_par_close ] r ->
      repr p e r.

(************************************************************)
(* * Properties of the syntax *)

Hint Extern 1 (_ < _) => math.

(** [repr] is monotonic in the priority *)

Hint Constructors repr.

Lemma repr_prio_le : forall p1 p2 e r,
  repr p1 e r ->
  p1 <= p2 ->
  repr p2 e r.
Proof. introv H. induction H; introv L; try constructors*. Qed.

(** [spacings] stable by concatenation *)

Lemma spacings_concat : forall s1 s2,
  spacings s1 ->
  spacings s2 ->
  spacings (s1 ~~ s2).
Proof.
  introv S1 S2. induction S1.
  rewrite~ append_empty_l.
  rewrite <- append_assoc. constructors~.
Qed.

(** [separ] supports adding spaces at the end of the string *)

Lemma separ_trailing_spaces : forall ss s g,
  spacings s ->
  separ ss g ->
  separ ss (g ~~ s).
Proof.
  introv P S. induction S.
  constructors. applys~ spacings_concat.
  do 2 rewrite <- append_assoc. constructors~.
Qed.

(** [repr] supports adding spaces at the end of the string *)

Lemma repr_trailing_spaces : forall p e s s',
  spacings s' ->
  repr p e s ->
  repr p e (s ~~ s').
Proof.
  hint separ_trailing_spaces.
  introv S R. inverts R; constructors*.
Qed.

(** Results about [spacings] *)

Hint Constructors spacings.

Lemma spacings_char : forall (c:char) s,
  spacing c ->
  spacings s ->
  spacings (String c s).
Proof. introv Sc Ss. applys (spacings_string Sc Ss). Qed.

Hint Resolve spacings_char.

(** Results about [separ] *)

Lemma separ_empty_not :
  separ nil EmptyString.
Proof.
  applys~ separ_nil.
Qed.

Lemma separ_cons_not : forall s ss r,
  separ ss r ->
  separ (s::ss) (s ~~ r).
Proof.
  introv H. rewrite <- append_empty_l.
  applys~ separ_cons.
Qed.

Lemma separ_unary : forall g s,
  spacings g -> separ [s] (g ~~ s).
Proof.
  introv G. rewrite <- append_empty_r.
  rewrite <- append_assoc.
  constructors~. constructors~.
Qed.

Lemma separ_1_alone : forall s,
  separ [s] s.
Proof.
  intros. rewrite <- append_empty_l. applys~ separ_unary.
Qed.

Lemma separ_2_front : forall g s1 s2,
  spacings g -> separ [s1;s2] (g ~~ s1 ~~ s2).
Proof.
  introv G. constructors~. applys separ_1_alone.
Qed.

Lemma separ_enclose : forall g1 g2 s1 s2 s3,
  spacings g1 -> spacings g2 ->
  separ [s1;s2;s3] (g1 ~~ s1 ~~ s2 ~~ g2 ~~ s3).
Proof.
  introv G1 G2. applys~ separ_cons.
  applys~ separ_cons_not. applys~ separ_unary.
Qed.

Hint Resolve separ_empty_not separ_cons_not
  separ_unary separ_1_alone separ_2_front separ_enclose.

(************************************************************)
(* * Parse trees *)

(** Definition of a parse tree -- expression plus parentheses *)

Inductive pexp :=
  | pexp_int : int -> pexp
  | pexp_unop : unop -> pexp -> pexp
  | pexp_binop : binop -> pexp -> pexp -> pexp
  | pexp_par : pexp -> pexp.

(** Conversion of a parse tree into an expression *)

Fixpoint exp_of_pexp f :=
  let r := exp_of_pexp in
  match f with
  | pexp_int n => exp_int n
  | pexp_unop op f1 => exp_unop op (r f1)
  | pexp_binop op f1 f2 => exp_binop op (r f1) (r f2)
  | pexp_par f1 => r f1
  end.

(************************************************************)
(* * Auxiliarly functions for the validator *)

(** [eat_leading t s] returns [None] is [t] is not
    a prefix of [s] and returns [Some s'] if [s = append t s']. *)

Fixpoint eat_leading t s :=
  match t with
  | EmptyString => Some s
  | String c t' =>
      match s with
      | EmptyString => None
      | String c' s' =>
         if decide (c = c')
           then eat_leading t' s'
           else None
      end
  end.

Lemma eat_leading_spec : forall t s s',
  eat_leading t s = Some s' -> s = append t s'.
Proof.
  induction t; introv E; simpls.
  inverts~ E.
  destruct s as [|c s''].
    false.
    case_if. subst. rewrites~ (>> IHt E).
Qed.

(** [eat_spaces s] returns the string obtained
    by removing the leading spacing characters (those
    satisfying the predicate [spacing]) from the string [s]. *)

Fixpoint eat_spaces s :=
  match s with
  | EmptyString => EmptyString
  | String c s' =>
     if decide (spacing (c:char))
       then eat_spaces s'
       else s
  end.

Lemma eat_spaces_spec : forall s s',
  eat_spaces s = s' ->
  exists g, spacings g /\ s = append g s'.
Proof.
  induction s; introv E.
  exists~ EmptyString.
  simpls. case_if.
    forwards (g'&G'&E'): IHs E.
     subst s. exists~ (String a g').
    exists~ EmptyString.
Qed.

Lemma eat_spaces_empty : forall s,
  eat_spaces s = EmptyString -> spacings s.
Proof.
  introv H. induction s.
  auto.
  simpls. case_if. applys* spacings_char.
Qed.

(** [eat t s] eats the spaces and the string [t] at the head
    of the string [s], and returns [Some] of the rest, or
    [None] if the eating failed. *)

Definition eat t s :=
  eat_leading t (eat_spaces s).

Lemma eat_spec : forall s s' t,
  eat t s = Some s' ->
  exists g, spacings g /\ s = append (append g t) s'.
Proof.
  introv H. unfolds eat.
  sets_eq u: (eat_spaces s).
  forwards~ (g&G&E): (@eat_spaces_spec s u).
  exists g. splits~.
  forwards: eat_leading_spec H.
  subst s u. rewrite~ append_assoc.
Qed.

(************************************************************)
(* * Validation of a parse tree w.r.t. a string *)

(** Auxiliary definitions *)

Definition if_lt (p q:int) (k:unit->option string) :=
  if decide (p < q) then k tt else None.

Definition if_str (o:option string) (k:string->option string) :=
  match o with
  | None => None
  | Some s => k s
  end.

(** [pexp_validate p f s] returns [Some s'] if [f] is a valid
    parse tree for a string [s''] such that [s = s'' ++ s'],
    in a context of priority [p]. Otherwise it returns [None] *)

Fixpoint pexp_validate p f s :=
  let r := pexp_validate in
  match f with
  | pexp_int n => eat (string_of_int n) s
  | pexp_unop op f1 =>
     match op with
     | unop_neg =>
        if_lt prio_neg p (fun _ =>
        if_str (eat symb_neg s) (fun s1 =>
        if_str (r prio_neg f1 s1) Some))
     end
  | pexp_binop op f1 f2 =>
     match op with
     | binop_add =>
        if_lt prio_add p (fun _ =>
        if_str (r (prio_add+1) f1 s) (fun s1 =>
        if_str (eat symb_add s1) (fun s2 =>
        if_str (r (prio_add+1) f2 s2) Some)))
     | binop_sub =>
        if_lt prio_sub p (fun _ =>
        if_str (r (prio_sub+1) f1 s) (fun s1 =>
        if_str (eat symb_sub s1) (fun s2 =>
        if_str (r prio_sub f2 s2) Some)))
     | binop_mul =>
        if_lt prio_mul p (fun _ =>
        if_str (r (prio_mul+1) f1 s) (fun s1 =>
        if_str (eat symb_mul s1) (fun s2 =>
        if_str (r (prio_mul+1) f2 s2) Some)))
     end
  | pexp_par f1 =>
     if_str (eat symb_par_open s) (fun s1 =>
     if_str (r prio_max f1 s1) (fun s2 =>
     if_str (eat symb_par_close s2) Some))
  end.

Definition pexp_validate_full f s :=
  match pexp_validate prio_max f s with
  | Some s =>
     match eat_spaces s with
     | EmptyString => true
     | _ => false
     end
  | _ => false
  end.

(** Tactic for automating the proof of correctness *)

Ltac step H :=
  match type of H with
  | if_lt _ _ _ = _ =>
    unfold if_lt in H at 1; case_if
  | if_str (eat ?s ?t) _ = _ =>
    let C := fresh "C" in
    (cases (eat s t) as C; simpl in H; [ | false ]);
    let g := fresh "g" in
    let Sg := fresh "Sg" in
    let Eg := fresh "Eg" in
    forwards (g&Sg&Eg): eat_spec C
  | if_str (pexp_validate ?p ?f ?s) _ = _ =>
    let C := fresh "C" in
    (cases (pexp_validate p f s) as C; simpl in H; [ | false]);
    let t := fresh "t" in
    let Et := fresh "Et" in
    let Rt := fresh "Rt" in
    match goal with IH: forall _, _ |- _ => forwards (t&Et&Rt): IH C end
  end.

Ltac steps H :=
  repeat step H; inverts H.

(** Proof of correctness of the validator *)

Lemma pexp_validate_correct : forall f s' p s,
  pexp_validate p f s = Some s' ->
  exists t, s = append t s' /\ repr p (exp_of_pexp f) t.
Proof.
  induction f; introv H; simpls.
  (* int *)
  forwards (g&G&E): eat_spec H.
  esplit. split*.
  (* --unary *)
  destruct u.
  (* neg *)
  steps H. subst. esplit. split.
    rewrite append_assoc. eauto.
    rewrite <- append_assoc. constructors*.
  (* -- binary *)
  destruct b.
  (* add *)
  steps H. subst. esplit. split.
    do 2 rewrite append_assoc. eauto.
    do 2 rewrite <- append_assoc. constructors*.
  (* sub -- copy pasted *)
  steps H. subst. esplit. split.
    do 2 rewrite append_assoc. eauto.
    do 2 rewrite <- append_assoc. constructors*.
  (* mul -- copy pasted  *)
  steps H. subst. esplit. split.
    do 2 rewrite append_assoc. eauto.
    do 2 rewrite <- append_assoc. constructors*.
  (* par *)
  steps H. subst. esplit. split.
    do 2 rewrite append_assoc. eauto.
    do 2 rewrite <- append_assoc. constructors*.
Qed.

(** Corollary for validation of complete strings *)

Theorem pexp_validate_correct_full : forall f s,
  pexp_validate_full f s = true ->
  repr prio_max (exp_of_pexp f) s.
Proof.
  introv M. unfolds in M.
  cases (pexp_validate prio_max f s) as N; tryfalse.
  cases (eat_spaces s0); tryfalse.
  forwards (t&E&R): pexp_validate_correct N.
  subst. apply~ repr_trailing_spaces.
  apply~ eat_spaces_empty.
Qed.

(************************************************************)
(* * Validation of a parse tree w.r.t. a string *)

Coercion pexp_of_int (n:int) : pexp := pexp_int n.
Definition _neg := pexp_unop unop_neg.
Definition _add := pexp_binop binop_add.
Definition _sub := pexp_binop binop_sub.
Definition _mul := pexp_binop binop_mul.
Definition _par := pexp_par.

Definition test_string_of_int := string_of_int 12.

Definition test1_valid := pexp_validate_full
  (1)
  "1".

Definition test2_valid := pexp_validate_full
  (1)
  "  1  ".

Definition test3_valid := pexp_validate_full
  (_add 1 2)
  "  1+ 2 ".

Definition test4_valid := pexp_validate_full
  (_par (_add (_par 1) 2))
  " ( (1)+ 2 )".

Definition test5_valid := pexp_validate_full
  (_add 1 (_par (_neg 2)))
  "  1+ (- 2) ".

Definition test6_valid := pexp_validate_full
  (_add 1 (_neg 2))
  "1+ - 2". (* not correct *)

(*
Definition test6_valid := pexp_validate_full
  (_par (_add (_mul (_par (_neg 5)) 6) 7))
  "((-5)*6+7))".
*)

(*
Definition test6_valid := pexp_validate_full
  (_par (_add (_mul (_par (_neg 5)) 6) 7))
  "((-5)*6+7)".
*)

Definition test_pexp :=
  _sub (_mul 1 (_par (_add 2 (_sub 3 4))))
       (_par (_add (_mul (_par (_neg 5)) 6) 7)).

Definition test_exp := exp_of_pexp test_pexp.

Definition test_exp' :=
  Eval cbv beta iota zeta delta
    [test_exp exp_of_pexp test_pexp _neg _add _sub _mul _par pexp_of_int]
    in test_exp.
  (* Print test_exp'. *)

Definition test7_valid := pexp_validate_full
  test_pexp
  " 1 *(2 +  3  - 4  ) - ((-5)*6+7)".

Definition test8_valid := pexp_validate_full
  test_pexp
  " 1 *(2 +  3  - 4  ) - (-5*6+7)".  (* not the same *)

Definition test9_valid := pexp_validate_full
  (_sub (_mul 1 (_par (_add 2 (_sub 3 4))))
        (_par (_neg (_add (_mul 5 6) 7))))
  " 1 *(2 +  3  - 4  ) - (-5*6+7)".

(************************************************************)
(** * Extraction *)

Extract Constant string_of_int =>
  "(fun n ->
     let int_of_pos p =
       let rec aux factor = function
         | XI p1 -> aux (2*factor) p1 + factor
         | XO p1 -> aux (2*factor) p1
         | XH -> factor
         in
       aux 1 p
       in
     let int_of_z = function
       | Z0 -> 0
       | Zpos p -> int_of_pos p
       | Zneg p -> - (int_of_pos p)
       in
     let ascii_of_char c =
       let i = Char.code c in
       let bit k = (if i land (1 lsl k) > 0 then True else False) in
       Ascii (bit 0, bit 1, bit 2, bit 3, bit 4, bit 5, bit 6, bit 7)
       in
     let s = string_of_int (int_of_z n) in
     let r = ref [] in
     String.iter (fun c -> r := ascii_of_char c :: !r) s;
     List.fold_left (fun acc c -> String (c,acc)) EmptyString !r)".

Extraction "eval/demo.ml" test_string_of_int test1_valid test2_valid
  test3_valid test4_valid test5_valid test6_valid test7_valid
  test8_valid test9_valid.

(* From top-level folder, run the command:

coqc -I js -I tlc eval/Arithm.v && ocamlc eval/demo.mli && ocamlc -I eval eval/demo.ml eval/test.ml -o eval/test.out && ./eval/test.out

-- expected output:
true
true
true
true
true
false
true
false
true
12

*)


Require Import Hask.Prelude.

Generalizable All Variables.
Set Primitive Projections.

Class Semigroup (m : Type) := {
  mappend : m -> m -> m
}.

Arguments mappend {m _ } _ _.

Infix "⨂" := mappend (at level 40).

Definition Maybe_append `{Semigroup a} (x y : Maybe a) : Maybe a :=
  match x, y with
  | Nothing, x     => x
  | x, Nothing     => x
  | Just x, Just y => Just (x ⨂ y)
  end.

#[global]
Program Instance Semigroup_Maybe `{Semigroup a} : Semigroup (Maybe a) := {
  mappend := Maybe_append
}.

Class SemigroupLaws (m : Type) `{Semigroup m} := {
  mappend_assoc : forall a b c, mappend a (mappend b c) = mappend (mappend a b) c;
}.

#[global]
Program Instance SemigroupLaws_Maybe `{SemigroupLaws a} : SemigroupLaws (Maybe a).
Next Obligation.
  destruct a0, b, c; simpl; try reflexivity.
  now rewrite mappend_assoc.
Qed.