(* Require Import CertiCoq. *)
From MetaCoq Require Import Template.Ast.
Require Import Arith List.

Import ListNotations.

(** Ideas for TemplateCoq translation validation that would let us connect the generated target file
    with the original Coq code.

    Author: Zoe Paraskevopoulou *)

(** * VST specs for compiled Coq programs

    The idea is that we want to derive a proof in Verifiable C (VST's separation
    logic) for compiled Coq programs. These specifications will relate the
    original Coq function (rather than L1g abstract syntax) with the compiled C
    code.

    Let [f : A -> B] be a Coq function and [f_in_C : compcert.exp] its
    translation. Then we want:

    forall (a: A) (v : compcert.val),
      {{ rep_A a v }} f_in_C(v)  {{ret. rep_B (f a) ret }}

    The separation logic predicate rep_A describes how Coq values of type A are
    laid out as a C data structure.

    For instance, if for simplicity we assume that Coq values of type [list A]
    will be represented as a null terminated linked lists, then rep_list will,
    very roughly, be

    Fixpoint rep_list (l: list A) (p: compcert.val) : mpred :=
      match l with
      |  h :: l' => rep_A h p ∗ rep_list l' (offset p 4)
         (* i.e. p is a struct pointer and p.head points to a C value in memory
          * that represents h and p.tail is a struct pointer that represents the
          * rest of the list *)
      |  nil => !! (p = null) && emp
    end.

    Then a C program may call f_in_C, and also we may use the above spec when we
    prove it correct in VST!

    To obtain this triple for a compiled program we'll make use of the
    semantic definition of the triple that (again very roughly) says

    {{ pre }} e {{ post }} iff forall h, pre h -> exists v h', eval (e, h) (v, h') /\ post v h'

    That is, to obtain the top-level theorem we need

    forall (a: A) (v : compcert.val) (h : heap),
       rep_A a v h -> exists v' h', eval (app e v, h) (v', h') /\ rep_B (f a) v'

   It should be possible to obtain a similar theorem for L1 -> C light just from
   our compiler correctness theorem.

   The following explains how can we obtain such a theorem for Coq -> L1 to
   eventually compose the two and derive the desired theorem.

  This idea seems to be similar with the one presented in
  https://pdfs.semanticscholar.org/58bb/00b882700d67779871a6208f288f68a0b71c.pdf
  where they verify an HOL -> ML extractor.

 *)

(* Assume we have this *)
Axiom (eval : Ast.term -> Ast.term).

Class Rep (A : Type) :=
  {
    (* An Ast.term represents a Coq value *)
    rep : A -> Ast.term -> Prop
  }.

(* Example 1 : nat *)

Fixpoint nat_rep (n : nat) (v : Ast.term) : Prop :=
  match n with
    | O =>
      match v with
        | Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.nat" 0) 0 => True
        | _ => False
      end
    | S n =>
      match v with
        | Ast.tApp (Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.nat" 0) 1) [x] =>
          nat_rep n x
        | _ => False
      end
  end.

Instance NatRep : Rep nat := { rep n v := nat_rep n (eval v) }.

(* Example 2 : list *)

Fixpoint list_rep {A : Type} `{Rep A} (l : list A) (v : Ast.term) : Prop :=
  match l with
    | [] =>
      match v with
        | Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.list" 0) 0 => True
        | _ => False
      end
    | hd :: tl =>
      match v with
        | Ast.tApp (Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.list" 0) 1) [typ; vhd; vtl] =>
          rep hd vhd /\ list_rep tl vtl
        | _ => False
      end
  end.

Instance ListRep {A : Type} `{Rep A} : Rep (list A) := { rep l v := list_rep l (eval v) }.

(* And so on. For inductive types we should be able to generate these instances automatically *)

(* Function types are more interesting *)

Instance ArrowRep {A B : Type} `{Rep A} `{Rep B} : Rep (A -> B) :=
  { rep f t :=
      forall (a : A) (v : Ast.term), rep a v -> rep (f a) (eval (Ast.tApp t [v]))
  }.

Instance ProdRep (B : Type -> Type) `{forall (A : Type) (H : Rep A), Rep (B A)}
: Rep (forall (A : Type), B A) :=
  { rep f t :=
      forall (A : Type) `{Rep A}, rep (f A) (eval (Ast.tApp t [qUnit]))
  }.

(* For every term f we reify we want to generate a proof that [rep f f_reified].
   If we can generate such a thing (can we?) then we could obtain the
   top-level theorem we want. *)

(* What about quantification over computationally irrelevant things? *)

Quote Definition qUnit := tt.

Instance ProdRep (B : Type -> Type) `{forall (A : Type) (H : Rep A), Rep (B A)}
: Rep (forall (A : Type), B A) :=
  { rep f t :=
      forall (A : Type) `{Rep A}, rep (f A) (eval (Ast.tApp t [qUnit]))
  }.

(* This resembles a lot the approach we follow in QuickChick to automatically
   generate correctness proofs for automatically generated generators. We do the
   proof term generation in OCaml, but I think it would be nice to do it in Coq
   and then reflect the terms. *)

Instance ProdRep (B : Type -> Type) `{forall (A : Type) (H : Rep A), Rep (B A)}
: Rep (forall (A : Type), B A) :=
  { rep f t :=
      forall (A : Type) `{Rep A}, rep (f A) (eval (Ast.tApp t [qUnit]))
  }.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import boolp reals realsum distr.
(* ------- *) Require Import notations.

(* -------------------------------------------------------------------- *)
CoInductive or_spec (a b : bool) : bool -> bool -> Type :=
| OrT of a    : or_spec a b true  true
| OrF of ~~ a : or_spec a b false b.

Lemma orlP a b : or_spec a b a (a || b).
Proof. by case: (boolP a) => h; constructor. Qed.

Lemma orrP a b : or_spec b a b (a || b).
Proof. rewrite orbC;apply orlP. Qed.

(* -------------------------------------------------------------------- *)
Delimit Scope assn with A.

Definition predImpl {T} (P Q:pred T) :=
   [pred x | P x ==> Q x].

Notation "P /\ Q"   := (predI P%A Q%A) : assn.
Notation "P \/ Q"   := (predU P%A Q%A) : assn.
Notation "P ==> Q"  := (predImpl P%A Q%A) : assn.
Notation "~ P"      := (predC P%A) : assn.

Definition predP {T : Type} (P : T -> Prop) := [pred x | `[<P x>]].

Notation "`[< P >]" := (predP P) : assn.

Definition pswap {A B : Type} (P : pred (A * B)) :=
  [pred m | P (m.2, m.1)].


From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
From Undecidability.L Require Import L_facts LM_heap_def UpToCNary.

From Coq Require Import List.
Import Vector.VectorNotations ListNotations.

From Undecidability.TM Require Import TM_facts ProgrammingTools WriteValue CaseList Copy ListTM Hoare.
From Undecidability.TM.L Require Import Alphabets Eval.
From Undecidability.TM.L.CompilerBoolFuns Require Import Compiler_spec Compiler_facts ClosedLAdmissible.

Require Import Equations.Prop.DepElim.

Set Default Proof Using "Type".

Section APP_right.

  Definition APP_right : pTM (sigPro)^+ unit 2 :=
    App _;;
    WriteValue ( [appT]%list) @ [|Fin1|];;
    App _.

  Lemma APP_right_Spec :
    { f : UpToC (fun '(s1,s2)=>size (compile s1) + size (compile s2)) & forall s1 s2 : term,
    TripleT ≃≃([],[|Contains _ (compile s1);Contains _ (compile s2)|])
    (f (s1,s2)) APP_right (fun _ => ≃≃([],[|Contains _ (compile (L.app s1 s2));Void|])) }.
  Proof.
    eexists_UpToC f. [f]:refine (fun '(s1,s2) => _).
    intros s1 s2.
    unfold APP_right.
    hsteps_cbn.
    -rewrite app_assoc.  reflexivity.
    -reflexivity.
    - rewrite !(correct__leUpToC (App_steps_nice _) (_,_)).
      rewrite Encode_list_hasSize with (xs:=(compile s1 ++ compile s2)%list).
      rewrite Encode_list_hasSize_app, <- !Encode_list_hasSize. reflexivity.
    -assert (H': (fun x => 1) <=c (fun '(s1,s2)=>size (compile s1) + size (compile s2))).
     { eapply upToC_le. intros []. setoid_rewrite Encode_list_hasSize. setoid_rewrite <- Encode_list_hasSize_ge1. nia. }
    unfold f. unfold sigPro. cbn - ["-" "+"]. smpl_upToC. cbn. all:try smpl_upToC_solve.
  Qed.

End APP_right.

Lemma tabulate_nth [X : Type] [n : nat] (v : Vector.t X n): tabulate (fun i => v[@i]) = v.
Proof. depind v;cbn. all:congruence. Qed.

Hint Rewrite  Nat.eqb_refl tabulate_nth nth_tabulate: cleanupParamTM.

Ltac cleanupParamTM :=
  try fold Nat.add;rewrite ?Nat.eqb_refl, ?tabulate_nth, ?nth_tabulate;cbn.

Section MK_isVoid.

  Context {Σ : finType}.

  Definition MK_isVoid : pTM Σ^+ unit 1 :=
    Write (inl UNKNOWN).

  Lemma MK_isVoid_Sem :
    RealiseIn MK_isVoid (fun t '(r, t') => t = [| niltape|] -> isVoid (t'[@Fin0])) 1.
  Proof.
    eapply RealiseIn_monotone.
    { unfold MK_isVoid. TM_Correct. }
    easy.
    intros ? [] H ->. hnf in H. cbn in *. rewrite H. hnf. eauto.
  Qed.

  Lemma MK_isVoid_Spec :
   TripleT ≃≃([],[|Custom (eq niltape)|]) 1 MK_isVoid (fun _ => ≃≃([],[|Void|])).
  Proof.
    eapply RealiseIn_TripleT. now apply MK_isVoid_Sem. cbn. intros ? ? ? ? [_ H']%tspecE.
    specialize  (H' Fin0). eapply tspecI. easy. intros i; destruct_fin i;cbn. apply H. now vector_destruct tin.
  Qed.

  Fixpoint MK_isVoid_multi m' : pTM (Σ) ^+ unit m' :=
    match m' with
    0 => Nop
    | S m' => MK_isVoid @ [|Fin0|];;MK_isVoid_multi m'@(tabulate (fun i => Fin.FS i))
    end.

  Lemma helper n m i f:
    injective f ->
      lookup_index_vector (m:=m) (n:=n)
    (tabulate f)
    (f i) = Some i.
  Proof.
    revert n i f. induction m;cbn. easy.
    intros n i f Hinj. specialize (Fin.eqb_eq _ (f i) (f Fin0)) as H'.
    destruct Fin.eqb.
    -destruct H' as [H' _]. specialize (H' eq_refl). apply Hinj in H' as ->. easy.
    -destruct H' as [_ H']. destruct (fin_destruct_S i) as [[i' ->]| ->]. 2:now discriminate H'.
     specialize IHm with (f:= fun m => f (Fin.FS m) ). cbn in IHm. rewrite IHm. easy. intros ? ? ?%Hinj. now apply Fin.FS_inj.
  Qed.

  Instance Proper_tabulate X n: Proper (pointwise_relation _ eq ==> eq) (@tabulate X n).
  Proof.
    unfold pointwise_relation.
    induction n;hnf;intros f g H;cbn. reflexivity. f_equal. apply H. now apply IHn.
  Qed.

  Theorem MK_isVoid_multi_SpecT m' :
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) m')
    (m'*2) (MK_isVoid_multi m')
    (fun _ => ≃≃([],Vector.const Void m')).
  Proof using All.
    depind m';cbn. now hsteps_cbn.
    hstep. {hsteps_cbn;cbn. apply MK_isVoid_Spec. }
    cbn;intros _. rewrite Nat.eqb_refl,tabulate_nth;cbn.
    eapply ConsequenceT.
    {
      eapply LiftTapes_SpecT with (Q:=fun _ => _)(Q':=fun _ => _) (P:= Void:::Vector.const (Custom (eq niltape)) _). now eapply dupfree_tabulate_injective,Fin.FS_inj.
      eapply ConsequenceT . eassumption. 2:cbn;intro;reflexivity. 2:reflexivity.
      unfold Downlift,select. rewrite Vector_map_tabulate. cbn. now rewrite tabulate_nth.
    }
    1,3,4:reflexivity. cbn. intros _.
    rewrite lookup_index_vector_None. 2:{rewrite in_tabulate. intros (?&?). congruence. }
    eapply EntailsI. intros ? [_ H]%tspecE. eapply tspecI. easy. intros i. cbn.
    specialize (H i);cbn in H. destruct (fin_destruct_S i) as [[i' ->]| ->];cbn in H|-*. 2:easy.
    rewrite nth_tabulate in H. rewrite helper in H. easy. hnf. eapply Fin.FS_inj.
  Qed.

End MK_isVoid.
Opaque MK_isVoid_multi.

From Undecidability Require Import TM.L.Transcode.Boollist_to_Enc.
From Undecidability Require Import EncBoolsTM_boolList.
From Undecidability.TM.L Require Import SizeBoundsL.

Section mk_init_one.

  Variable Σ : finType.

  Variable s b : Σ^+.
  Variable (H_disj : s <> b).

  Variable (retr_pro : Retract sigPro Σ).
  Variable (retr_list : Retract (sigList bool) Σ).

   (* Tapes:
       0: bs (input, encBoolsTM)
       1: ter (input)
       2: intern, bs als listBool
       3: intern
       4: intern
       5: intern
     *)

  Definition M_init_one : pTM (Σ) ^+ unit 6:=
    encBoolsTM2boollist.M s retr_list @[|Fin0;Fin3|];;
    Rev _ ⇑ retr_list @ [|Fin3;Fin2;Fin4|];;
    BoollistToEnc.M retr_list retr_pro @[|Fin2;Fin3;Fin4;Fin5|];;
    APP_right ⇑ retr_pro  @[|Fin1;Fin3|].

  Lemma M_init_one_Spec :
    { f : UpToC (fun '(bs,ter)=>length bs + L_facts.size ter + 1) & forall (bs:list bool) (ter : L.term),
    TripleT ≃≃([],[|Custom (eq (encBoolsTM s b bs));Contains _ (compile ter);Void;Void;Void;Void|])
    (f (bs,ter)) M_init_one (fun _ => ≃≃([],[|Custom (eq (encBoolsTM s b bs));Contains _ (compile (L.app ter (encBoolsL bs)));Void;Void;Void;Void|])) }.
  Proof using H_disj.
    eexists_UpToC f.
    {
    [f]:refine (fun '(bs,ter) => _).
    intros bs ter.
    unfold M_init_one.
    hstep. { hsteps_cbn. cbn. eapply (projT2 (encBoolsTM2boollist.SpecT _ H_disj)). }
    cbn. intros _. hstep. { hsteps_cbn. cbn. tspec_ext. } 2:reflexivity.
    cbn. intros _. hstep.
    {
      hsteps_cbn. cbn. eapply ConsequenceT. eapply BoollistToEnc.SpecT with (bs:=rev bs).
      all:cbn. now tspec_ext. now rewrite rev_involutive. reflexivity.
    } 2:reflexivity.
    cbn. intros _. hsteps_cbn.
     now eapply (projT2 (APP_right_Spec)). 1,2:now cbn;tspec_ext.
     subst f. cbn beta. cbn beta iota.  reflexivity.
    }
    etransitivity.
    {
       unfold f. eapply upToC_le with (F:=fun '(bs,ter) => _). intros [bs ter].
       rewrite (correct__leUpToC (Rev_steps_nice _)).
       rewrite (correct__leUpToC (BoollistEnc.boollist_size)).
       do 3 rewrite (correct__leUpToC (correct__UpToC _)).
       rewrite rev_length.
       rewrite !size_le_sizeP.
       unfold sizeP;rewrite !sizeP_size.
       rewrite (correct__leUpToC size_L_enc_bools).
       reflexivity.
    }
       smpl_upToC_solve.
  Qed.

End  mk_init_one.

Section mk_init.

  Variable Σ : finType.
  Variable s b : Σ^+.
  Variable (H_disj : s <> b).

  Context (retr_pro : Retract sigPro Σ) (retr_bools : Retract (sigList bool) Σ).

  Variable m k : nat.

  Notation aux n := (Fin.L k (Fin.L m n)) (only parsing).
  Notation auxm n := (Fin.L k (Fin.R 6 n)) (only parsing).
  Notation auxk n := (Fin.R (6 + m) n) (only parsing).

  Fixpoint M_init' (sim:term) {k'} : (Vector.t (Fin.t k) k') -> pTM (Σ) ^+ unit ((6 + m)+ k).
  Proof using m s retr_bools retr_pro.
    simple notypeclasses refine (match k' with
    0 => fun _ => MK_isVoid_multi _ @ [|aux Fin1;aux Fin2;aux Fin3;aux Fin4; aux Fin5|];;
        WriteValue ( (compile sim)) ⇑ retr_pro @ [|aux Fin1|]
    | S k' =>
    fun ren =>
      _;;M_init_one s retr_pro retr_bools @ [|auxk (ren[@Fin0]);aux Fin1;aux Fin2;aux Fin3;aux Fin4;aux Fin5|]
    end). all:try exact _.
    2:{apply (M_init' sim _ (Vector.tl ren)). }
  Defined. (* because definition *)

  Theorem M_init'_SpecT k' (ren :Vector.t (Fin.t k) k') :
  { f : UpToC (fun '(sim,v) => L_facts.size sim + sumn (Vector.to_list (Vector.map (length (A:=bool)) v)) + 1)
  & forall sim (v:Vector.t (list bool) k),
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) (6+m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v)
    (f (sim,v)) (M_init' sim ren)
    (fun _ => ≃≃([],
      ([|Custom (eq niltape);
        Contains retr_pro (compile (Vector.fold_right (fun l_i s => L.app s (encBoolsL l_i)) (select ren v) sim))
         ;Void;Void;Void;Void|]++Vector.const (Custom (eq niltape)) m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v))}.
  Proof using All.
    depind ren. all:cbn [compile Vector.fold_left M_init' Vector.tl Vector.caseS].
    {
      eexists_UpToC f. [f]:refine (fun '(sim,v) => _).
      {
        cbn. intros sim v.
        hstep. hsteps_cbn;cbn. exact (MK_isVoid_multi_SpecT 5). cbn;cleanupParamTM. 2:reflexivity.
        hsteps_cbn. reflexivity.
        cleanupParamTM.
        apply EntailsI. intros t H. eapply tspec_ext. eassumption. easy.
        intros i. clear - i.
        repeat (destruct (fin_destruct_S i) as [(i'&->) | ->];[rename i' into i;cbn| ]);try (intros H;exact H).
      }
      unfold f. etransitivity.
      {eapply upToC_le with (F:= (fun '(_,_) => _ ));intros []. unfold WriteValue_steps. rewrite !size_le_sizeP. unfold sizeP;rewrite !sizeP_size. reflexivity. }
      smpl_upToC_solve.
    }
    {
      eexists_UpToC f. [f]:refine (fun '(sim,v) => _).
      {
        cbn. intros sim v.
        hstep.
        3:reflexivity. now apply (projT2 IHren).
        cbn. intros _. hstep. { cbn. rewrite Vector_nth_R,nth_map'. cbn. eapply (projT2 (M_init_one_Spec H_disj _ _)). }
        cbn;fold Nat.add;rewrite Nat.eqb_refl;cbn. intros _.
        apply EntailsI. intros t H. eapply tspec_ext. eassumption. easy.
        intros i. clear - i.
        repeat (destruct (fin_destruct_S i) as [(i'&->) | ->];[rename i' into i;cbn| ]);try (intros H;exact H).
        rewrite nth_tabulate. destruct (Fin.eqb _ _) eqn:H'. 2:tauto.
        cbn. eapply Fin.eqb_eq in H' as ->. rewrite Vector_nth_R,nth_map'. cbn. tauto.
      }
      unfold f. etransitivity.
      {
        eapply upToC_le with (F:= (fun '(_,_) => _ ));intros [].
        do 2 rewrite (correct__leUpToC (correct__UpToC _)). reflexivity.
      }
      assert (Hnth : forall n h,(fun '(_, x) => | x[@h] |) <=c
          (fun '(sim, v) =>
          L_facts.size sim + sumn (Vector.to_list (n:=n) (Vector.map (length (A:=bool)) v)) +
          1)).
          {
          clear. intros. eapply upToC_le;intros [? ?].
          clear. revert h t0. induction n;intros i v. easy. depelim v. depelim i.
            now cbn;nia.
            cbn. rewrite IHn. unfold Vector.to_list. nia.
          }
      smpl_upToC.
      all:try smpl_upToC_solve. now apply Hnth.
      -clear - Hnth. induction n.
       +depelim ren;cbn. smpl_upToC_solve.
       +depelim ren;cbn.
        etransitivity.
        *eapply upToC_le with (F:= (fun '(_,_) => _ ));intros []. unfold select in IHn.  rewrite (correct__leUpToC (IHn ren) (_,_)). reflexivity.
        *smpl_upToC. all:try smpl_upToC_solve.
         etransitivity.
         {
           eapply upToC_le with (F:= (fun '(_,_) => _ ));intros [? ?].
           change (encBoolsL t0[@h]) with (Extract.enc t0[@h]).
           rewrite (correct__leUpToC size_L_enc_bools). reflexivity.
         }
           smpl_upToC. apply Hnth. smpl_upToC_solve.
    }
  Qed.

  Program Definition startRen := Vectors.tabulate (n:=k) (fun i => Fin.of_nat_lt (n:=k) (p:=k - 1 -proj1_sig (Fin.to_nat i)) _).
  Next Obligation.
  destruct Fin.to_nat;cbn. nia.
  Defined. (* because definition *)

  Lemma startRen_spec A (v:Vector.t A _): select startRen v = Vector.rev v.
  Proof.
    unfold select.
    apply eq_nth_iff'. intros i. rewrite nth_map'.
    unfold startRen.
    unshelve erewrite nth_tabulate, vector_nth_rev. 1:abstract (inv i;nia).
    f_equal.  eapply Fin.of_nat_ext.
  Qed.

  Import CasePair Code.CaseList.

  Definition M_init sim : pTM (Σ) ^+ unit ((6 + m)+ k) :=
    M_init' sim startRen.

  Theorem M_init_SpecT:
  { f : UpToC (fun '(sim,v) => L_facts.size sim + sumn (Vector.to_list (Vector.map (length (A:=bool)) v)) + 1)
    & forall sim (v:Vector.t (list bool) k),
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) (6+m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v)
    (f (sim,v)) (M_init sim)
    (fun _ => ≃≃([],
      ([|Custom (eq niltape);
        Contains retr_pro (compile (Vector.fold_left (fun s l_i => L.app s (encBoolsL l_i)) sim v));
         Void;Void;Void;Void|]
         ++Vector.const (Custom (eq niltape)) m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v))}.
  Proof using H_disj.
    eexists_UpToC f. [f]:refine (fun '(sim,v) => _).
    intros.
    unfold M_init.
    eapply ConsequenceT. eapply (projT2 (M_init'_SpecT _)). reflexivity. 2:unfold f;reflexivity.
    cbn. intros _.
    rewrite vector_fold_left_right with (v:=v), <- (startRen_spec v).
    apply EntailsI. intros t H. eapply tspec_ext. eassumption. easy.
    intros i. clear - i.
    repeat (destruct (fin_destruct_S i) as [(i'&->) | ->];[rename i' into i;cbn| ]);try (intros H;exact H).
    unfold f;cbn beta.
    etransitivity.
    {
       eapply upToC_le with (F:= fun '(x,y)=>_);intros []. cbn.
      setoid_rewrite (correct__leUpToC (correct__UpToC _)). reflexivity.
    }
    smpl_upToC_solve.
  Qed.

End mk_init.

From Undecidability Require Import Enc_to_Boollist.

Section conv_output.

  Variable Σ : finType.
  Variable s b : Σ^+.
  Variable (retr_pro : Retract sigPro Σ).
  Variable (retr_list : Retract (sigList bool) Σ).

  Definition M_out : pTM (Σ) ^+ unit 4 :=
    EncToBoollist.M _ _ @ [|Fin0;Fin2;Fin3|];;
    Boollist2encBoolsTM.M s b _ @ [|Fin2;Fin1;Fin3|].

  Theorem M_out_SpecT :
    { f : UpToC (fun bs => length bs + 1) & forall bs,
    TripleT ≃≃([],[|Contains _ (compile (encBoolsL bs));Custom (eq niltape);Void;Void|])
      (f bs) M_out
      (fun _ => ≃≃([],
        ([|Custom (fun _ => True); Custom (eq (encBoolsTM s b bs)); Void;Void|])))}.
  Proof.
    eexists_UpToC f. [f]:refine (fun bs => _).
    intro bs.
    unfold M_out. hsteps_cbn;cbn.
    -eapply (projT2 (@EncToBoollist.SpecT _ _ _)).
    -eapply (projT2 (Boollist2encBoolsTM.SpecT _ _ _)).
    - cbn. rewrite rev_involutive. tspec_ext. easy.
    -unfold f.  setoid_rewrite (correct__leUpToC (correct__UpToC _)). rewrite rev_length. reflexivity.
    -unfold f. smpl_upToC_solve.
  Qed.

End conv_output.

From Undecidability.TM.L.HeapInterpreter Require UnfoldClosBounds.

Section main.

  Variable k : nat.
  Variable (R : Vector.t (list bool) k -> (list bool) -> Prop).

  Variable s : term.

  Hypothesis Hscl : closed s.

  Variable Hs1 : (forall v, forall m : list bool,
   L.eval (Vector.fold_left (fun (s0 : term) (n : list bool) => L.app s0 (encBoolsL n)) s v) (encBoolsL m)
   -> R v m).

  Variable Hs2 : (forall v, forall o : term,
                     L.eval (Vector.fold_left (n := k) (fun (s0 : term) (n : list bool) => L.app s0 (encBoolsL n)) s v) o ->
                     exists m : list bool, o = encBoolsL m).

  Definition n_main := 14.

  Definition Σ : Type := sigList bool + EvalL.Σintern.

  Definition retr_bools : Retract (sigList bool) Σ := (Retract_inl _ _).
  Definition retr_intern : Retract EvalL.Σintern Σ := (Retract_inr _ _).

  Definition retr_closs : Retract (sigList sigHClos) Σ
  := ComposeRetract retr_intern _.
  Definition retr_clos : Retract sigHClos Σ := ComposeRetract retr_closs _.
  Definition retr_pro : Retract sigPro Σ := ComposeRetract retr_clos _.

  Definition sym_s : Σ^+ := inr (inl (sigList_X true)).
  Definition sym_b : Σ^+ := inr (inl (sigList_X false)).

  (*
    auxiliary tapes:

    0    : T

   *)

  Notation aux n := (Fin.L k (Fin.R 1 n)).

  Definition garb : Σ^+ := inl UNKNOWN.

  Definition M_main : pTM (Σ ^+)  unit (1 + n_main + k):=
        M_init sym_s retr_pro retr_bools (1 + n_main - 6) k s ;;
        MK_isVoid_multi _ @ [|aux Fin5;aux Fin6;aux Fin7;aux Fin8;aux Fin9;aux Fin10;aux Fin11;aux Fin12;aux Fin13 |] ;;
        EvalL.M retr_intern retr_pro @ [| aux Fin0 ; aux Fin1 ; aux Fin2; aux Fin5 ; aux Fin6 ; aux Fin7 ; aux Fin8 ; aux Fin9 ; aux Fin10 ; aux Fin11 ; aux Fin12 |] ;;
        M_out sym_s sym_b retr_pro retr_bools @ [|aux Fin0;Fin.L k Fin0;aux Fin7;aux Fin8|].

  Lemma syms_diff : sym_s <> sym_b. Proof. cbv. congruence. Qed.

  Theorem M_main_Spec v:
    Triple ≃≃([],Vector.const (Custom (eq niltape)) (S n_main) ++ Vector.map (fun bs => Custom (eq (encBoolsTM sym_s sym_b bs))) v)
       M_main
      (fun _ t => exists m, t ≃≃ ([R v m]%list,
        (Custom (eq (encBoolsTM sym_s sym_b m)):::Vector.const (Custom (fun _ => True)) _))).
  Proof  using Hscl Hs1 Hs2.
    unfold M_main.
    hstep. { eapply TripleT_Triple,(projT2 (M_init_SpecT syms_diff _ _ _ _)). }
    cbn. intros _.
    start_TM.
    hstep. {hsteps_cbn;cbn. eapply TripleT_Triple. exact (MK_isVoid_multi_SpecT 9). }
    cbn;cleanupParamTM. intros _.
    hstep. {eapply LiftTapes_Spec_ex. now smpl_dupfree. cbn. refine (EvalL.Spec _ _ _). now eapply closed_compiler_helper. }
    cbn;cleanupParamTM.
    intros _. eapply Triple_exists_pre. intros s'.
    change (fun x => ?f x) with f.
    hintros Heval%eval_iff. specialize (Hs2 Heval) as (res&->).
    unfold_abbrev.
    eapply Triple_exists_con. eexists res.
    hstep. { eapply Consequence_pre. eapply TripleT_Triple. refine (projT2 (M_out_SpecT _ _ _ _) res). cbn. reflexivity. }
    cbn;cleanupParamTM. intros _.
    apply Hs1 in Heval.
    eapply EntailsI. intros tin [[] Hin]%tspecE.
    eapply tspecI;cbn. easy.
    intros i. specialize (Hin i). destruct_fin i;try exact Logic.I;cbn in *.
    now simpl_vector. eassumption.
  Qed.
End main.

Import UpToCNary.

Polymorphic Lemma upToC_mul_descend_nary (domain : list Type) (f g f' g': Rarrow domain nat):
  Uncurry f <=c Uncurry f'
  -> Uncurry g <=c Uncurry g'
  -> Fun' (fun x => App f x * App g x)
    <=c Fun' (fun x => App f' x * App g' x).
Proof.
  prove_nary upToC_mul_descend.
Qed.

Theorem M_main_SpecT k s (Hscl : closed s):
  { f : UpToC (fun '(i,m_r,m_v) => (i+1)*(i+m_v+1)*((m_v+1)*(i+1) + m_r)) &
  forall i v res,
    (Vector.fold_left (fun (s0 : term) (n : list bool) => L.app s0 (encBoolsL n)) s v) ⇓(i) (encBoolsL res)  ->
    TripleT ≃≃([],Vector.const (Custom (eq niltape)) (S n_main) ++ Vector.map (fun bs => Custom (eq (encBoolsTM sym_s sym_b bs))) v)
    (f (i,length res,sumn (Vector.to_list (Vector.map (length (A:=bool)) v)))) (M_main k s)
      (fun _ => ≃≃([],Custom (eq (encBoolsTM sym_s sym_b res)):::Vector.const (Custom (fun _ => True)) (13+S k)))}.
Proof.
  eexists_UpToC f. [f]:refine (fun '(i,m_r,m_v) => _).
  intros ? ? ? Red. unfold M_main.
  eapply ConsequenceT_pre. 2:reflexivity.
  {
  hstep. { eapply (projT2 (M_init_SpecT syms_diff _ _ _ _)). }
  2:{ set (f' := f__UpToC _). pose (H' := correct__UpToC _ :f' <=c _). rewrite (correct__leUpToC H'). subst f' H'; cbn beta;reflexivity. }
  cbn. intros _.
  start_TM.
  hstep. {hsteps_cbn;cbn. exact (MK_isVoid_multi_SpecT 9). } 2:reflexivity.
  cbn;cleanupParamTM. intros _.
  hstep. { eapply LiftTapes_SpecT. now smpl_dupfree. cbn. unshelve apply EvalL.SpecT. 3:now eapply closed_compiler_helper. 3:easy. }
  cbn;cleanupParamTM.
  intros _.
  hstep. now refine (projT2 (M_out_SpecT _ _ _ _) res).
  cbn;cleanupParamTM. intros _.
  eapply EntailsI. intros tin [[] Hin]%tspecE.
  eapply tspecI;cbn. easy.
  intros j. specialize (Hin j). destruct_fin j;try exact Logic.I;cbn in *.
  now simpl_vector. eassumption. cbn beta.
  set (l:= EvalL.steps _ _).
  pose (Hl:= proj2_sig UnfoldClosBounds.EvalL_steps_nice' _ _ _ _ _ : l <= _ ).
  rewrite Hl.   setoid_rewrite (correct__leUpToC (correct__UpToC _)) at 1. reflexivity.
  }
  set (f' := L_facts.size
      (Vector.fold_left _ _ _)). pose (H':= correct__leUpToC (size_fold_app k) (s,v) : f' <= _).
      cbn in H'. setoid_rewrite H'. clear f' H'.
  rewrite (LargestVar_fold s v) at 1.
  change (encBoolsL) with (Extract.enc (X:=list bool)).
  rewrite (correct__leUpToC size_L_enc_bools res).

  unfold f;cbn beta iota.
  set (m_s:= L_facts.size s). set (m_v:= sumn (Vector.to_list (Vector.map (length (A:=bool)) v))).
  set (m_r := length res).
  reflexivity.
  unfold f. cbn - ["+" "*"]. clear.
  assert ( (fun _ => 1) <=c (fun '(i, m_r,m_v) => (i + 1) * (i + m_v+1) * ((m_v + 1) * (i + 1) + m_r))) by smpl_upToC_solve.
  smpl_upToC.
  1,3:now smpl_upToC_solve.
  eapply leUpToC_proper_eq with (x:=fun '(i, m_r,m_v) => _) (x0:=fun '(i, m_r,m_v) => _).
  { intros [[]]. rewrite <- !Nat.mul_assoc. reflexivity. }
  { intros [[]]. rewrite <- !Nat.mul_assoc. reflexivity. }
  nary simple apply upToC_mul_descend_nary. reflexivity.
  nary simple apply upToC_mul_descend_nary. now smpl_upToC_solve.
  smpl_upToC.
  2,3:smpl_upToC_solve.
  transitivity ((fun '(t', x) => let '(t'0, x0) := t' in (0*x0)+(x + 1) * (t'0 + 1))).
  1,2:cbn.
  nary simple apply upToC_mul_descend_nary; now smpl_upToC_solve.
  smpl_upToC_solve.
Qed.

Theorem compiler_correct {k} (R : Vector.t (list bool) k -> (list bool) -> Prop) :
  L_bool_computable_closed R -> TM_bool_computable_hoare' R.
Proof.
  intros H.
  destruct H as [sim [cs Hsim]].
  hnf.
  eexists _, _, sym_s, sym_b. split. eapply syms_diff. exists (M_main k sim).
  intros v. split.
  - eapply M_main_Spec. easy. all:firstorder.
  - intros. edestruct eval_evalIn. now apply eval_iff,Hsim.
    eexists. eapply (projT2 (M_main_SpecT _ cs)). easy.
Qed.


(** The univalence axiom and its consequences *)

(**

In this file, we formulate univalence and its consequences, including functional
extensionality (the statement that functions with equal values are equal).

One approach would be to take univalence as the only axiom and to formulate
theorems proving the consequences, whose proofs would appeal to the
univalence axiom.  We adopt a different approach here, preferring also to
introduce axioms for various consequences of univalence.  This allows us to
measure how subsequent theorems depend on the axioms using the "Print
Assumptions" command of Coq.

An important point is that the types of all our axioms are propositions, that is
types of h-level 1 and once an element of such a type is declared or contructed
it becomes a contractible type.

In particular, the declared element corresponding to the axiom and the element
that can be contructed using another, stronger, axiom are connected by a path.

Proofs that the types of our axioms are propositions will be provided in the
file UnivalenceAxiom2.

We postpone stating the axioms themselves until after all the implications
are established; this helps us encourage the use of the axioms for the
consequences of univalence, rather than the theorems giving the implications.

*)

(** Preliminaries  *)

Require Export UniMath.Foundations.PartB.

(* everything related to eta correction is obsolete *)

Definition eqweqmap { T1 T2 : UU } : T1 = T2 -> T1 ≃ T2.
Proof.
  intro e. induction e. apply idweq.
Defined.

Definition sectohfiber { X : UU } (P:X -> UU): (∏ x:X, P x) -> (hfiber (λ f, λ x, pr1  (f x)) (λ x:X, x)) := (fun a : ∏ x:X, P x => tpair _ (λ x, tpair _ x (a x)) (idpath (λ x:X, x))).

Definition hfibertosec { X : UU } (P:X -> UU):
  (hfiber (λ f x, pr1 (f x)) (λ x:X, x)) -> (∏ x:X, P x)
  := λ se , λ x:X, match se as se' return P x with tpair _ s e => (transportf P (toforallpaths _ (λ x:X, pr1 (s x)) (λ x:X, x) e x) (pr2  (s x))) end.

Definition sectohfibertosec { X : UU } (P:X -> UU):
  ∏ a : (∏ x:X, P x), hfibertosec _ (sectohfiber _ a) = a.
Proof.
  apply idpath.
Defined.

Lemma isweqtransportf10 { X : UU } ( P : X -> UU ) { x x' : X } ( e :  x = x' ) : isweq ( transportf P e ).
Proof.
  intros. induction e.  apply idisweq.
Defined.

Lemma isweqtransportb10 { X : UU } ( P : X -> UU ) { x x' : X } ( e :  x = x' ) : isweq ( transportb P e ).
Proof.
  intros. apply ( isweqtransportf10 _ ( pathsinv0 e ) ).
Defined.

Lemma l1  { X0 X0' : UU } ( ee : X0 = X0' ) ( P : UU -> UU ) ( pp' : P X0' ) ( R : ∏ X X' : UU , ∏ w : X ≃ X' , P X' -> P X ) ( r : ∏ X : UU , ∏ p : P X , paths ( R X X ( idweq X ) p ) p ) : paths ( R X0 X0' ( eqweqmap ee ) pp' ) (  transportb P ee pp' ).
Proof.
  induction ee. simpl. apply r.
Defined.

(** Axiom statements (propositions) *)

Definition univalenceStatement := ∏ X Y:UU, isweq (@eqweqmap X Y).

Definition funextemptyStatement := ∏ (X:UU) (f g : X->empty), f = g.

Definition propositionalUnivalenceStatement :=
  ∏ (P Q:UU), isaprop P -> isaprop Q -> (P -> Q) -> (Q -> P) -> P=Q.

Definition funcontrStatement :=
  ∏ (X : UU) (P:X -> UU),
    (∏ x:X, iscontr (P x)) -> iscontr (∏ x:X, P x).

Definition funextcontrStatement :=
  ∏ (T:UU) (P:T -> UU) (g: ∏ t, P t), ∃! (f:∏ t, P t), ∏ t:T, f t = g t.

Definition isweqtoforallpathsStatement :=
  ∏ (T:UU) (P:T -> UU) (f g :∏ t:T, P t), isweq (toforallpaths _ f g).

(** Axiom consequence statements (not propositions) *)

Definition funextsecStatement :=
  ∏ (T:UU) (P:T -> UU) (f g :∏ t:T, P t), f ~ g -> f = g.

Definition funextfunStatement :=
  ∏ (X Y:UU) (f g : X -> Y), f ~ g -> f = g.

Definition weqtopathsStatement := ∏ ( T1 T2 : UU ), T1 ≃ T2 -> T1 = T2.

Definition weqpathsweqStatement (weqtopaths:weqtopathsStatement) :=
  ∏ ( T1 T2 : UU ) ( w : T1 ≃ T2 ), eqweqmap (weqtopaths _ _ w) = w.

Definition weqtoforallpathsStatement :=
  ∏ (T:UU) (P:T -> UU) (f g :∏ t:T, P t), (f = g) ≃ (f ~ g).

(** Implications between statements and consequences of them *)

Theorem funextsecImplication : isweqtoforallpathsStatement -> funextsecStatement.
Proof.
  intros fe ? ? ? ?. exact (invmap (make_weq _ (fe _ _ f g))).
Defined.

Theorem funextfunImplication : funextsecStatement -> funextfunStatement.
Proof.
  intros fe ? ?. apply fe.
Defined.

(** We show that [ univalenceAxiom ] is equivalent to the axioms [ weqtopathsStatement ] and [ weqpathsweqStatement ] stated below . *)

Theorem univfromtwoaxioms :
  (∑ weqtopaths: weqtopathsStatement, weqpathsweqStatement weqtopaths)
  <-> univalenceStatement.
Proof.
  split.
  { intros [weqtopaths weqpathsweq] T1 T2.
    set ( P1 := λ XY : UU × UU, pr1 XY = pr2 XY ) .
    set ( P2 := λ XY :  UU × UU, (pr1 XY) ≃ (pr2 XY) ) .
    set ( Z1 := total2 P1 ). set ( Z2 := total2 P2 ).
    set ( f := totalfun _ _ ( λ XY : UU × UU,  @eqweqmap (pr1 XY) (pr2 XY)) : Z1 -> Z2 ) .
    set ( g := totalfun _ _ ( λ XY : UU × UU,  weqtopaths (pr1 XY) (pr2 XY) ) : Z2 -> Z1 ) .
    assert (efg : funcomp g f ~ idfun _) .
    - intro z2 . induction z2 as [ XY e ] .
      unfold g . unfold f . unfold totalfun . simpl .
      apply ( maponpaths ( fun w : ( pr1 XY) ≃ (pr2 XY) =>  tpair P2 XY w )
                       ( weqpathsweq ( pr1 XY ) ( pr2 XY ) e )) .
    - set ( h := λ a1 : Z1,  pr1 ( pr1 a1 ) ) .
      assert ( egf0 : ∏ a1 : Z1 ,  pr1 ( g ( f a1 ) ) = pr1 a1 ).
      + intro. apply idpath.
      + assert ( egf1 : ∏ a1 a1' : Z1 ,  paths ( pr1 a1' ) (  pr1 a1 ) ->  a1' = a1 ).
        * intros.
          set ( X' :=  maponpaths pr1 X ).
          assert ( is : isweq h ).
          { simpl in h .  apply isweqpr1pr1 . }
          apply ( invmaponpathsweq ( make_weq h is ) _ _ X' ).
        * set ( egf := λ a1 , egf1 _ _ ( egf0 a1 ) ).
          set ( is2 := isweq_iso _ _ egf efg ).
          apply ( isweqtotaltofib _ _ ( λ _, eqweqmap) is2 ( make_dirprod T1 T2 ) ).
          }
  { intros ua.
    simple refine (_,,_).
    - intros ? ?. exact (invmap (make_weq _ (ua _ _))).
    - intros ? ?. exact (homotweqinvweq (make_weq _ (ua _ _))). }
Defined.

(** Conjecture :  the pair [weqtopaths] and [weqtopathsweq] in the proof above is well defined up to a canonical equality. **)

Section UnivalenceImplications.

  (** In this section we take univalence as a hypothesis, not as an axiom, so
     we can limit the number of theorems that take univalence an axiom.

     The suffix UAH on the name of a theorem indicates a theorem that will be
     stated later unconditionally, with a proof that appeals to the future
     univalence axiom. *)

  Hypothesis univalenceAxiom : univalenceStatement.

  Theorem univalenceUAH (X Y:UU) : (X=Y) ≃ (X≃Y).
  Proof.
    exact (make_weq _ (univalenceAxiom X Y)).
  Defined.

  Definition weqtopathsUAH : weqtopathsStatement.
  Proof.
    intros ? ?. exact (invmap (univalenceUAH _ _)).
  Defined.
  Arguments weqtopathsUAH {_ _} _.

  Definition weqpathsweqUAH : weqpathsweqStatement (@weqtopathsUAH).
  Proof.
    intros ? ? w. exact (homotweqinvweq (univalenceUAH T1 T2) w).
  Defined.
  Arguments weqpathsweqUAH {_ _} _.

  Lemma propositionalUnivalenceUAH: propositionalUnivalenceStatement.
  Proof.
    unfold propositionalUnivalenceStatement; intros ? ? i j f g.
    apply weqtopathsUAH.
    simple refine (make_weq f (isweq_iso f g _ _)).
    - intro p. apply proofirrelevance, i.
    - intro q. apply proofirrelevance, j.
  Defined.

  (** ** Proof of the functional extensionality for functions from univalence *)

  (** ** Transport theorem.

    Theorem saying that any general scheme to "transport" a structure along a
    weak equivalence which does not change the structure in the case of the
    identity equivalence is equivalent to the transport along the path which
    corresponds to a weak equivalence by the univalenceAxiom. As a corollary we
    conclude that for any such transport scheme the corresponding maps on spaces
    of structures are weak equivalences. *)

  Theorem weqtransportbUAH ( P : UU -> UU )
          ( R : ∏ ( X X' : UU ) ( w :  X ≃ X' ) , P X' -> P X )
          ( r : ∏ X : UU , ∏ p : P X , R X X ( idweq X ) p = p ) :
    ∏ ( X X' : UU ) ( w :  X ≃ X' ) ( p' : P X' ),
      R X X' w p' = transportb P ( weqtopathsUAH w ) p'.
  Proof.
    intros.
    set ( uv := weqtopathsUAH w ).
    set ( v := eqweqmap uv ).
    assert ( e : v = w ) .
    - unfold weqtopathsUAH in uv.
      apply ( homotweqinvweq ( univalenceUAH X X' ) w ).
    - assert ( ee : R X X' v p' = R X X' w p' ).
      + set ( R' := fun vis : X ≃ X' => R X X' vis p' ).
        assert ( ee' : R' v = R' w ).
        * apply (  maponpaths R' e ).
        * assumption.
      + induction ee. apply l1. assumption.
  Defined.

  Corollary isweqweqtransportbUAH
            ( P : UU -> UU )
            ( R :  ∏ ( X X' : UU ) ( w : X ≃ X' ) , P X' -> P X )
            ( r :  ∏ X : UU , ∏ p : P X , R X X ( idweq X ) p  = p ) :
    ∏ ( X X' : UU ) ( w : X ≃ X' ),
      isweq ( λ p' :  P X', R X X' w p' ).
  Proof.
    intros.
    assert ( e : R X X' w ~ transportb P ( weqtopathsUAH w )).
    - unfold homot. apply weqtransportbUAH. assumption.
    - assert ( ee : transportb P ( weqtopathsUAH w ) ~ R X X' w).
      + intro p'. apply ( pathsinv0 ( e p' ) ).
      + clear e.
        assert ( is1 : isweq ( transportb P ( weqtopathsUAH w ) ) ).
        apply isweqtransportb10.
        apply ( isweqhomot ( transportb P ( weqtopathsUAH w ) ) (R X X' w) ee is1 ).
  Defined.

  (** Theorem saying that composition with a weak equivalence is a weak equivalence on function spaces. *)

  Theorem isweqcompwithweqUAH { X X' : UU } ( w : X ≃ X' ) ( Y : UU ) :
    isweq ( fun f : X' -> Y => ( λ x : X, f ( w x ) ) ).
  Proof.
    set ( P := λ X0 : UU, ( X0 -> Y ) ).
    set ( R := λ X0 : UU, ( λ X0' : UU, ( fun w1 : X0 -> X0' =>  ( λ  f : P X0' , ( λ x : X0, f ( w1 x ) ) ) ) ) ).
    apply ( isweqweqtransportbUAH P R (λ X0 f, idpath _) X X' w ).
  Defined.

  Lemma eqcor0UAH { X X' : UU } ( w :  X ≃ X' ) ( Y : UU ) ( f1 f2 : X' -> Y ) :
    (λ x : X, f1 ( w x )) = (λ x : X, f2 ( w x ) ) -> f1 = f2.
  Proof.
    apply ( invmaponpathsweq ( make_weq _ ( isweqcompwithweqUAH w Y ) ) f1 f2 ).
  Defined.

  Lemma apathpr1toprUAH ( T : UU ) : paths ( λ z :  pathsspace T, pr1 z ) ( λ z : pathsspace T, pr1 ( pr2 z ) ).
  Proof.
    apply ( eqcor0UAH ( make_weq _ ( isweqdeltap T ) ) _ ( λ z :  pathsspace T, pr1 z ) ( λ z :  pathsspace T, pr1 ( pr2 z ) ) ( idpath ( idfun T ) ) ) .
  Defined.

  Theorem funextfunPreliminaryUAH : funextfunStatement.
  Proof.
    intros ? ? f1 f2 e.
    set ( f := λ x : X, pathsspacetriple Y ( e x ) ).
    set ( g1 := λ z : pathsspace Y, pr1 z ).
    set ( g2 := λ z : pathsspace Y, pr1 ( pr2 z ) ).
    change ( (funcomp f g1) = (funcomp f g2) ).
    apply maponpaths.
    apply apathpr1toprUAH.
  Defined.
  Arguments funextfunPreliminaryUAH {_ _} _ _ _.

  Lemma funextemptyUAH : funextemptyStatement.
  Proof.
    unfold funextemptyStatement; intros.
    apply funextfunPreliminaryUAH.
    intro x.
    induction (f x).
  Defined.

  (** *** Deduction of functional extensionality for dependent functions (sections) from functional extensionality of usual functions *)

  Lemma isweqlcompwithweqUAH {X X' : UU} (w: X ≃ X') (Y:UU) : isweq (fun (a:X'->Y) x => a (w x)).
  (* this lemma is currently unused *)
  Proof.
    simple refine (isweq_iso _ _ _ _).
    exact (λ b x', b (invweq w x')).
    exact (λ a, funextfunPreliminaryUAH _ a (λ x', maponpaths a (homotweqinvweq w x'))).
    exact (λ a, funextfunPreliminaryUAH _ a (λ x , maponpaths a (homotinvweqweq w x ))).
  Defined.

  Lemma isweqrcompwithweqUAH { Y Y':UU } (w: Y ≃ Y')(X:UU) :
    isweq (fun a:X->Y => (λ x, w (a x))).
  Proof.
    simple refine (isweq_iso _ _ _ _).
    exact (fun a':X->Y' => λ x, (invweq  w (a' x))).
    exact (fun a :X->Y  => funextfunPreliminaryUAH _ a (λ x, homotinvweqweq w (a x))).
    exact (fun a':X->Y' => funextfunPreliminaryUAH _ a' (λ x, homotweqinvweq w (a' x))).
  Defined.

  Theorem funcontrUAH : funcontrStatement.
  Proof.
    unfold funcontrStatement.
    intros ? ? X0.
    set (T1 := ∏ x:X, P x).
    set (T2 := (hfiber (fun f: (X -> total2 P)  => λ x: X, pr1  (f x)) (λ x:X, x))).
    assert (is1:isweq (@pr1 X P)).
    - apply isweqpr1. assumption.
    - set (w1:= make_weq  (@pr1 X P) is1).
      assert (X1:iscontr T2).
      + apply (isweqrcompwithweqUAH w1 X (λ x:X, x)).
      + apply (iscontrretract _ _ (sectohfibertosec P) X1).
  Defined.

  (** Proof of the fact that the [ toforallpaths ] from [s1 = s2] to
  [∏ t:T, paths (s1 t) (s2 t)] is a weak equivalence - a strong form of
  functional extensionality for sections of general families. The proof uses
  only [funcontrUAH] which is an element of a proposition.  *)

  Lemma funextcontrUAH : funextcontrStatement.
  Proof.
    unfold funextcontrStatement.
    intros.
    use (iscontrretract (X := ∏ t, ∑ p, p = g t)).
    - intros x. use tpair.
      + intro t. exact (pr1 (x t)).
      + intro t; simpl. exact (pr2 (x t)).
    - intros y t. exists (pr1 y t). exact (pr2 y t).
    - intros u. induction u as [t x]. apply idpath.
    - apply funcontrUAH. intro t. apply iscontrcoconustot.
  Defined.
  Arguments funextcontrUAH {_} _ _.

  Theorem isweqtoforallpathsUAH : isweqtoforallpathsStatement.
  Proof.
    unfold isweqtoforallpathsStatement.
    intros.
    refine (isweqtotaltofib _ _ (λ (h:∏ t, P t), toforallpaths _ h g) _ f).
    refine (isweqcontrcontr (X := ∑ (h: ∏ t, P t), h = g)
              (λ ff, tpair _ (pr1 ff) (toforallpaths P (pr1 ff) g (pr2 ff))) _ _).
    { exact (iscontrcoconustot _ g). }
    { apply funextcontrUAH. }
  Qed.

End UnivalenceImplications.

(** Univalence implies each of the other axioms *)

Definition funcontrFromUnivalence: univalenceStatement -> funcontrStatement
  := funcontrUAH.

Definition funextsecweqFromUnivalence: univalenceStatement -> isweqtoforallpathsStatement
  := isweqtoforallpathsUAH.

Definition funextemptyFromUnivalence: univalenceStatement -> funextemptyStatement
  := funextemptyUAH.

Definition propositionalUnivalenceFromUnivalence: univalenceStatement -> propositionalUnivalenceStatement
  := propositionalUnivalenceUAH.

Definition funextcontrStatementFromUnivalence: univalenceStatement ->  funextcontrStatement
  := funextcontrUAH.

(** the axioms themselves *)

Axiom univalenceAxiom : univalenceStatement.
Axiom funextemptyAxiom : funextemptyStatement.
Axiom isweqtoforallpathsAxiom : isweqtoforallpathsStatement.
Axiom funcontrAxiom : funcontrStatement.
Axiom propositionalUnivalenceAxiom : propositionalUnivalenceStatement.
Axiom funextcontrAxiom : funextcontrStatement.

(** provide some theorems based on the axioms  *)

Definition funextempty := funextemptyAxiom.

Definition univalence := univalenceUAH univalenceAxiom.

Definition weqtopaths : weqtopathsStatement.
Proof.
  unfold weqtopathsStatement.
  intros ? ?.
  exact (invmap (univalence _ _)).
Defined.
Arguments weqtopaths {_ _} _.

Definition weqpathsweq := weqpathsweqUAH univalenceAxiom.
Arguments weqpathsweq {_ _} _.

Definition funcontr : funcontrStatement := funcontrAxiom.
Arguments funcontr {_} _ _.

Definition funextcontr : funextcontrStatement := @funextcontrAxiom.
Arguments funextcontr {_} _ _.

Definition isweqtoforallpaths : isweqtoforallpathsStatement := isweqtoforallpathsAxiom.
Arguments isweqtoforallpaths {_} _ _ _ _.

Definition weqtoforallpaths : weqtoforallpathsStatement
  := λ X P f g, make_weq _ (@isweqtoforallpaths X P f g).
Arguments weqtoforallpaths {_} _ _ _.
(* Print Assumptions weqtoforallpaths. (* isweqtoforallpathsAxiom *) *)

Definition funextsec : funextsecStatement := funextsecImplication isweqtoforallpathsAxiom.
Arguments funextsec {_} _ _ _ _.
(* Print Assumptions funextsec.    (* isweqtoforallpathsAxiom *) *)

Definition funextfun := funextfunImplication (@funextsec).
Arguments funextfun {_ _} _ _ _.
(* Print Assumptions funextfun.    (* isweqtoforallpathsAxiom *) *)

Definition weqfunextsec { T : UU } (P:T -> UU) (f g : ∏ t:T, P t) :
  (f ~ g) ≃ (f = g)
  := invweq (weqtoforallpaths P f g).
(* Print Assumptions weqfunextsec. (* isweqtoforallpathsAxiom *) *)

Corollary funcontrtwice { X : UU } (P: X-> X -> UU) (is: ∏ (x x':X), iscontr (P x x')) :
  iscontr (∏ (x x':X), P x x').
Proof.
  intros.
  assert (is1: ∏ x:X, iscontr (∏ x':X, P x x')).
  - intro. apply (funcontr _ (is x)).
  - apply (funcontr _ is1).
Defined.

(** Check assumptions *)

Lemma toforallpaths_induction (X Y : UU) (f g : X -> Y) (P : (∏ x, f x = g x) -> UU)
      (H : ∏ e : f = g, P (toforallpaths _ _ _ e)) : ∏ i : (∏ x, f x = g x), P i.
Proof.
  intros i. rewrite <- (homotweqinvweq (weqtoforallpaths _ f g)). apply H.
Defined.

Definition transportf_funextfun {X Y : UU} (P : Y -> UU) (F F' : X -> Y) (H : ∏ (x : X), F x = F' x)
           (x : X) (f : P (F x)) :
  transportf (λ x0 : X → Y, P (x0 x)) (funextsec _ F F' H) f = transportf (λ x0 : Y, P x0) (H x) f.
Proof.
  apply (toforallpaths_induction
           _ _ F F' (λ H', transportf (λ x0 : X → Y, P (x0 x))
                                       (funextsec (λ _ : X, Y) F F' (λ x0 : X, H' x0)) f =
                            transportf (λ x0 : Y, P x0) (H' x) f)).
  intro e. clear H.
  set (XR := homotinvweqweq (weqtoforallpaths _ F F') e).
  set (H := funextsec (λ _ : X, Y) F F' (λ x0 : X, toforallpaths (λ _ : X, Y) F F' e x0)).
  set (P' := λ x0 : X → Y, P (x0 x)).
  use pathscomp0.
  - exact (transportf P' e f).
  - use transportf_paths. exact XR.
  - induction e. apply idpath.
Defined.

(** induction tactic for the universe *)

Theorem UU_rect (X Y : UU) (P : X ≃ Y -> UU) :
  (∏ e : X=Y, P (univalence _ _ e)) -> ∏ f, P f.
Proof.
  intros ih ?.
  set (p := ih (invmap (univalence _ _) f)).
  set (h := homotweqinvweq (univalence _ _) f).
  exact (transportf P h p).
Defined.

Ltac type_induction f e := generalize f; apply UU_rect; intro e; clear f.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path.
From mathcomp Require Import div choice fintype tuple finfun bigop prime order.
From mathcomp Require Import ssralg poly finset fingroup morphism perm.
From mathcomp Require Import automorphism quotient finalg action gproduct.
From mathcomp Require Import zmodp commutator cyclic center pgroup sylow.
From mathcomp Require Import frobenius vector ssrnum ssrint intdiv algC.
From mathcomp Require Import algnum classfun character integral_char.

(******************************************************************************)
(* This file provides basic notions of virtual character theory:              *)
(*       'Z[S, A] == collective predicate for the phi that are Z-linear       *)
(*                   combinations of elements of S : seq 'CF(G) and have      *)
(*                   support in A : {set gT}.                                 *)
(*          'Z[S] == collective predicate for the Z-linear combinations of    *)
(*                   elements of S.                                           *)
(*      'Z[irr G] == the collective predicate for virtual characters.         *)
(*         dirr G == the collective predicate for normal virtual characters,  *)
(*                   i.e., virtual characters of norm 1:                      *)
(*               mu \in dirr G <=> m \in 'Z[irr G] and '[mu] = 1              *)
(*                             <=> mu or - mu \in irr G.                      *)
(* --> othonormal subsets of 'Z[irr G] are contained in dirr G.               *)
(*        dIirr G == an index type for normal virtual characters.             *)
(*         dchi i == the normal virtual character of index i.                 *)
(*       of_irr i == the (unique) irreducible constituent of dchi i:          *)
(*                   dchi i = 'chi_(of_irr i) or - 'chi_(of_irr i).           *)
(*        ndirr i == the index of - dchi i.                                   *)
(*        dirr1 G == the normal virtual character index of 1 : 'CF(G), the    *)
(*                   principal character.                                     *)
(* dirr_dIirr j f == the index i (or dirr1 G if it does not exist) such that  *)
(*                   dchi i = f j.                                            *)
(* dirr_constt phi == the normal virtual character constituents of phi:       *)
(*                    i \in dirr_constt phi <=> [dchi i, phi] > 0.            *)
(*  to_dirr phi i == the normal virtual character constituent of phi with an  *)
(*                   irreducible constituent i, when i \in irr_constt phi.    *)
(******************************************************************************)

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

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

Section Basics.

Variables (gT : finGroupType) (B : {set gT}) (S : seq 'CF(B)) (A : {set gT}).

Definition Zchar : {pred 'CF(B)} :=
  [pred phi in 'CF(B, A) | dec_Cint_span (in_tuple S) phi].
Fact Zchar_key : pred_key Zchar. Proof. by []. Qed.
Canonical Zchar_keyed := KeyedPred Zchar_key.

Lemma cfun0_zchar : 0 \in Zchar.
Proof.
rewrite inE mem0v; apply/sumboolP; exists 0.
by rewrite big1 // => i _; rewrite ffunE.
Qed.

Fact Zchar_zmod : zmod_closed Zchar.
Proof.
split; first exact: cfun0_zchar.
move=> phi xi /andP[Aphi /sumboolP[a Da]] /andP[Axi /sumboolP[b Db]].
rewrite inE rpredB // Da Db -sumrB; apply/sumboolP; exists (a - b).
by apply: eq_bigr => i _; rewrite -mulrzBr !ffunE.
Qed.
Canonical Zchar_opprPred := OpprPred Zchar_zmod.
Canonical Zchar_addrPred := AddrPred Zchar_zmod.
Canonical Zchar_zmodPred := ZmodPred Zchar_zmod.

Lemma scale_zchar a phi : a \in Cint -> phi \in Zchar -> a *: phi \in Zchar.
Proof. by case/CintP=> m -> Zphi; rewrite scaler_int rpredMz. Qed.

End Basics.

Notation "''Z[' S , A ]" := (Zchar S A)
  (at level 8, format "''Z[' S ,  A ]") : group_scope.
Notation "''Z[' S ]" := 'Z[S, setT]
  (at level 8, format "''Z[' S ]") : group_scope.

Section Zchar.

Variables (gT : finGroupType) (G : {group gT}).
Implicit Types (A B : {set gT}) (S : seq 'CF(G)).

Lemma zchar_split S A phi :
  phi \in 'Z[S, A] = (phi \in 'Z[S]) && (phi \in 'CF(G, A)).
Proof. by rewrite !inE cfun_onT andbC. Qed.

Lemma zcharD1E phi S : (phi \in 'Z[S, G^#]) = (phi \in 'Z[S]) && (phi 1%g == 0).
Proof. by rewrite zchar_split cfunD1E. Qed.

Lemma zcharD1 phi S A :
  (phi \in 'Z[S, A^#]) = (phi \in 'Z[S, A]) && (phi 1%g == 0).
Proof. by rewrite zchar_split cfun_onD1 andbA -zchar_split. Qed.

Lemma zcharW S A : {subset 'Z[S, A] <= 'Z[S]}.
Proof. by move=> phi; rewrite zchar_split => /andP[]. Qed.

Lemma zchar_on S A : {subset 'Z[S, A] <= 'CF(G, A)}.
Proof. by move=> phi /andP[]. Qed.

Lemma zchar_onS A B S : A \subset B -> {subset 'Z[S, A] <= 'Z[S, B]}.
Proof.
move=> sAB phi; rewrite zchar_split (zchar_split _ B) => /andP[->].
exact: cfun_onS.
Qed.

Lemma zchar_onG S : 'Z[S, G] =i 'Z[S].
Proof. by move=> phi; rewrite zchar_split cfun_onG andbT. Qed.

Lemma irr_vchar_on A : {subset 'Z[irr G, A] <= 'CF(G, A)}.
Proof. exact: zchar_on. Qed.

Lemma support_zchar S A phi : phi \in 'Z[S, A] -> support phi \subset A.
Proof. by move/zchar_on; rewrite cfun_onE. Qed.

Lemma mem_zchar_on S A phi :
  phi \in 'CF(G, A) -> phi \in S -> phi \in 'Z[S, A].
Proof.
move=> Aphi /(@tnthP _ _ (in_tuple S))[i Dphi]; rewrite inE /= {}Aphi {phi}Dphi.
apply/sumboolP; exists [ffun j => (j == i)%:Z].
rewrite (bigD1 i) //= ffunE eqxx (tnth_nth 0) big1 ?addr0 // => j i'j.
by rewrite ffunE (negPf i'j).
Qed.

(* A special lemma is needed because trivial fails to use the cfun_onT Hint. *)
Lemma mem_zchar S phi : phi \in S -> phi \in 'Z[S].
Proof. by move=> Sphi; rewrite mem_zchar_on ?cfun_onT. Qed.

Lemma zchar_nth_expansion S A phi :
    phi \in 'Z[S, A] ->
  {z | forall i, z i \in Cint & phi = \sum_(i < size S) z i *: S`_i}.
Proof.
case/andP=> _ /sumboolP/sig_eqW[/= z ->].
exists (intr \o z) => [i|]; first exact: Cint_int.
by apply: eq_bigr => i _; rewrite scaler_int.
Qed.

Lemma zchar_tuple_expansion n (S : n.-tuple 'CF(G)) A phi :
    phi \in 'Z[S, A] ->
  {z | forall i, z i \in Cint & phi = \sum_(i < n) z i *: S`_i}.
Proof. by move/zchar_nth_expansion; rewrite size_tuple. Qed.

(* A pure seq version with the extra hypothesis of S's unicity.  *)
Lemma zchar_expansion S A phi : uniq S ->
    phi \in 'Z[S, A] ->
  {z | forall xi, z xi \in Cint & phi = \sum_(xi <- S) z xi *: xi}.
Proof.
move=> Suniq /zchar_nth_expansion[z Zz ->] /=.
pose zS xi := oapp z 0 (insub (index xi S)).
exists zS => [xi | ]; rewrite {}/zS; first by case: (insub _).
rewrite (big_nth 0) big_mkord; apply: eq_bigr => i _; congr (_ *: _).
by rewrite index_uniq // valK.
Qed.

Lemma zchar_span S A : {subset 'Z[S, A] <= <<S>>%VS}.
Proof.
move=> _ /zchar_nth_expansion[z Zz ->] /=.
by apply: rpred_sum => i _; rewrite rpredZ // memv_span ?mem_nth.
Qed.

Lemma zchar_trans S1 S2 A B :
  {subset S1 <= 'Z[S2, B]} -> {subset 'Z[S1, A] <= 'Z[S2, A]}.
Proof.
move=> sS12 phi; rewrite !(zchar_split _ A) andbC => /andP[->]; rewrite andbT.
case/zchar_nth_expansion=> z Zz ->; apply: rpred_sum => i _.
by rewrite scale_zchar // (@zcharW _ B) ?sS12 ?mem_nth.
Qed.

Lemma zchar_trans_on S1 S2 A :
  {subset S1 <= 'Z[S2, A]} -> {subset 'Z[S1] <= 'Z[S2, A]}.
Proof.
move=> sS12 _ /zchar_nth_expansion[z Zz ->]; apply: rpred_sum => i _.
by rewrite scale_zchar // sS12 ?mem_nth.
Qed.

Lemma zchar_sub_irr S A :
  {subset S <= 'Z[irr G]} -> {subset 'Z[S, A] <= 'Z[irr G, A]}.
Proof. exact: zchar_trans. Qed.

Lemma zchar_subset S1 S2 A :
  {subset S1 <= S2} -> {subset 'Z[S1, A] <= 'Z[S2, A]}.
Proof.
move=> sS12; apply: zchar_trans setT _ => // f /sS12 S2f.
by rewrite mem_zchar.
Qed.

Lemma zchar_subseq S1 S2 A :
  subseq S1 S2 -> {subset 'Z[S1, A] <= 'Z[S2, A]}.
Proof. by move/mem_subseq; apply: zchar_subset. Qed.

Lemma zchar_filter S A (p : pred 'CF(G)) :
  {subset 'Z[filter p S, A] <= 'Z[S, A]}.
Proof. by apply: zchar_subset=> f; apply/mem_subseq/filter_subseq. Qed.

End Zchar.

Section VChar.

Variables (gT : finGroupType) (G : {group gT}).
Implicit Types (A B : {set gT}) (phi chi : 'CF(G)) (S : seq 'CF(G)).

Lemma char_vchar chi : chi \is a character -> chi \in 'Z[irr G].
Proof.
case/char_sum_irr=> r ->; apply: rpred_sum => i _.
by rewrite mem_zchar ?mem_tnth.
Qed.

Lemma irr_vchar i : 'chi[G]_i \in 'Z[irr G].
Proof. exact/char_vchar/irr_char. Qed.

Lemma cfun1_vchar : 1 \in 'Z[irr G]. Proof. by rewrite -irr0 irr_vchar. Qed.

Lemma vcharP phi :
  reflect (exists2 chi1, chi1 \is a character
            & exists2 chi2, chi2 \is a character & phi = chi1 - chi2)
          (phi \in 'Z[irr G]).
Proof.
apply: (iffP idP) => [| [a Na [b Nb ->]]]; last by rewrite rpredB ?char_vchar.
case/zchar_tuple_expansion=> z Zz ->; rewrite (bigID (fun i => 0 <= z i)) /=.
set chi1 := \sum_(i | _) _; set nchi2 := \sum_(i | _) _.
exists chi1; last exists (- nchi2); last by rewrite opprK.
  apply: rpred_sum => i zi_ge0; rewrite -tnth_nth rpredZ_Cnat ?irr_char //.
  by rewrite CnatEint Zz.
rewrite -sumrN rpred_sum // => i zi_lt0; rewrite -scaleNr -tnth_nth.
rewrite rpredZ_Cnat ?irr_char // CnatEint rpredN Zz oppr_ge0 ltW //.
by rewrite real_ltNge ?Creal_Cint.
Qed.

Lemma Aint_vchar phi x : phi \in 'Z[irr G] -> phi x \in Aint.
Proof.
case/vcharP=> [chi1 Nchi1 [chi2 Nchi2 ->]].
by rewrite !cfunE rpredB ?Aint_char.
Qed.

Lemma Cint_vchar1 phi : phi \in 'Z[irr G] -> phi 1%g \in Cint.
Proof.
case/vcharP=> phi1 Nphi1 [phi2 Nphi2 ->].
by rewrite !cfunE rpredB // rpred_Cnat ?Cnat_char1.
Qed.

Lemma Cint_cfdot_vchar_irr i phi : phi \in 'Z[irr G] -> '[phi, 'chi_i] \in Cint.
Proof.
case/vcharP=> chi1 Nchi1 [chi2 Nchi2 ->].
by rewrite cfdotBl rpredB // rpred_Cnat ?Cnat_cfdot_char_irr.
Qed.

Lemma cfdot_vchar_r phi psi :
  psi \in 'Z[irr G] -> '[phi, psi] = \sum_i '[phi, 'chi_i] * '[psi, 'chi_i].
Proof.
move=> Zpsi; rewrite cfdot_sum_irr; apply: eq_bigr => i _; congr (_ * _).
by rewrite aut_Cint ?Cint_cfdot_vchar_irr.
Qed.

Lemma Cint_cfdot_vchar : {in 'Z[irr G] &, forall phi psi, '[phi, psi] \in Cint}.
Proof.
move=> phi psi Zphi Zpsi; rewrite /= cfdot_vchar_r // rpred_sum // => k _.
by rewrite rpredM ?Cint_cfdot_vchar_irr.
Qed.

Lemma Cnat_cfnorm_vchar : {in 'Z[irr G], forall phi, '[phi] \in Cnat}.
Proof.
by move=> phi Zphi; rewrite /= CnatEint cfnorm_ge0 Cint_cfdot_vchar.
Qed.

Fact vchar_mulr_closed : mulr_closed 'Z[irr G].
Proof.
split; first exact: cfun1_vchar.
move=> _ _ /vcharP[xi1 Nxi1 [xi2 Nxi2 ->]] /vcharP[xi3 Nxi3 [xi4 Nxi4 ->]].
by rewrite mulrBl !mulrBr !(rpredB, rpredD) // char_vchar ?rpredM.
Qed.
Canonical vchar_mulrPred := MulrPred vchar_mulr_closed.
Canonical vchar_smulrPred := SmulrPred vchar_mulr_closed.
Canonical vchar_semiringPred := SemiringPred vchar_mulr_closed.
Canonical vchar_subringPred := SubringPred vchar_mulr_closed.

Lemma mul_vchar A :
  {in 'Z[irr G, A] &, forall phi psi, phi * psi \in 'Z[irr G, A]}.
Proof.
move=> phi psi; rewrite zchar_split => /andP[Zphi Aphi] /zcharW Zpsi.
rewrite zchar_split rpredM //; apply/cfun_onP=> x A'x.
by rewrite cfunE (cfun_onP Aphi) ?mul0r.
Qed.

Section CfdotPairwiseOrthogonal.

Variables (M : {group gT}) (S : seq 'CF(G)) (nu : 'CF(G) -> 'CF(M)).
Hypotheses (Inu : {in 'Z[S] &, isometry nu}) (oSS : pairwise_orthogonal S).

Let freeS := orthogonal_free oSS.
Let uniqS : uniq S := free_uniq freeS.
Let Z_S : {subset S <= 'Z[S]}. Proof. by move=> phi; apply: mem_zchar. Qed.
Let notS0 : 0 \notin S. Proof. by case/andP: oSS. Qed.
Let dotSS := proj2 (pairwise_orthogonalP oSS).

Lemma map_pairwise_orthogonal : pairwise_orthogonal (map nu S).
Proof.
have inj_nu: {in S &, injective nu}.
  move=> phi psi Sphi Spsi /= eq_nu; apply: contraNeq (memPn notS0 _ Sphi).
  by rewrite -cfnorm_eq0 -Inu ?Z_S // {2}eq_nu Inu ?Z_S // => /dotSS->.
have notSnu0: 0 \notin map nu S.
  apply: contra notS0 => /mapP[phi Sphi /esym/eqP].
  by rewrite -cfnorm_eq0 Inu ?Z_S // cfnorm_eq0 => /eqP <-.
apply/pairwise_orthogonalP; split; first by rewrite /= notSnu0 map_inj_in_uniq.
move=> _ _ /mapP[phi Sphi ->] /mapP[psi Spsi ->].
by rewrite (inj_in_eq inj_nu) // Inu ?Z_S //; apply: dotSS.
Qed.

Lemma cfproj_sum_orthogonal P z phi :
    phi \in S ->
  '[\sum_(xi <- S | P xi) z xi *: nu xi, nu phi]
    = if P phi then z phi * '[phi] else 0.
Proof.
move=> Sphi; have defS := perm_to_rem Sphi.
rewrite cfdot_suml (perm_big _ defS) big_cons /= cfdotZl Inu ?Z_S //.
rewrite big1_seq ?addr0 // => xi; rewrite mem_rem_uniq ?inE //.
by case/and3P=> _ neq_xi Sxi; rewrite cfdotZl Inu ?Z_S // dotSS ?mulr0.
Qed.

Lemma cfdot_sum_orthogonal z1 z2 :
  '[\sum_(xi <- S) z1 xi *: nu xi, \sum_(xi <- S) z2 xi *: nu xi]
    = \sum_(xi <- S) z1 xi * (z2 xi)^* * '[xi].
Proof.
rewrite cfdot_sumr; apply: eq_big_seq => phi Sphi.
by rewrite cfdotZr cfproj_sum_orthogonal // mulrCA mulrA.
Qed.

Lemma cfnorm_sum_orthogonal z :
  '[\sum_(xi <- S) z xi *: nu xi] = \sum_(xi <- S) `|z xi| ^+ 2 * '[xi].
Proof.
by rewrite cfdot_sum_orthogonal; apply: eq_bigr => xi _; rewrite normCK.
Qed.

Lemma cfnorm_orthogonal : '[\sum_(xi <- S) nu xi] = \sum_(xi <- S) '[xi].
Proof.
rewrite -(eq_bigr _ (fun _ _ => scale1r _)) cfnorm_sum_orthogonal.
by apply: eq_bigr => xi; rewrite normCK conjC1 !mul1r.
Qed.

End CfdotPairwiseOrthogonal.

Lemma orthogonal_span S phi :
    pairwise_orthogonal S -> phi \in <<S>>%VS ->
  {z | z = fun xi => '[phi, xi] / '[xi] & phi = \sum_(xi <- S) z xi *: xi}.
Proof.
move=> oSS /free_span[|c -> _]; first exact: orthogonal_free.
set z := fun _ => _ : algC; exists z => //; apply: eq_big_seq => u Su.
rewrite /z cfproj_sum_orthogonal // mulfK // cfnorm_eq0.
by rewrite (memPn _ u Su); case/andP: oSS.
Qed.

Section CfDotOrthonormal.

Variables (M : {group gT}) (S : seq 'CF(G)) (nu : 'CF(G) -> 'CF(M)).
Hypotheses (Inu : {in 'Z[S] &, isometry nu}) (onS : orthonormal S).
Let oSS := orthonormal_orthogonal onS.
Let freeS := orthogonal_free oSS.
Let nS1 : {in S, forall phi, '[phi] = 1}.
Proof. by move=> phi Sphi; case/orthonormalP: onS => _ -> //; rewrite eqxx. Qed.

Lemma map_orthonormal : orthonormal (map nu S).
Proof.
rewrite !orthonormalE map_pairwise_orthogonal // andbT.
by apply/allP=> _ /mapP[xi Sxi ->]; rewrite /= Inu ?nS1 // mem_zchar.
Qed.

Lemma cfproj_sum_orthonormal z phi :
  phi \in S -> '[\sum_(xi <- S) z xi *: nu xi, nu phi] = z phi.
Proof. by move=> Sphi; rewrite cfproj_sum_orthogonal // nS1 // mulr1. Qed.

Lemma cfdot_sum_orthonormal z1 z2 :
  '[\sum_(xi <- S) z1 xi *: xi, \sum_(xi <- S) z2 xi *: xi]
     = \sum_(xi <- S) z1 xi * (z2 xi)^*.
Proof.
rewrite cfdot_sum_orthogonal //; apply: eq_big_seq => phi /nS1->.
by rewrite mulr1.
Qed.

Lemma cfnorm_sum_orthonormal z :
  '[\sum_(xi <- S) z xi *: nu xi] = \sum_(xi <- S) `|z xi| ^+ 2.
Proof.
rewrite cfnorm_sum_orthogonal //.
by apply: eq_big_seq => xi /nS1->; rewrite mulr1.
Qed.

Lemma cfnorm_map_orthonormal : '[\sum_(xi <- S) nu xi] = (size S)%:R.
Proof.
by rewrite cfnorm_orthogonal // (eq_big_seq _ nS1) big_tnth sumr_const card_ord.
Qed.

Lemma orthonormal_span phi :
    phi \in <<S>>%VS ->
  {z | z = fun xi => '[phi, xi] & phi = \sum_(xi <- S) z xi *: xi}.
Proof.
case/orthogonal_span=> // _ -> {2}->; set z := fun _ => _ : algC.
by exists z => //; apply: eq_big_seq => xi /nS1->; rewrite divr1.
Qed.

End CfDotOrthonormal.

Lemma cfnorm_orthonormal S :
  orthonormal S -> '[\sum_(xi <- S) xi] = (size S)%:R.
Proof. exact: cfnorm_map_orthonormal. Qed.

Lemma vchar_orthonormalP S :
    {subset S <= 'Z[irr G]} ->
  reflect (exists I : {set Iirr G}, exists b : Iirr G -> bool,
           perm_eq S [seq (-1) ^+ b i *: 'chi_i | i in I])
          (orthonormal S).
Proof.
move=> vcS; apply: (equivP orthonormalP).
split=> [[uniqS oSS] | [I [b defS]]]; last first.
  split=> [|xi1 xi2]; rewrite ?(perm_mem defS).
    rewrite (perm_uniq defS) map_inj_uniq ?enum_uniq // => i j /eqP.
    by rewrite eq_signed_irr => /andP[_ /eqP].
  case/mapP=> [i _ ->] /mapP[j _ ->]; rewrite eq_signed_irr.
  rewrite cfdotZl cfdotZr rmorph_sign mulrA cfdot_irr -signr_addb mulr_natr.
  by rewrite mulrb andbC; case: eqP => //= ->; rewrite addbb eqxx.
pose I := [set i | ('chi_i \in S) || (- 'chi_i \in S)].
pose b i := - 'chi_i \in S; exists I, b.
apply: uniq_perm => // [|xi].
  rewrite map_inj_uniq ?enum_uniq // => i j /eqP.
  by rewrite eq_signed_irr => /andP[_ /eqP].
apply/idP/mapP=> [Sxi | [i Ii ->{xi}]]; last first.
  move: Ii; rewrite mem_enum inE orbC -/(b i).
  by case b_i: (b i); rewrite (scale1r, scaleN1r).
have: '[xi] = 1 by rewrite oSS ?eqxx.
have vc_xi := vcS _ Sxi; rewrite cfdot_sum_irr.
case/Cnat_sum_eq1 => [i _ | i [_ /eqP norm_xi_i xi_i'_0]].
  by rewrite -normCK rpredX // Cnat_norm_Cint ?Cint_cfdot_vchar_irr.
suffices def_xi: xi = (-1) ^+ b i *: 'chi_i.
  exists i; rewrite // mem_enum inE -/(b i) orbC.
  by case: (b i) def_xi Sxi => // ->; rewrite scale1r.
move: Sxi; rewrite [xi]cfun_sum_cfdot (bigD1 i) //.
rewrite big1 //= ?addr0 => [|j ne_ji]; last first.
  apply/eqP; rewrite scaler_eq0 -normr_eq0 -[_ == 0](expf_eq0 _ 2) normCK.
  by rewrite xi_i'_0 ?eqxx.
have:= norm_xi_i; rewrite (aut_Cint _ (Cint_cfdot_vchar_irr _ _)) //.
rewrite -subr_eq0 subr_sqr_1 mulf_eq0 subr_eq0 addr_eq0 /b scaler_sign.
case/pred2P=> ->; last by rewrite scaleN1r => ->.
rewrite scale1r => Sxi; case: ifP => // SNxi.
have:= oSS _ _ Sxi SNxi; rewrite cfdotNr cfdot_irr eqxx; case: eqP => // _.
by move/eqP; rewrite oppr_eq0 oner_eq0.
Qed.

Lemma vchar_norm1P phi :
    phi \in 'Z[irr G] -> '[phi] = 1 ->
  exists b : bool, exists i : Iirr G, phi = (-1) ^+ b *: 'chi_i.
Proof.
move=> Zphi phiN1.
have: orthonormal phi by rewrite /orthonormal/= phiN1 eqxx.
case/vchar_orthonormalP=> [xi /predU1P[->|] // | I [b def_phi]].
have: phi \in (phi : seq _) := mem_head _ _.
by rewrite (perm_mem def_phi) => /mapP[i _ ->]; exists (b i), i.
Qed.

Lemma zchar_small_norm phi n :
    phi \in 'Z[irr G] -> '[phi] = n%:R -> (n < 4)%N ->
  {S : n.-tuple 'CF(G) |
    [/\ orthonormal S, {subset S <= 'Z[irr G]} & phi = \sum_(xi <- S) xi]}.
Proof.
move=> Zphi def_n lt_n_4.
pose S := [seq '[phi, 'chi_i] *: 'chi_i | i in irr_constt phi].
have def_phi: phi = \sum_(xi <- S) xi.
  rewrite big_image big_mkcond {1}[phi]cfun_sum_cfdot.
  by apply: eq_bigr => i _; rewrite if_neg; case: eqP => // ->; rewrite scale0r.
have orthS: orthonormal S.
  apply/orthonormalP; split=> [|_ _ /mapP[i phi_i ->] /mapP[j _ ->]].
    rewrite map_inj_in_uniq ?enum_uniq // => i j; rewrite mem_enum => phi_i _.
    by move/eqP; rewrite eq_scaled_irr (negbTE phi_i) => /andP[_ /= /eqP].
  rewrite eq_scaled_irr cfdotZl cfdotZr cfdot_irr mulrA mulr_natr mulrb.
  rewrite mem_enum in phi_i; rewrite (negbTE phi_i) andbC; case: eqP => // <-.
  have /CnatP[m def_m] := Cnat_norm_Cint (Cint_cfdot_vchar_irr i Zphi).
  apply/eqP; rewrite eqxx /= -normCK def_m -natrX eqr_nat eqn_leq lt0n.
  rewrite expn_eq0 andbT -eqC_nat -def_m normr_eq0 [~~ _]phi_i andbT.
  rewrite (leq_exp2r _ 1) // -ltnS -(@ltn_exp2r _ _ 2) //.
  apply: leq_ltn_trans lt_n_4; rewrite -leC_nat -def_n natrX.
  rewrite cfdot_sum_irr (bigD1 i) //= -normCK def_m addrC -subr_ge0 addrK.
  by rewrite sumr_ge0 // => ? _; apply: mul_conjC_ge0.
have <-: size S = n.
  by apply/eqP; rewrite -eqC_nat -def_n def_phi cfnorm_orthonormal.
exists (in_tuple S); split=> // _ /mapP[i _ ->].
by rewrite scale_zchar ?irr_vchar // Cint_cfdot_vchar_irr.
Qed.

Lemma vchar_norm2 phi :
    phi \in 'Z[irr G, G^#] -> '[phi] = 2 ->
  exists i, exists2 j, j != i & phi = 'chi_i - 'chi_j.
Proof.
rewrite zchar_split cfunD1E => /andP[Zphi phi1_0].
case/zchar_small_norm => // [[[|chi [|xi [|?]]] //= S2]].
case=> /andP[/and3P[Nchi Nxi _] /= ochi] /allP/and3P[Zchi Zxi _].
rewrite big_cons big_seq1 => def_phi.
have [b [i def_chi]] := vchar_norm1P Zchi (eqP Nchi).
have [c [j def_xi]] := vchar_norm1P Zxi (eqP Nxi).
have neq_ji: j != i.
  apply: contraTneq ochi; rewrite !andbT def_chi def_xi => ->.
  rewrite cfdotZl cfdotZr rmorph_sign cfnorm_irr mulr1 -signr_addb.
  by rewrite signr_eq0.
have neq_bc: b != c.
  apply: contraTneq phi1_0; rewrite def_phi def_chi def_xi => ->.
  rewrite -scalerDr !cfunE mulf_eq0 signr_eq0 eq_le lt_geF //.
  by rewrite ltr_paddl ?ltW ?irr1_gt0.
rewrite {}def_phi {}def_chi {}def_xi !scaler_sign.
case: b c neq_bc => [|] [|] // _; last by exists i, j.
by exists j, i; rewrite 1?eq_sym // addrC.
Qed.

End VChar.

Section Isometries.

Variables (gT : finGroupType) (L G : {group gT}) (S : seq 'CF(L)).
Implicit Type nu : {additive 'CF(L) -> 'CF(G)}.

Lemma Zisometry_of_cfnorm (tauS : seq 'CF(G)) :
    pairwise_orthogonal S -> pairwise_orthogonal tauS ->
    map cfnorm tauS = map cfnorm S -> {subset tauS <= 'Z[irr G]} ->
  {tau : {linear 'CF(L) -> 'CF(G)} | map tau S = tauS
       & {in 'Z[S], isometry tau, to 'Z[irr G]}}.
Proof.
move=> oSS oTT /isometry_of_cfnorm[||tau defT Itau] // Z_T; exists tau => //.
split=> [|_ /zchar_nth_expansion[u Zu ->]].
  by apply: sub_in2 Itau; apply: zchar_span.
rewrite big_seq linear_sum rpred_sum // => xi Sxi.
by rewrite linearZ scale_zchar ?Z_T // -defT map_f ?mem_nth.
Qed.

Lemma Zisometry_of_iso f :
    free S -> {in S, isometry f, to 'Z[irr G]} ->
  {tau : {linear 'CF(L) -> 'CF(G)} | {in S, tau =1 f}
       & {in 'Z[S], isometry tau, to 'Z[irr G]}}.
Proof.
move=> freeS [If Zf]; have [tau Dtau Itau] := isometry_of_free freeS If.
exists tau => //; split; first by apply: sub_in2 Itau; apply: zchar_span.
move=> _ /zchar_nth_expansion[a Za ->]; rewrite linear_sum rpred_sum // => i _.
by rewrite linearZ rpredZ_Cint ?Dtau ?Zf ?mem_nth.
Qed.

Lemma Zisometry_inj A nu :
  {in 'Z[S, A] &, isometry nu} -> {in 'Z[S, A] &, injective nu}.
Proof. by move/isometry_raddf_inj; apply; apply: rpredB. Qed.

Lemma isometry_in_zchar nu : {in S &, isometry nu} -> {in 'Z[S] &, isometry nu}.
Proof.
move=> Inu _ _ /zchar_nth_expansion[u Zu ->] /zchar_nth_expansion[v Zv ->].
rewrite !raddf_sum; apply: eq_bigr => j _ /=.
rewrite !cfdot_suml; apply: eq_bigr => i _.
by rewrite !raddfZ_Cint //= !cfdotZl !cfdotZr Inu ?mem_nth.
Qed.

End Isometries.

Section AutVchar.

Variables (u : {rmorphism algC -> algC}) (gT : finGroupType) (G : {group gT}).
Local Notation "alpha ^u" := (cfAut u alpha).
Implicit Type (S : seq 'CF(G)) (phi chi : 'CF(G)).

Lemma cfAut_zchar S A psi :
  cfAut_closed u S -> psi \in 'Z[S, A] -> psi^u \in 'Z[S, A].
Proof.
rewrite zchar_split => SuS /andP[/zchar_nth_expansion[z Zz Dpsi] Apsi].
rewrite zchar_split cfAut_on {}Apsi {psi}Dpsi rmorph_sum rpred_sum //= => i _.
by rewrite cfAutZ_Cint // scale_zchar // mem_zchar ?SuS ?mem_nth.
Qed.

Lemma cfAut_vchar A psi : psi \in 'Z[irr G, A] -> psi^u \in 'Z[irr G, A].
Proof. by apply: cfAut_zchar; apply: irr_aut_closed. Qed.

Lemma sub_aut_zchar S A psi :
   {subset S <= 'Z[irr G]} -> psi \in 'Z[S, A] -> psi^u \in 'Z[S, A] ->
  psi - psi^u \in 'Z[S, A^#].
Proof.
move=> Z_S Spsi Spsi_u; rewrite zcharD1 !cfunE subr_eq0 rpredB //=.
by rewrite aut_Cint // Cint_vchar1 // (zchar_trans Z_S) ?(zcharW Spsi).
Qed.

Lemma conjC_vcharAut chi x : chi \in 'Z[irr G] -> (u (chi x))^* = u (chi x)^*.
Proof.
case/vcharP=> chi1 Nchi1 [chi2 Nchi2 ->].
by rewrite !cfunE !rmorphB !conjC_charAut.
Qed.

Lemma cfdot_aut_vchar phi chi :
  chi \in 'Z[irr G] -> '[phi^u , chi^u] = u '[phi, chi].
Proof.
case/vcharP=> chi1 Nchi1 [chi2 Nchi2 ->].
by rewrite !raddfB /= !cfdot_aut_char.
Qed.

Lemma vchar_aut A chi : (chi^u \in 'Z[irr G, A]) = (chi \in 'Z[irr G, A]).
Proof.
rewrite !(zchar_split _ A) cfAut_on; congr (_ && _).
apply/idP/idP=> [Zuchi|]; last exact: cfAut_vchar.
rewrite [chi]cfun_sum_cfdot rpred_sum // => i _.
rewrite scale_zchar ?irr_vchar //.
by rewrite -(Cint_aut u) -cfdot_aut_irr -aut_IirrE Cint_cfdot_vchar_irr.
Qed.

End AutVchar.

Definition cfConjC_vchar :=  cfAut_vchar conjC.

Section MoreVchar.

Variables (gT : finGroupType) (G H : {group gT}).

Lemma cfRes_vchar phi : phi \in 'Z[irr G] -> 'Res[H] phi \in 'Z[irr H].
Proof.
case/vcharP=> xi1 Nx1 [xi2 Nxi2 ->].
by rewrite raddfB rpredB ?char_vchar ?cfRes_char.
Qed.

Lemma cfRes_vchar_on A phi :
  H \subset G -> phi \in 'Z[irr G, A] -> 'Res[H] phi \in 'Z[irr H, A].
Proof.
rewrite zchar_split => sHG /andP[Zphi Aphi]; rewrite zchar_split cfRes_vchar //.
apply/cfun_onP=> x /(cfun_onP Aphi); rewrite !cfunElock !genGid sHG => ->.
exact: mul0rn.
Qed.

Lemma cfInd_vchar phi : phi \in 'Z[irr H] -> 'Ind[G] phi \in 'Z[irr G].
Proof.
move=> /vcharP[xi1 Nx1 [xi2 Nxi2 ->]].
by rewrite raddfB rpredB ?char_vchar ?cfInd_char.
Qed.

Lemma sub_conjC_vchar A phi :
  phi \in 'Z[irr G, A] -> phi - (phi^*)%CF \in 'Z[irr G, A^#].
Proof.
move=> Zphi; rewrite sub_aut_zchar ?cfAut_zchar // => _ /irrP[i ->].
  exact: irr_vchar.
exact: cfConjC_irr.
Qed.

Lemma Frobenius_kernel_exists :
  [Frobenius G with complement H] -> {K : {group gT} | [Frobenius G = K ><| H]}.
Proof.
move=> frobG; have [_ ntiHG] := andP frobG.
have [[_ sHG regGH][_ tiHG /eqP defNH]] := (normedTI_memJ_P ntiHG, and3P ntiHG).
suffices /sigW[K defG]: exists K, gval K ><| H == G by exists K; apply/andP.
pose K1 := G :\: cover (H^# :^: G).
have oK1: #|K1| = #|G : H|.
  rewrite cardsD (setIidPr _); last first.
    rewrite cover_imset; apply/bigcupsP=> x Gx.
    by rewrite sub_conjg conjGid ?groupV // (subset_trans (subsetDl _ _)).
  rewrite (cover_partition (partition_normedTI ntiHG)) -(Lagrange sHG).
  by rewrite (card_support_normedTI ntiHG) (cardsD1 1%g) group1 mulSn addnK.
suffices extG i: {j | {in H, 'chi[G]_j =1 'chi[H]_i} & K1 \subset cfker 'chi_j}.
  pose K := [group of \bigcap_i cfker 'chi_(s2val (extG i))].
  have nKH: H \subset 'N(K).
    by apply/norms_bigcap/bigcapsP=> i _; apply: subset_trans (cfker_norm _).
  have tiKH: K :&: H = 1%g.
    apply/trivgP; rewrite -(TI_cfker_irr H) /= setIC; apply/bigcapsP=> i _.
    apply/subsetP=> x /setIP[Hx /bigcapP/(_ i isT)/=]; rewrite !cfkerEirr !inE.
    by case: (extG i) => /= j def_j _; rewrite !def_j.
  exists K; rewrite sdprodE // eqEcard TI_cardMg // mul_subG //=; last first.
    by rewrite (bigcap_min (0 : Iirr H)) ?cfker_sub.
  rewrite -(Lagrange sHG) mulnC leq_pmul2r // -oK1 subset_leq_card //.
  by apply/bigcapsP=> i _; case: (extG i).
case i0: (i == 0).
  exists 0 => [x Hx|]; last by rewrite irr0 cfker_cfun1 subsetDl.
  by rewrite (eqP i0) !irr0 !cfun1E // (subsetP sHG) ?Hx.
have ochi1: '['chi_i, 1] = 0 by rewrite -irr0 cfdot_irr i0.
pose a := 'chi_i 1%g; have Za: a \in Cint by rewrite CintE Cnat_irr1.
pose theta := 'chi_i - a%:A; pose phi := 'Ind[G] theta + a%:A.
have /cfun_onP theta0: theta \in 'CF(H, H^#).
  by rewrite cfunD1E !cfunE cfun11 mulr1 subrr.
have RItheta: 'Res ('Ind[G] theta) = theta.
  apply/cfun_inP=> x Hx; rewrite cfResE ?cfIndE // (big_setID H) /= addrC.
  apply: canLR (mulKf (neq0CG H)) _; rewrite (setIidPr sHG) mulr_natl.
  rewrite big1 ?add0r => [|y /setDP[/regGH tiHy H'y]]; last first.
    have [-> | ntx] := eqVneq x 1%g; first by rewrite conj1g theta0 ?inE ?eqxx.
    by rewrite theta0 ?tiHy // !inE ntx.
  by rewrite -sumr_const; apply: eq_bigr => y Hy; rewrite cfunJ.
have ophi1: '[phi, 1] = 0.
  rewrite cfdotDl -cfdot_Res_r cfRes_cfun1 // cfdotBl !cfdotZl !cfnorm1.
  by rewrite ochi1 add0r addNr.
have{ochi1} n1phi: '[phi] = 1.
  have: '[phi - a%:A] = '[theta] by rewrite addrK -cfdot_Res_l RItheta.
  rewrite !cfnormBd ?cfnormZ ?cfdotZr ?ophi1 ?ochi1 ?mulr0 //.
  by rewrite !cfnorm1 cfnorm_irr => /addIr.
have Zphi: phi \in 'Z[irr G].
  by rewrite rpredD ?cfInd_vchar ?rpredB ?irr_vchar // scale_zchar ?rpred1.
have def_phi: {in H, phi =1 'chi_i}.
  move=> x Hx /=; rewrite !cfunE -[_ x](cfResE _ sHG) ?RItheta //.
  by rewrite !cfunE !cfun1E ?(subsetP sHG) ?Hx ?subrK.
have [j def_chi_j]: {j | 'chi_j = phi}.
  apply/sig_eqW; have [[] [j]] := vchar_norm1P Zphi n1phi; last first.
    by rewrite scale1r; exists j.
  move/cfunP/(_ 1%g)/eqP; rewrite scaleN1r def_phi // cfunE -addr_eq0 eq_le.
  by rewrite lt_geF // ltr_paddl ?ltW ?irr1_gt0.
exists j; rewrite ?cfkerEirr def_chi_j //; apply/subsetP => x /setDP[Gx notHx].
rewrite inE cfunE def_phi // cfunE -/a cfun1E // Gx mulr1 cfIndE //.
rewrite big1 ?mulr0 ?add0r // => y Gy; apply/theta0/(contra _ notHx) => Hxy.
by rewrite -(conjgK y x) cover_imset -class_supportEr imset2_f ?groupV.
Qed.

End MoreVchar.

Definition dirr (gT : finGroupType) (B : {set gT}) : {pred 'CF(B)} :=
  [pred f | (f \in irr B) || (- f \in irr B)].
Arguments dirr {gT}.

Section Norm1vchar.

Variables (gT : finGroupType) (G : {group gT}).

Fact dirr_key : pred_key (dirr G). Proof. by []. Qed.
Canonical dirr_keyed := KeyedPred dirr_key.

Fact dirr_oppr_closed : oppr_closed (dirr G).
Proof. by move=> xi; rewrite !inE opprK orbC. Qed.
Canonical dirr_opprPred := OpprPred dirr_oppr_closed.

Lemma dirr_opp v : (- v \in dirr G) = (v \in dirr G). Proof. exact: rpredN. Qed.
Lemma dirr_sign n v : ((-1)^+ n *: v \in dirr G) = (v \in dirr G).
Proof. exact: rpredZsign. Qed.

Lemma irr_dirr i : 'chi_i \in dirr G.
Proof. by rewrite !inE mem_irr. Qed.

Lemma dirrP f :
  reflect (exists b : bool, exists i, f = (-1) ^+ b *: 'chi_i) (f \in dirr G).
Proof.
apply: (iffP idP) => [| [b [i ->]]]; last by rewrite dirr_sign irr_dirr.
case/orP=> /irrP[i Hf]; first by exists false, i; rewrite scale1r.
by exists true, i; rewrite scaleN1r -Hf opprK.
Qed.

(* This should perhaps be the definition of dirr. *)
Lemma dirrE phi : phi \in dirr G = (phi \in 'Z[irr G]) && ('[phi] == 1).
Proof.
apply/dirrP/andP=> [[b [i ->]] | [Zphi /eqP/vchar_norm1P]]; last exact.
by rewrite rpredZsign irr_vchar cfnorm_sign cfnorm_irr.
Qed.

Lemma cfdot_dirr f g : f \in dirr G -> g \in dirr G ->
  '[f, g] = (if f == - g then -1 else (f == g)%:R).
Proof.
case/dirrP=> [b1 [i1 ->]] /dirrP[b2 [i2 ->]].
rewrite cfdotZl cfdotZr rmorph_sign mulrA -signr_addb cfdot_irr.
rewrite -scaleNr -signrN !eq_scaled_irr signr_eq0 !(inj_eq signr_inj) /=.
by rewrite -!negb_add addbN mulr_sign -mulNrn mulrb; case: ifP.
Qed.

Lemma dirr_norm1 phi : phi \in 'Z[irr G] -> '[phi] = 1 -> phi \in dirr G.
Proof. by rewrite dirrE => -> -> /=. Qed.

Lemma dirr_aut u phi : (cfAut u phi \in dirr G) = (phi \in dirr G).
Proof.
rewrite !dirrE vchar_aut; apply: andb_id2l => /cfdot_aut_vchar->.
exact: fmorph_eq1.
Qed.

Definition dIirr (B : {set gT}) := (bool * (Iirr B))%type.

Definition dirr1 (B : {set gT}) : dIirr B := (false, 0).

Definition ndirr (B : {set gT}) (i : dIirr B) : dIirr B :=
  (~~ i.1, i.2).

Lemma ndirr_diff (i : dIirr G) : ndirr i != i.
Proof. by case: i => [] [|] i. Qed.

Lemma ndirrK : involutive (@ndirr G).
Proof. by move=> [b i]; rewrite /ndirr /= negbK. Qed.

Lemma ndirr_inj : injective (@ndirr G).
Proof. exact: (inv_inj ndirrK). Qed.

Definition dchi (B : {set gT}) (i : dIirr B) : 'CF(B) :=
  (-1)^+ i.1 *: 'chi_i.2.

Lemma dchi1 : dchi (dirr1 G) = 1.
Proof. by rewrite /dchi scale1r irr0. Qed.

Lemma dirr_dchi i : dchi i \in dirr G.
Proof. by apply/dirrP; exists i.1; exists i.2. Qed.

Lemma dIrrP phi : reflect (exists i, phi = dchi i) (phi \in dirr G).
Proof.
by apply: (iffP idP)=> [/dirrP[b]|] [i ->]; [exists (b, i) | apply: dirr_dchi].
Qed.

Lemma dchi_ndirrE (i : dIirr G) : dchi (ndirr i) = - dchi i.
Proof. by case: i => [b i]; rewrite /ndirr /dchi signrN scaleNr. Qed.

Lemma cfdot_dchi (i j : dIirr G) :
  '[dchi i, dchi j] = (i == j)%:R - (i == ndirr j)%:R.
Proof.
case: i => bi i; case: j => bj j; rewrite cfdot_dirr ?dirr_dchi // !xpair_eqE.
rewrite -dchi_ndirrE !eq_scaled_irr signr_eq0 !(inj_eq signr_inj) /=.
by rewrite -!negb_add addbN negbK; case: andP => [[->]|]; rewrite ?subr0 ?add0r.
Qed.

Lemma dchi_vchar i : dchi i \in 'Z[irr G].
Proof. by case: i => b i; rewrite rpredZsign irr_vchar. Qed.

Lemma cfnorm_dchi (i : dIirr G) : '[dchi i] = 1.
Proof.  by case: i => b i; rewrite cfnorm_sign cfnorm_irr. Qed.

Lemma dirr_inj : injective (@dchi G).
Proof.
case=> b1 i1 [b2 i2] /eqP; rewrite eq_scaled_irr (inj_eq signr_inj) /=.
by rewrite signr_eq0 -xpair_eqE => /eqP.
Qed.

Definition dirr_dIirr (B : {set gT}) J (f : J -> 'CF(B)) j : dIirr B :=
  odflt (dirr1 B) [pick i | dchi i == f j].

Lemma dirr_dIirrPE J (f : J -> 'CF(G)) (P : pred J) :
    (forall j, P j -> f j \in dirr G) ->
  forall j, P j -> dchi (dirr_dIirr f j) = f j.
Proof.
rewrite /dirr_dIirr => dirrGf j Pj; case: pickP => [i /eqP //|].
by have /dIrrP[i-> /(_ i)/eqP] := dirrGf j Pj.
Qed.

Lemma dirr_dIirrE J (f : J -> 'CF(G)) :
  (forall j, f j \in dirr G) -> forall j, dchi (dirr_dIirr f j) = f j.
Proof. by move=> dirrGf j; apply: (@dirr_dIirrPE _ _ xpredT). Qed.

Definition dirr_constt (B : {set gT}) (phi: 'CF(B)) : {set (dIirr B)} :=
  [set i | 0 < '[phi, dchi i]].

Lemma dirr_consttE (phi : 'CF(G)) (i : dIirr G) :
  (i \in dirr_constt phi) = (0 < '[phi, dchi i]).
Proof. by rewrite inE. Qed.

Lemma Cnat_dirr (phi : 'CF(G)) i :
  phi \in 'Z[irr G] -> i \in dirr_constt phi -> '[phi, dchi i] \in Cnat.
Proof.
move=> PiZ; rewrite CnatEint dirr_consttE andbC => /ltW -> /=.
by case: i => b i; rewrite cfdotZr rmorph_sign rpredMsign Cint_cfdot_vchar_irr.
Qed.

Lemma dirr_constt_oppr (i : dIirr G) (phi : 'CF(G)) :
  (i \in dirr_constt (-phi)) = (ndirr i \in dirr_constt phi).
Proof. by rewrite !dirr_consttE dchi_ndirrE cfdotNl cfdotNr. Qed.

Lemma dirr_constt_oppI (phi: 'CF(G)) :
   dirr_constt phi :&: dirr_constt (-phi) = set0.
Proof.
apply/setP=> i; rewrite inE !dirr_consttE cfdotNl inE.
apply/idP=> /andP [L1 L2]; have := ltr_paddl (ltW L1) L2.
by rewrite subrr lt_def eqxx.
Qed.

Lemma dirr_constt_oppl (phi: 'CF(G)) i :
  i \in dirr_constt phi -> (ndirr i) \notin dirr_constt phi.
Proof.
by rewrite !dirr_consttE dchi_ndirrE cfdotNr oppr_gt0 => /ltW /le_gtF ->.
Qed.

Definition to_dirr  (B : {set gT}) (phi : 'CF(B)) (i : Iirr B) : dIirr B :=
  ('[phi, 'chi_i] < 0, i).

Definition of_irr (B : {set gT}) (i : dIirr B) : Iirr B := i.2.

Lemma irr_constt_to_dirr (phi: 'CF(G)) i : phi \in 'Z[irr G] ->
  (i \in irr_constt phi) = (to_dirr phi i \in dirr_constt phi).
Proof.
move=> Zphi; rewrite irr_consttE dirr_consttE cfdotZr rmorph_sign /=.
by rewrite -real_normrEsign ?normr_gt0 ?Creal_Cint // Cint_cfdot_vchar_irr.
Qed.

Lemma to_dirrK (phi: 'CF(G)) : cancel (to_dirr phi) (@of_irr G).
Proof. by []. Qed.

Lemma of_irrK (phi: 'CF(G)) :
  {in dirr_constt phi, cancel (@of_irr G) (to_dirr phi)}.
Proof.
case=> b i; rewrite dirr_consttE cfdotZr rmorph_sign /= /to_dirr mulr_sign.
by rewrite fun_if oppr_gt0; case: b => [|/ltW/le_gtF] ->.
Qed.

Lemma cfdot_todirrE (phi: 'CF(G)) i (phi_i := dchi (to_dirr phi i)) :
  '[phi, phi_i] *: phi_i = '[phi, 'chi_i] *: 'chi_i.
Proof. by rewrite cfdotZr rmorph_sign mulrC -scalerA signrZK. Qed.

Lemma cfun_sum_dconstt (phi : 'CF(G)) :
    phi \in 'Z[irr G] ->
  phi = \sum_(i in dirr_constt phi) '[phi, dchi i] *: dchi i.
Proof.
move=> PiZ; rewrite [LHS]cfun_sum_constt.
rewrite (reindex (to_dirr phi))=> [/= |]; last first.
  by exists (@of_irr _)=> //; apply: of_irrK .
by apply: eq_big => i; rewrite ?irr_constt_to_dirr // cfdot_todirrE.
Qed.

Lemma cnorm_dconstt (phi : 'CF(G)) :
  phi \in 'Z[irr G] ->
  '[phi] = \sum_(i in dirr_constt phi) '[phi, dchi i] ^+ 2.
Proof.
move=> PiZ; rewrite {1 2}(cfun_sum_dconstt PiZ).
rewrite cfdot_suml; apply: eq_bigr=> i IiD.
rewrite cfdot_sumr (bigD1 i) //= big1 ?addr0 => [|j /andP [JiD IdJ]].
  rewrite cfdotZr cfdotZl cfdot_dchi eqxx eq_sym (negPf (ndirr_diff i)).
  by rewrite subr0 mulr1 aut_Cnat ?Cnat_dirr.
rewrite cfdotZr cfdotZl cfdot_dchi eq_sym (negPf IdJ) -natrB ?mulr0 //.
by rewrite (negPf (contraNneq _ (dirr_constt_oppl JiD))) => // <-.
Qed.

Lemma dirr_small_norm (phi : 'CF(G)) n :
  phi \in 'Z[irr G] -> '[phi] = n%:R -> (n < 4)%N ->
  [/\ #|dirr_constt phi| = n, dirr_constt phi :&: dirr_constt (- phi) = set0 &
      phi = \sum_(i in dirr_constt phi) dchi i].
Proof.
move=> PiZ Pln; rewrite ltnNge -leC_nat => Nl4.
suffices Fd i: i \in dirr_constt phi -> '[phi, dchi i] = 1.
  split; last 2 [by apply/setP=> u; rewrite !inE cfdotNl oppr_gt0 lt_asym].
    apply/eqP; rewrite -eqC_nat -sumr_const -Pln (cnorm_dconstt PiZ).
    by apply/eqP/eq_bigr=> i Hi; rewrite Fd // expr1n.
  rewrite {1}[phi]cfun_sum_dconstt //.
  by apply: eq_bigr => i /Fd->; rewrite scale1r.
move=> IiD; apply: contraNeq Nl4 => phi_i_neq1.
rewrite -Pln cnorm_dconstt // (bigD1 i) ?ler_paddr ?sumr_ge0 //=.
  by move=> j /andP[JiD _]; rewrite exprn_ge0 ?Cnat_ge0 ?Cnat_dirr.
have /CnatP[m Dm] := Cnat_dirr PiZ IiD; rewrite Dm -natrX ler_nat (leq_sqr 2).
by rewrite ltn_neqAle eq_sym -eqC_nat -ltC_nat -Dm phi_i_neq1 -dirr_consttE.
Qed.

Lemma cfdot_sum_dchi (phi1 phi2 : 'CF(G)) :
  '[\sum_(i in dirr_constt phi1) dchi i,
    \sum_(i in dirr_constt phi2) dchi i] =
  #|dirr_constt phi1 :&: dirr_constt phi2|%:R -
    #|dirr_constt phi1 :&: dirr_constt (- phi2)|%:R.
Proof.
rewrite addrC (big_setID (dirr_constt (- phi2))) /= cfdotDl; congr (_ + _).
  rewrite cfdot_suml -sumr_const -sumrN; apply: eq_bigr => i /setIP[p1i p2i].
  rewrite cfdot_sumr (bigD1 (ndirr i)) -?dirr_constt_oppr //= dchi_ndirrE.
  rewrite cfdotNr cfnorm_dchi big1 ?addr0 // => j /andP[p2j i'j].
  rewrite cfdot_dchi -(inv_eq ndirrK) [in rhs in - rhs]eq_sym (negPf i'j) subr0.
  rewrite (negPf (contraTneq _ p2i)) // => ->.
  by rewrite dirr_constt_oppr dirr_constt_oppl.
rewrite cfdot_sumr (big_setID (dirr_constt phi1)) setIC /= addrC.
rewrite big1 ?add0r => [|j /setDP[p2j p1'j]]; last first.
  rewrite cfdot_suml big1 // => i /setDP[p1i p2'i].
  rewrite cfdot_dchi (negPf (contraTneq _ p1i)) => [|-> //].
  rewrite (negPf (contraNneq _ p2'i)) ?subrr // => ->.
  by rewrite dirr_constt_oppr ndirrK.
rewrite -sumr_const; apply: eq_bigr => i /setIP[p1i p2i]; rewrite cfdot_suml.
rewrite (bigD1 i) /=; last by rewrite inE dirr_constt_oppr dirr_constt_oppl.
rewrite cfnorm_dchi big1 ?addr0 // => j /andP[/setDP[p1j _] i'j].
rewrite cfdot_dchi (negPf i'j) (negPf (contraTneq _ p1j)) ?subrr // => ->.
exact: dirr_constt_oppl.
Qed.

Lemma cfdot_dirr_eq1 :
  {in dirr G &, forall phi psi, ('[phi, psi] == 1) = (phi == psi)}.
Proof.
move=> _ _ /dirrP[b1 [i1 ->]] /dirrP[b2 [i2 ->]].
rewrite eq_signed_irr cfdotZl cfdotZr rmorph_sign cfdot_irr mulrA -signr_addb.
rewrite pmulrn -rmorphMsign (eqr_int _ _ 1) -negb_add.
by case: (b1 (+) b2) (i1 == i2) => [] [].
Qed.

Lemma cfdot_add_dirr_eq1 :
  {in dirr G & &, forall phi1 phi2 psi,
    '[phi1 + phi2, psi] = 1 -> psi = phi1 \/ psi = phi2}.
Proof.
move=> _ _ _ /dirrP[b1 [i1 ->]] /dirrP[b2 [i2 ->]] /dirrP[c [j ->]] /eqP.
rewrite cfdotDl !cfdotZl !cfdotZr !rmorph_sign !cfdot_irr !mulrA -!signr_addb.
rewrite 2!{1}signrE !mulrBl !mul1r -!natrM addrCA -subr_eq0 -!addrA.
rewrite -!opprD addrA subr_eq0 -mulrSr -!natrD eqr_nat => eq_phi_psi.
apply/pred2P; rewrite /= !eq_signed_irr -!negb_add !(eq_sym j) !(addbC c).
by case: (i1 == j) eq_phi_psi; case: (i2 == j); do 2!case: (_ (+) c).
Qed.

End Norm1vchar.

Prenex Implicits ndirr ndirrK to_dirr to_dirrK of_irr.
Arguments of_irrK {gT G phi} [i] phi_i : rename.