Require Import ZArith.
Require Import List. Import ListNotations.
Require Import MSetPositive.

From QuickChick.ifcbasic Require Export Rules Instructions.

Open Scope Z_scope.
Open Scope bool_scope.

(** * Basic List manipulation *)

(* [nth l n] returns the [n]th element of [l] if [0 <= n < Zlength l] *)
Definition nth {A:Type} (l:list A) (n:Z) : option A :=
  if Z_lt_dec n 0 then None
  else nth_error l (Z.to_nat n).

(* [upd_nat l n a] returns a list [l'] that is pointwise equal to [l], except the [n]th
    element that is now [a]. Only suceeds if [n < length l] *)
Fixpoint upd_nat {A:Type} (l:list A) (n:nat) (a:A) : option (list A) :=
  match l with
    | nil => None
    | x::q =>
      match n with
        | O => Some (a::q)
        | S p =>
          match upd_nat q p a with
            | None => None
            | Some q' => Some (x::q')
          end
      end
  end.

(* [upd l n a] returns a list [l'] that is pointwise equal to [l], except the [n]th
    element that is now [a]. Only suceeds if [0 <= n < Zlength l] *)
Definition upd {A:Type} (l:list A) (n:Z) (a:A) : option (list A) :=
  if Z_lt_dec n 0 then None
  else upd_nat l (Z.to_nat n) a.

Fixpoint replicate {A:Type} (n:nat) (a:A) : list A :=
  match n with
  | O => nil
  | S n' => a :: replicate n' a
  end.

Definition zreplicate {A:Type} (n:Z) (a:A) : option (list A) :=
  if Z_lt_dec n 0 then None
  else Some (replicate (Z.to_nat n) a).

(** * Machine definition *)

Inductive Atom : Type := Atm (x:Z) (l:Label).
Infix "@" := Atm (no associativity, at level 50).

Definition pc_lab (pc : Atom) : Label :=
  let (_,l) := pc in l.
Notation "'∂' pc" := (pc_lab pc) (at level 0).

Inductive Stack :=
  | Mty                         (* empty stack *)
  | Cons (a:Atom) (s:Stack)     (* stack atom cons *)
  | RetCons (pc:Atom) (s:Stack) (* stack frame marker cons *)
.
Infix "::"  := Cons (at level 60, right associativity).
Infix ":::" := RetCons (at level 60, right associativity).

Fixpoint app_stack (l:list Atom) (s:Stack) : Stack :=
  match l with
    | nil => s
    | cons a q => a::(app_stack q s)
  end.
Infix "$" := app_stack (at level 60, right associativity).

Definition IMem := list Instruction.
Definition Mem  := list Atom.
Record State := St {
  st_imem  : IMem ; (* instruction memory *)
  st_mem   : Mem  ; (* memory *)
  st_stack : Stack; (* operand stack *)
  st_pc    : Atom   (* program counter *)
}.

Definition labelCount (c:OpCode) : nat :=
  match c with
  | OpBCall   => 1
  | OpBRet    => 2
  | OpNop     => 0
  | OpPush    => 0
  | OpAdd     => 2
  | OpLoad    => 2
  | OpStore   => 3
end%nat.

Definition table := forall op, AllowModify (labelCount op).

Definition default_table : table := fun op =>
  match op with
  | OpBCall   =>  ≪ TRUE , LabPC , JOIN Lab1 LabPC≫
  | OpBRet    =>  ≪ TRUE , JOIN Lab2 LabPC , Lab1 ≫
  | OpNop     =>  ≪ TRUE , __ , LabPC ≫
  | OpPush    =>  ≪ TRUE , BOT , LabPC ≫
  | OpAdd     =>  ≪ TRUE , JOIN Lab1 Lab2, LabPC ≫
  | OpLoad    =>  ≪ TRUE , JOIN Lab1 Lab2 , LabPC ≫
  | OpStore   =>  ≪ LE (JOIN Lab1 LabPC) Lab3, JOIN LabPC (JOIN Lab1 Lab2) , LabPC ≫
end.

Definition run_tmr (t : table) (op: OpCode)
  (labs:Vector.t Label (labelCount op)) (pc: Label)
   : option (option Label * Label) :=
  let r := t op in
  apply_rule r labs pc.

Definition bind (A B:Type) (f:A->option B) (a:option A) : option B :=
    match a with
      | None => None
      | Some a => f a
    end.
Notation "'do' X <- A ; B" := (bind _ _ (fun X => B) A)
                    (at level 200, X ident, A at level 100, B at level 200).
Notation "'do' X : T <- A ; B" := (bind _ _ (fun X : T => B) A)
                    (at level 200, X ident, A at level 100, B at level 200).

Fixpoint insert_nat (s:Stack) (n:nat) (a:Atom) : option Stack :=
  match n,s with
    | O, _ => Some (a:::s)
    | S n', x :: xs =>
      do s' <- insert_nat xs n' a;
      Some (x :: s')
    | _, _ => None
  end.

Fixpoint findRet (s:Stack) : option (Atom * Stack) :=
  match s with
    | x ::: s' => Some (x,s')
    | x :: s'  => findRet s'
    | Mty      => None
  end.

Definition insert (s:Stack) (n:Z) (a:Atom) : option Stack :=
  if Z_lt_dec n 0 then None
  else insert_nat s (Z.to_nat n) a.

Definition lookupInstr (st : State) : option Instruction :=
  let '(St μ _ _ (pc@_)) := st in nth μ pc.

Definition exec (t : table) (st:State) : option State :=
  do instr <- lookupInstr st;
  match instr, st with
    | BCall n, St μ m (x @ l :: σ) (xpc@lpc) =>
      match run_tmr t OpBCall <|l|> lpc with
        | Some (Some rl, rpcl) =>
          let pc' := x @ rpcl in
          let ret_pc := (xpc + 1 @ rl) in
          do σ' <- insert σ n ret_pc;
          Some (St μ m σ' pc')
        | _ => None
      end
    | BRet, St μ m ((ax@al)::σ) (xpc@lpc) =>
      do tmp <- findRet σ;
      let '(xrpc @ lrpc, σ') := tmp in
      match run_tmr t OpBRet <|lrpc; al|> lpc with
        | Some (Some rl, rpcl) =>
          let pc' := xrpc @ rpcl in
          Some (St μ m ((ax@rl)::σ') pc')
        | _ => None
      end
    | Load, St μ m ((x @ l) :: σ) (xpc@lpc) =>
     do a <- nth m x;
     let '(ax @ al) := a in
     match run_tmr t OpLoad <|al; l|> lpc with
       | Some (Some rl, rpcl) =>
         Some (St μ m ((ax @ rl)::σ) ((xpc+1) @ rpcl))
       | _ => None
     end
    | Store, St μ m ((x @ lx) :: (a@la) :: σ) (xpc@lpc) =>
      do inMem <- nth m x;
      match run_tmr t OpStore <|lx; la; ∂inMem|> lpc with
        | Some (Some rl, rpcl) =>
          do m' <- upd m x (a@rl);
          Some (St μ m' σ ((xpc+1)@rpcl))
        | _ => None
      end
    | Push r, St μ m σ (xpc@lpc) =>
      match run_tmr t OpPush <||> lpc with
        | Some (Some rl, rpcl) =>
          Some (St μ m ((r@rl)::σ) ((xpc+1)@rpcl))
        | _ => None
      end
    | Nop, St μ m σ (xpc@lpc) =>
      match run_tmr t OpNop <||> lpc with
        | Some (_, rpcl) =>
          Some (St μ m σ ((xpc+1)@rpcl))
        | _ => None
      end
    | Add, St μ m ((x @ lx) :: (y @ ly) :: σ) (xpc@lpc) =>
      match run_tmr t OpAdd <|lx ; ly|> lpc with
      | Some (Some rl, rpcl) =>
        Some (St μ m (((x + y) @ rl) :: σ) ((xpc+1)@rpcl))
      | _ => None
      end
    | _,_ => None
  end.

Fixpoint execN (t : table) (n : nat) (s : State) : list State :=
  match n with
    | O => [s]
    | S n' =>
      match exec t s with
        | Some s' => s :: execN t n' s'
        | None => s :: nil
      end
  end%list.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                               safe_card.v                                *)
(****************************************************************************)

Section safe_card.

Require Export white_card.
Require Export black_card.
Require Export grey_card.
Require Export mesure.
Require Export safety.

Notation Step := (step (fun (a : label) (s t : state) => transition s t a))
  (only parsing).
Notation Safe :=
  (safe init_state (fun (a : label) (s t : state) => transition s t a))
  (only parsing).
Notation Invariant :=
  (invariant (fun (a : label) (s t : state) => transition s t a))
  (only parsing).
Notation Stream := (stream state) (only parsing).
Notation Run :=
  (run init_state (fun (a : label) (s t : state) => transition s t a))
  (only parsing).
Notation State_formula := (state_formula state) (only parsing).
Notation Stream_formula := (stream_formula state) (only parsing).

Lemma step_black_card :
 forall s t : state,
 (exists b : nat, card_color black (mk s) b) ->
 step (fun (a : label) (s t : state) => transition s t a) s t ->
 exists b : nat, card_color black (mk t) b.

unfold invariant in |- *; unfold leads_to in |- *.
intros s t H_s step.
elim step.
intro a; case a; intro trans; inversion_clear trans; eauto.
Qed.

Hint Resolve step_black_card.

Lemma inv_black_card :
 invariant (fun (a : label) (s t : state) => transition s t a)
   (fun s : state => exists b : nat, card_color black (mk s) b).

unfold invariant in |- *; unfold leads_to in |- *; eauto.
Qed.

Hint Resolve inv_black_card.

Lemma safe_card_black :
 safe init_state (fun (a : label) (s t : state) => transition s t a)
   (state2stream_formula
      (fun s : state => exists b : nat, card_color black (mk s) b)).

apply safety; eauto.
Qed.

Hint Resolve safe_card_black.

Lemma always_card_black :
 forall str : stream state,
 run init_state (fun (a : label) (s t : state) => transition s t a) str ->
 always
   (state2stream_formula
      (fun s : state => exists b : nat, card_color black (mk s) b)) str.

intros str H_run.
cut
 (safe init_state (fun (a : label) (s t : state) => transition s t a)
    (state2stream_formula
       (fun s : state => exists b : nat, card_color black (mk s) b)));
 eauto.
Qed.

Hint Resolve always_card_black.

Lemma step_white_card :
 forall s t : state,
 rt_grey_or_black s ->
 (exists b : nat, card_color black (mk s) b) ->
 (exists w : nat, card_color white (mk s) w) ->
 step (fun (a : label) (s t : state) => transition s t a) s t ->
 exists w : nat, card_color white (mk t) w.

unfold invariant in |- *; unfold leads_to in |- *.
intros s t safety_prop cardb_s cardw_s step.
elim step.
intro a; case a; intro trans; inversion_clear trans; eauto.
Qed.

Hint Resolve step_white_card.

Definition conj_inv : state_formula state :=
  fun s =>
  (exists w : nat, card_color white (mk s) w) /\
  (exists b : nat, card_color black (mk s) b) /\ rt_grey_or_black s.

Lemma init_conj_inv : forall s : state, init_state s -> conj_inv s.

intros s init; unfold conj_inv in |- *; split; eauto.
Qed.

Hint Resolve init_conj_inv.

Lemma invariant_conj_inv :
 invariant (fun (a : label) (s t : state) => transition s t a) conj_inv.

unfold invariant in |- *; unfold leads_to in |- *; unfold conj_inv in |- *.
intros s t inv step; elim inv; clear inv.
intros cardw_s inv; elim inv; clear inv.
intros cardb_s H_rt_s; split; eauto.
Qed.

Hint Resolve invariant_conj_inv.

Lemma safe_conj_inv :
 safe init_state (fun (a : label) (s t : state) => transition s t a)
   (state2stream_formula conj_inv).

apply safety; eauto.
Qed.

Hint Resolve safe_conj_inv.

Lemma safe_card_white :
 safe init_state (fun (a : label) (s t : state) => transition s t a)
   (state2stream_formula
      (fun s : state => exists b : nat, card_color white (mk s) b)).

apply
 safe_and_state
  with
    (Q := and_state
            (fun s : state => exists b : nat, card_color black (mk s) b)
            rt_grey_or_black); eauto.
Qed.

Hint Resolve safe_card_white.

Lemma always_card_white :
 forall str : stream state,
 run init_state (fun (a : label) (s t : state) => transition s t a) str ->
 always
   (state2stream_formula
      (fun s : state => exists w : nat, card_color white (mk s) w)) str.

intros str H_run.
cut
 (safe init_state (fun (a : label) (s t : state) => transition s t a)
    (state2stream_formula
       (fun s : state => exists w : nat, card_color white (mk s) w)));
 eauto.
Qed.

Hint Resolve always_card_white.

Lemma step_grey_card :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 (exists b : nat, card_color grey (mk s) b) ->
 step (fun (a : label) (s t : state) => transition s t a) s t ->
 exists b : nat, card_color grey (mk t) b.

unfold invariant in |- *; unfold leads_to in |- *.
intros s t cardw_s cardg_s step.
elim step.
intro a; case a; intro trans; inversion_clear trans; eauto.
Qed.

Hint Resolve step_grey_card.

Definition inv_conj : state_formula state :=
  fun s =>
  (exists g : nat, card_color grey (mk s) g) /\
  rt_grey_or_black s /\
  (exists b : nat, card_color black (mk s) b) /\
  (exists w : nat, card_color white (mk s) w).

Lemma init_inv_conj : forall s : state, init_state s -> inv_conj s.

intros s init; unfold inv_conj in |- *; split; eauto.
Qed.

Hint Resolve init_inv_conj.

Lemma invariant_inv_conj :
 invariant (fun (a : label) (s t : state) => transition s t a) inv_conj.

unfold invariant in |- *; unfold leads_to in |- *; unfold inv_conj in |- *.
intros s t inv step; elim inv; clear inv.
intros cardg_s inv; elim inv; clear inv.
intros H_rt inv; elim inv; clear inv.
intros cardb_s cardw_s; split; eauto.
split; eauto.
Qed.

Hint Resolve invariant_inv_conj.

Lemma safe_inv_conj :
 safe init_state (fun (a : label) (s t : state) => transition s t a)
   (state2stream_formula inv_conj).

apply safety; eauto.
Qed.

Hint Resolve safe_inv_conj.

Lemma safe_card_grey :
 safe init_state (fun (a : label) (s t : state) => transition s t a)
   (state2stream_formula
      (fun s : state => exists g : nat, card_color grey (mk s) g)).

apply
 safe_and_state
  with
    (Q := and_state rt_grey_or_black
            (and_state
               (fun s : state => exists b : nat, card_color black (mk s) b)
               (fun s : state => exists w : nat, card_color white (mk s) w)));
 eauto.
Qed.

Hint Resolve safe_card_grey.

Lemma always_card_grey :
 forall str : stream state,
 run init_state (fun (a : label) (s t : state) => transition s t a) str ->
 always
   (state2stream_formula
      (fun s : state => exists g : nat, card_color grey (mk s) g)) str.

intros str H_run.
cut
 (safe init_state (fun (a : label) (s t : state) => transition s t a)
    (state2stream_formula
       (fun s : state => exists g : nat, card_color grey (mk s) g)));
 eauto.
Qed.

Hint Resolve always_card_grey.

Definition g_w_b : stream_formula state :=
  and
    (state2stream_formula
       (fun s : state => exists g : nat, card_color grey (mk s) g))
    (and
       (state2stream_formula
          (fun s : state => exists b : nat, card_color black (mk s) b))
       (state2stream_formula
          (fun s : state => exists w : nat, card_color white (mk s) w))).

Lemma always_gwb :
 forall str : stream state,
 run init_state (fun (a : label) (s t : state) => transition s t a) str ->
 always g_w_b str.

intros str H_run; unfold g_w_b in |- *.
apply and_always; eauto.
apply and_always; eauto.
Qed.

Hint Resolve always_gwb.

Lemma safe_gwb :
 safe init_state (fun (a : label) (s t : state) => transition s t a) g_w_b.

unfold safe in |- *; eauto.
Qed.

Lemma step_mesure :
 forall (s t : state) (nb : nat),
 step (fun (a : label) (s t : state) => transition s t a) s t ->
 mesure (mk s) 0 \/
 (nb <> 0 /\ mesure (mk s) nb -> mesure (mk t) nb \/ mesure (mk t) (pred nb)).

intros s t nb step; elim step; clear step.
intro a; case a; intro trans; inversion trans.
right; intro H_mes; elim H_mes; clear H_mes; intros H_nb mes_s; left; eauto.
right; intro H_mes; elim H_mes; clear H_mes; intros H_nb mes_s; left; eauto.
right; intro H_mes; elim H_mes; clear H_mes; intros H_nb mes_s; left; eauto.
cut
 (mesure (mk s) 0 \/ (mesure (mk s) nb -> nb <> 0 /\ mesure (mk t) (pred nb)));
 eauto.
intro H_mes; elim H_mes; clear H_mes; auto.
intro H_mes; right; right.
elim H_mes; auto.
elim H0; auto.
right; intro H_mes; elim H_mes; clear H_mes.
intros H_nb mes_s; right; eauto.
right; intro H_mes; elim H_mes; clear H_mes; intros H_nb mes_s; left; eauto.
right; intro H_mes; elim H_mes; clear H_mes.
intros H_nb mes_s; right; eauto.
right; intro H_mes; elim H_mes; clear H_mes.
intros H_nb mes_s; right; eauto.
right; intro H_mes; elim H_mes; clear H_mes; intros H_nb mes_s; left; eauto.
Qed.

Hint Immediate gccall_ex_mesure.

Lemma step_ex_mesure :
 forall s t : state,
 rt_grey_or_black s ->
 (exists b : nat, card_color black (mk s) b) ->
 (exists nb : nat, mesure (mk s) nb) ->
 step (fun (a : label) (s t : state) => transition s t a) s t ->
 exists nb : nat, mesure (mk t) nb.

intros s t H_rt card_s H_mes step.
elim step.
intro a; case a; intro trans; inversion_clear trans; eauto.
Qed.

Hint Resolve step_ex_mesure.

Definition inv_conj_mes : state_formula state :=
  fun s =>
  (exists nb : nat, mesure (mk s) nb) /\
  rt_grey_or_black s /\ (exists b : nat, card_color black (mk s) b).

Lemma init_inv_conj_mes : forall s : state, init_state s -> inv_conj_mes s.

intros s init; unfold inv_conj in |- *; split; eauto.
Qed.

Hint Resolve init_inv_conj_mes.

Lemma invariant_inv_conj_mes :
 invariant (fun (a : label) (s t : state) => transition s t a) inv_conj_mes.

unfold invariant in |- *; unfold leads_to in |- *;
 unfold inv_conj_mes in |- *.
intros s t inv step; elim inv; clear inv.
intros H_mes inv; elim inv; clear inv.
intros H_rt cardb_s; split; eauto.
Qed.

Hint Resolve invariant_inv_conj_mes.

Lemma safe_inv_conj_mes :
 safe init_state (fun (a : label) (s t : state) => transition s t a)
   (state2stream_formula inv_conj_mes).

apply safety; eauto.
Qed.

Hint Resolve safe_inv_conj_mes.

Lemma safe_mesure :
 safe init_state (fun (a : label) (s t : state) => transition s t a)
   (state2stream_formula (fun s : state => exists nb : nat, mesure (mk s) nb)).

apply
 safe_and_state
  with
    (Q := and_state rt_grey_or_black
            (fun s : state => exists b : nat, card_color black (mk s) b));
 eauto.
Qed.

Hint Resolve safe_mesure.

Lemma always_mesure :
 forall str : stream state,
 run init_state (fun (a : label) (s t : state) => transition s t a) str ->
 always
   (state2stream_formula (fun s : state => exists nb : nat, mesure (mk s) nb))
   str.

intros str H_run.
cut
 (safe init_state (fun (a : label) (s t : state) => transition s t a)
    (state2stream_formula
       (fun s : state => exists nb : nat, mesure (mk s) nb)));
 eauto.
Qed.

Hint Resolve always_mesure.

End safe_card.

Hint Resolve always_gwb.
Hint Resolve safe_gwb.
Hint Resolve step_mesure.
Hint Resolve always_mesure.
Hint Resolve always_mesure.


(** * Combi.SymGroup.Frobenius_char : Frobenius characteristic *)
(******************************************************************************)
(*      Copyright (C) 2016-2021 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * Frobenius / Schur character theory for the symmetric groups.

We develop the theory of Frobenius characteristic associated to a class
function of ['SG_n], it is an isometry from class function to symmetric
functions, mapping
- [1%g] to ['HH[rowpartn n] ] (this is Fchar_triv);
- 1z_[l] to 'hp[l] (this is [Fchar_ncfuniCT]);
- induction product to product [Fchar_ind_morph];
- omega involution to multiplication by the sign character [omega_Fchar].

We define the following notions and notations:

- [Fchar f]     == the Frobenius characteristic of the class function [f].
                   the number of variable is inferred from the context.
- [Fchar_inv f] == the inverse Frobenius characteristic of the
                   homogeneous symmetric polynomial [f].

- ['M[la]]      == the Young character for ['SG_n] associated to the
                   partition [la] of n. If [la = (l1, ..., lk)] it is the
                   character induced from the trivial representations of the
                   group ['SG_l1 * ... * SG_lk].
- ['irrSG[la]]  == the irreducible character for ['SG_n] associated to the
                   partition [la] of n.

Here is a list of fundamental results:

- [Fchar_isometry] : The Frobenius characteristic is an isometry.
- [Young_rule]     : The Young rule for character of ['SG_n].
- [irrSGP]         : The ['irrSG[la] | la : 'P_n] forms a complete set of
                     irreducible characters for ['SG_n].
- [Frobenius_char] : Frobenius character formula for ['SG_n].
- [Murnaghan_Nakayama_char] : Murnaghan-Nakayama character formula for ['SG_n].
- [dim_cfReprSG]   : the dimension of irreducible representation of ['SG_n].
- [LR_rule_irrSG]  : Littlewood-Richardson rule for characters of ['SG_n].
 ********)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import finfun fintype tuple finset bigop order.
From mathcomp Require Import ssralg fingroup morphism perm gproduct.
From mathcomp Require Import rat ssralg ssrint ssrnum algC vector.
From mathcomp Require Import mxrepresentation classfun character.

From SsrMultinomials Require Import mpoly.
Require Import sorted ordtype tools partition antisym sympoly homogsym Cauchy
        Schur_altdef stdtab therule.
Require Import permcomp cycletype towerSn permcent reprSn unitriginv.
Require Import MurnaghanNakayama.

Require ordtype.
Local Notation inh := ordtype.Inhabited.Exports.inh.

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

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

Reserved Notation "''irrSG[' l ']'"
         (at level 8, l at level 2, format "''irrSG[' l ]").
Reserved Notation "''M[' l ']'"
         (at level 8, l at level 2, format "''M[' l ]").

Local Notation algCF := [numFieldType of algC].
Local Lemma char0_rat : [char rat] =i pred0.
Proof. exact: char_num. Qed.
Local Lemma char0_algC : [char algC] =i pred0.
Proof. exact: char_num. Qed.
#[local] Hint Resolve char0_algC char0_rat : core.

(** * Definition and basic properties *)
Section NVar.

Variable nvar0 : nat.
Local Notation nvar := nvar0.+1.

Section Defs.

Variable n : nat.
Local Notation HS := {homsym algC[nvar, n]}.

Definition Fchar (f : 'CF('SG_n)) : HS :=
  locked (\sum_(la : 'P_n) (f (permCT la) / 'z_la) *: 'hp[la]).

Definition Fchar_inv (p : HS) : 'CF('SG_n) :=
  locked (\sum_(la : 'P_n) (coord 'hp (enum_rank la) p) *: '1z_[la]).

Lemma FcharE (f : 'CF('SG_n)) :
  Fchar f = \sum_(la : 'P_n) (f (permCT la) / 'z_la) *: 'hp[la].
Proof. by rewrite /Fchar; unlock. Qed.

Lemma Fchar_invE (p : HS) :
  Fchar_inv p = \sum_(la : 'P_n) (coord 'hp (enum_rank la) p) *: '1z_[la].
Proof. by rewrite /Fchar_inv; unlock. Qed.

Lemma Fchar_is_linear : linear Fchar.
Proof using.
move=> a f g; rewrite !FcharE scaler_sumr -big_split /=.
apply eq_bigr => l _; rewrite !cfunElock.
by rewrite scalerA mulrA -scalerDl mulrDl.
Qed.
Canonical Fchar_additive := Additive Fchar_is_linear.
Canonical Fchar_linear := Linear Fchar_is_linear.

Lemma Fchar_ncfuniCT (l : 'P_n) : Fchar '1z_[l] = 'hp[l].
Proof using.
rewrite !FcharE (bigD1 l) //= big1 ?addr0; first last.
  move=> m /negbTE Hm /=.
  rewrite cfunElock cfuniCTE /= permCTP partnCTE /= !CTpartnK Hm /=.
  by rewrite mulr0 mul0r scale0r.
rewrite cfunElock cfuniCTE /= permCTP eq_refl /=.
by rewrite mulr1 divff ?scale1r.
Qed.

Lemma Fchar_inv_is_linear : linear Fchar_inv.
Proof using.
move=> a f g; rewrite !Fchar_invE scaler_sumr -big_split /=.
apply eq_bigr => la _.
by move: ('1z_[la]) => U; rewrite !linearD !linearZ /= scalerDl scalerA mulrC.
Qed.
Canonical Fchar_inv_additive := Additive Fchar_inv_is_linear.
Canonical Fchar_inv_linear := Linear Fchar_inv_is_linear.

Hypothesis Hn : (n <= nvar)%N.

Lemma FcharK : cancel Fchar Fchar_inv.
Proof using Hn.
move=> f.
rewrite !Fchar_invE {2}(ncfuniCT_gen f); apply eq_bigr => la _.
rewrite FcharE; congr (_ *: _).
rewrite (reindex _ (onW_bij _ (@enum_val_bij _))) /=.
transitivity
  (coord 'hp (enum_rank la)
         (\sum_(j < #|{:'P_n}|)
           (f (permCT (enum_val j)) / 'z_(enum_val j)) *: ('hp`_j : HS))).
  congr coord; apply eq_bigr => /= i _; congr (_ *: _).
  rewrite (nth_map inh); last by rewrite -cardE ltn_ord.
  by congr ('hp[_]); apply enum_val_nth.
by rewrite coord_sum_free ?enum_rankK //; exact: symbp_free.
Qed.

Lemma Fchar_invK : cancel Fchar_inv Fchar.
Proof using Hn.
move=> p; rewrite !Fchar_invE linear_sum.
have: p \in span 'hp.
  by rewrite (span_basis (symbp_basis Hn _ )) // memvf.
move=> /coord_span {2}->.
rewrite (reindex _ (onW_bij _ (@enum_rank_bij [finType of 'P__]))) /=.
apply eq_bigr => i _.
rewrite linearZ /= Fchar_ncfuniCT; congr (_ *: _).
rewrite (nth_map inh); last by rewrite -cardE ltn_ord.
by congr ('hp[_]); rewrite -enum_val_nth enum_rankK.
Qed.

Lemma Fchar_triv : Fchar 1 = 'hh[rowpartn n].
Proof.
rewrite -decomp_cf_triv linear_sum.
rewrite (eq_bigr (fun la => 'z_la^-1 *: 'hp[la])); first last => [la _|].
  rewrite -Fchar_ncfuniCT /ncfuniCT /= linearZ /=.
  by rewrite scalerA /= mulrC divff // scale1r.
apply val_inj; case: n => [|n0]/=.
  rewrite prod_gen0 (big_pred1 (rowpartn 0)); first last.
    by move=> la /=; rewrite !intpartn0 eqxx.
  rewrite linearZ /= prod_gen0.
  rewrite zcoeffE /zcard rowpartn0E big_nil mul1n /=.
  by rewrite big1 // invr1 scale1r.
rewrite /prod_gen rowpartnE big_seq1 raddf_sum symh_to_symp //=.
by apply eq_bigr => l _; rewrite zcoeffE.
Qed.

Lemma Fchar_inv_homsymp (l : 'P_n) : Fchar_inv 'hp[l] = '1z_[l].
Proof. by rewrite -Fchar_ncfuniCT FcharK. Qed.

(** ** Frobenius Characteristic and omega involution *)
Lemma omega_Fchar_inv (p : HS) :
  Fchar_inv (omegahomsym p) = sign_char * (Fchar_inv p).
Proof.
have /coord_span -> : p \in span 'hp.
  by rewrite (span_basis (symbp_basis Hn _ )) // memvf.
rewrite !linear_sum /= mulr_sumr; apply eq_bigr => i _.
rewrite !linearZ /= -scalerAr; congr (_ *: _).
rewrite {p} (nth_map (rowpartn n)); last by rewrite -cardE ltn_ord.
move: (nth _ _ _) => la {i}.
rewrite omega_homsymp //;
  try by apply: (leq_trans (leq_head_sumn _)); rewrite sumn_intpartn.
rewrite linearZ /= Fchar_inv_homsymp.
rewrite /ncfuniCT scalerA mulrC -scalerA -scalerAr; congr (_ *: _).
rewrite -cfunP => /= s; rewrite !cfunE.
rewrite odd_cycle_type signr_odd sumn_intpartn.
rewrite cfuniCTE; case: eqP => [->|]; rewrite /= ?mulr0 // {s}.
by rewrite {1}card_ord cast_intpartnE.
Qed.

Lemma omega_Fchar f : omegahomsym (Fchar f) = Fchar (sign_char * f).
Proof. by rewrite -(FcharK f) -omega_Fchar_inv !Fchar_invK. Qed.

Lemma Fchar_sign : Fchar sign_char = 'he[rowpartn n].
Proof.
rewrite -(mulr1 sign_char) -omega_Fchar Fchar_triv omega_homsymh //.
by apply: (leq_trans (leq_head_sumn _)); rewrite sumn_intpartn.
Qed.

(** ** The Frobenius Characteristic is an isometry *)
Theorem Fchar_isometry f g : '[Fchar f | Fchar g] = '[f, g].
Proof using Hn.
rewrite (ncfuniCT_gen f) (ncfuniCT_gen g) !linear_sum /=.
rewrite homsymdot_suml cfdot_suml; apply eq_bigr => la _.
rewrite homsymdot_sumr cfdot_sumr; apply eq_bigr => mu _.
rewrite ![Fchar (_ *: '1z_[_])]linearZ /= !Fchar_ncfuniCT.
rewrite homsymdotZl homsymdotZr cfdotZl cfdotZr; congr (_ * (_ * _)).
rewrite homsymdotpp // cfdotZl cfdotZr cfdot_classfun_part.
case: (altP (la =P mu)) => [<-{mu} | _]; rewrite ?mulr0 ?mulr1 //.
rewrite -zcoeffE -[LHS]mulr1; congr (_ * _).
rewrite /zcoeff rmorphM rmorphV; first last.
  by rewrite unitfE pnatr_eq0 card_classCT_neq0.
rewrite !rmorph_nat -mulrA [X in _ * X]mulrC - mulrA divff; first last.
  by rewrite pnatr_eq0 card_classCT_neq0.
by rewrite mulr1 divff // pnatr_eq0 -lt0n cardsT card_Sn fact_gt0.
Qed.

Theorem Fchar_inv_isometry p q : '[Fchar_inv p, Fchar_inv q] = '[p | q].
Proof using Hn. by rewrite -Fchar_isometry !Fchar_invK. Qed.

End Defs.

(**
This cannot be written as a SSReflect [{morph Fchar : f g / ...  >-> ... }]
because the dependency of Fchar on the degree [n]. The three [Fchar] below are
actually three different functions.

Note: this can be solved using a dependant record [{n; 'CF('S_n)}] with a
dependent equality but I'm not sure this is really needed.

*)

(** ** The Frobenius Characteristic is a graded ring morphism *)

Theorem Fchar_ind_morph m n (f : 'CF('SG_m)) (g : 'CF('SG_n)) :
  Fchar ('Ind['SG_(m + n)] (f \o^ g)) = Fchar f *h Fchar g.
Proof using.
rewrite (ncfuniCT_gen f) (ncfuniCT_gen g) !linear_sum; apply eq_bigr => /= l _.
rewrite cfextprod_suml homsymprod_suml !linear_sum; apply eq_bigr => /= k _.
do 2 rewrite [in RHS]linearZ /= Fchar_ncfuniCT.
rewrite cfextprodZr cfextprodZl homsymprodZr homsymprodZl !scalerA.
rewrite 2!linearZ /= ncfuniCT_Ind linearZ /= Fchar_ncfuniCT /=; congr (_ *: _).
by apply val_inj => /=; rewrite prod_genM.
Qed.

(** * Combinatorics of characters of the symmetric groups *)

(** ** Young characters and Young Rule *)
Section Character.

Import LeqGeqOrder.

Variable n : nat.
Hypothesis Hn : (n <= nvar)%N.
Local Notation HS := {homsym algC[nvar, n]}.

Lemma homsymh_character (la : 'P_n) : Fchar_inv 'hh[la] \is a character.
Proof.
move: (n) la Hn => d [la /= Hla].
have:= Hla => /andP [/eqP Hd _]; subst d.
elim: la Hla => [| l0 la IHla] Hlla Hd.
  by rewrite intpartn0 -Fchar_triv FcharK // cfun1_char.
have Hla : (sumn la == sumn la) && is_part la.
  by rewrite eq_refl /=; have:= Hlla => /andP [_ /is_part_consK ->].
have Hdla : (sumn la <= nvar)%N by apply: (leq_trans _ Hd); rewrite /= leq_addl.
have {IHla} Hrec := IHla Hla Hdla.
rewrite homsymprod_hh -Fchar_triv -(Fchar_invK Hdla 'hh[(IntPartN Hla)]).
rewrite -Fchar_ind_morph (FcharK Hd).
apply cfInd_char; rewrite cfIsom_char.
exact: (cfextprod_char (cfun1_char _) Hrec).
Qed.

Lemma homsyme_character (la : 'P_n) : Fchar_inv 'he[la] \is a character.
Proof.
rewrite -omega_homsymh; first last.
  by apply: (leq_trans _ Hn); rewrite -{2}(sumn_intpartn la) leq_head_sumn.
rewrite omega_Fchar_inv //.
exact: rpredM (lin_charW (sign_charP _)) (homsymh_character _).
Qed.

End Character.

End NVar.
#[local] Hint Resolve leqSpred : core.

Arguments Fchar nvar0 [n] f.
Arguments Fchar_inv nvar0 [n] p.

Lemma FcharNvar (nvar0 nvar1 n : nat) (f : 'CF('SG_n)) :
  (n <= nvar0.+1)%N || (nvar1 < nvar0.+1)%N ->
  cnvarhomsym nvar1 (Fchar nvar0 f) = (Fchar nvar1 f).
Proof.
rewrite !FcharE => Hn; rewrite linear_sum /=; apply eq_bigr => la _.
by rewrite linearZ /= cnvarhomsymp.
Qed.

Section YoungIrrDef.

Variable (n : nat).
Implicit Type (la mu : 'P_n).

Definition YoungSG la : 'CF('SG_n) := Fchar_inv (n.-1) 'hh[la].
Definition irrSG   la : 'CF('SG_n) := Fchar_inv (n.-1) 'hs[la].

Notation "''M[' l ']'" := (YoungSG l).
Notation "''irrSG[' l ']'" := (irrSG l).

Lemma Fchar_irrSGE nvar0 la : Fchar nvar0 'irrSG[la] = 'hs[la].
Proof.
rewrite /irrSG -(FcharNvar (nvar0 := n.-1) _) ?leqSpred //=.
by rewrite Fchar_invK ?leqSpred //= cnvarhomsyms ?leqSpred.
Qed.

Lemma Young_char la : 'M[la] \is a character.
Proof. exact: homsymh_character. Qed.

Lemma Young_rule la : 'M[la] = \sum_(mu : 'P_n) 'K(mu, la)  *: 'irrSG[mu].
Proof.
pose HS := {homsym algC[n.-1.+1, n]}.
rewrite /YoungSG /irrSG.
apply: (can_inj (FcharK _)); rewrite // Fchar_invK //.
have -> : 'hh[la] = \sum_(mu : 'P_n) 'K(mu, la) *: 'hs[mu] :> HS.
  apply/val_inj; rewrite -[val 'hh[la]]/('h[la]).
  by rewrite /= symh_syms /= linear_sum /=.
rewrite linear_sum /=; apply eq_bigr => mu hmu.
by rewrite linearZ /= Fchar_invK.
Qed.

Lemma Young_rule_partdom la :
  'M[la] =
  'irrSG[la] + \sum_(mu | (la < mu :> 'PDom_n)%O) 'K(mu, la)  *: 'irrSG[mu].
Proof.
rewrite Young_rule.
exact: (unitrig_sum1lV (fun mu : 'PDom_n => 'irrSG[mu]) la (Kostka_unitrig _ n)).
Qed.

(** ** Irreducible character *)

(** Substracting characters *)
Lemma rem_irr1 (xi phi : 'CF('SG_n)) :
  xi \in irr 'SG_n -> phi \is a character -> '[phi, xi] != 0 ->
     phi - xi \is a character.
Proof.
move=> /irrP [i ->{xi}] Hphi.
rewrite -irr_consttE => /(constt_charP i Hphi) [psi Hpsi ->{phi Hphi}].
by rewrite [_ + psi]addrC addrK.
Qed.

Lemma rem_irr (xi phi : 'CF('SG_n)) :
  xi \in irr 'SG_n -> phi \is a character ->
     phi - '[phi, xi] *: xi \is a character.
Proof.
move=> Hxi Hphi.
have /CnatP [m Hm] := Cnat_cfdot_char Hphi (irrWchar Hxi).
rewrite Hm.
elim: m phi Hphi Hm => [|m IHm] phi Hphi Hm; first by rewrite scale0r subr0.
rewrite mulrS scalerDl scale1r opprD addrA; apply: IHm.
- by apply rem_irr1; rewrite //= Hm pnatr_eq0.
- by rewrite cfdotBl Hm irrWnorm // mulrS [1 + _]addrC addrK.
Qed.

Lemma irrSG_orthonormal la mu :
  '['irrSG[la], 'irrSG[mu]] = (la == mu)%:R.
Proof. by rewrite /irrSG Fchar_inv_isometry // homsymdotss. Qed.

Theorem irrSG_irr la : 'irrSG[la] \in irr 'SG_n.
Proof.
elim/(finord_wf_down (T := [finPOrderType of 'PDom_n])): la => la IHla.
rewrite irrEchar irrSG_orthonormal !eq_refl andbT.
have -> : 'irrSG[la] = 'M[la] - \sum_(mu : 'PDom_n | (la < mu)%O)
                                   '[ 'M[la], 'irrSG[mu] ] *: 'irrSG[mu].
  apply/eqP; rewrite eq_sym subr_eq {1}Young_rule_partdom.
  apply/eqP; congr (_ + _); apply eq_bigr => mu _.
  rewrite Young_rule.
  rewrite cfdot_suml (bigD1 mu) //= cfdotZl.
  rewrite irrSG_orthonormal eq_refl mulr1 scalerDl.
  rewrite big1 ?scale0r ?addr0 // => nu /negbTE Hnu.
  by rewrite cfdotZl irrSG_orthonormal Hnu mulr0.
rewrite -big_filter; set L := filter _ _.
have : all (<%O la) L by apply filter_all.
have : uniq L by apply: filter_uniq; apply: index_enum_uniq.
elim: L => [| l0 l IHl].
  by rewrite big_nil subr0 homsymh_character.
rewrite big_cons /= => /andP [Hl0l Huniq] /andP [Hl0 Hall].
rewrite [X in 'M[la] - X]addrC opprD addrA.
have {IHl Huniq Hall} := IHl Huniq Hall.
set Frec := 'M[la] - _ => HFrec.
suff {IHla} -> : '['M[la], 'irrSG[l0]] = '[Frec, 'irrSG[l0]].
  by apply rem_irr => //; apply: IHla.
rewrite {HFrec}/Frec /= cfdotBl /=.
rewrite cfdot_suml big_seq big1 ?cfdot0l ?subr0 // => mu Hmu.
rewrite cfdotZl irrSG_orthonormal.
case: eqP => H; last by rewrite mulr0.
by rewrite -H Hmu in Hl0l.
Qed.

(** The ['irrSG[la]] forms a complete set of irreducible character *)
Theorem irrSGP : perm_eq [seq 'irrSG[la] | la : 'P_n] (irr 'SG_n).
Proof.
set IRR := [seq 'irrSG[la] | la : 'P_n].
have Huniq : uniq IRR.
  rewrite map_inj_uniq ?enum_uniq // => la mu Hlamu.
  apply/eqP; have:= irrSG_orthonormal la mu.
  rewrite Hlamu irrSG_orthonormal eq_refl /=.
  by case: eqP => //= _ /eqP; rewrite oner_eq0.
apply (uniq_perm Huniq).
  exact: (free_uniq (basis_free (irr_basis _))).
have /(uniq_min_size Huniq) Htmp : {subset IRR <= irr 'SG_n}.
  move=> /= f /mapP [/= p /mapP [/= la _ ->{p}] -> {f}].
  exact: irrSG_irr.
suff /Htmp [] : (size (irr 'SG_n) <= size IRR)%N by [].
rewrite size_tuple -(vector.size_basis (irr_basis _)) dim_cfun.
rewrite card_classes_perm /=.
by rewrite size_tuple card_ord.
Qed.

(** ** Frobenius character formula for ['SG_n] *)

(** The value of the irreducible character ['irrSG[la]] using scalar product of
    symmetric function *)
Theorem Frobenius_char_homsymdot la (sigma : 'S_n) :
  'irrSG[la] sigma = '[ 'hs[la] | 'hp[cycle_typeSn sigma] ] _(n.-1, n).
Proof.
rewrite cfdotr_ncfuniCT -(Fchar_isometry (leqSpred n)).
by rewrite Fchar_irrSGE Fchar_ncfuniCT.
Qed.

Theorem Frobenius_char_coord la (sigma : 'S_n) :
  'irrSG[la] sigma =
  coord 'hs (enum_rank la) ('hp[cycle_typeSn sigma] : {homsym algC[n.-1.+1, n]}).
Proof.
pose HSC := {homsym algC[n.-1.+1, n]}.
symmetry.
rewrite Frobenius_char_homsymdot.
have /coord_span {2}-> : ('hp[cycle_typeSn sigma] : HSC) \in span 'hs.
  by rewrite (span_basis (symbs_basis _ (leqSpred n))) // memvf.
rewrite (reindex _ (onW_bij _ (@enum_rank_bij [finType of 'P__]))) /=.
rewrite homsymdot_sumr (bigD1 la) //=.
rewrite (nth_map (rowpartn n)) -?cardE ?ltn_ord // nth_enum_rank.
rewrite homsymdotZr homsymdotss ?leqSpred // eq_refl mulr1.
rewrite big1 ?addr0; first last.
  move=> nu /negbTE Hnu.
  rewrite (nth_map (rowpartn n)) -?cardE ?ltn_ord // nth_enum_rank.
  by rewrite homsymdotZr homsymdotss ?leqSpred // eq_sym Hnu mulr0.
by rewrite -coord_map_homsym ?map_homsymbs ?symbs_basis // map_homsymp.
Qed.

End YoungIrrDef.
Notation "''M[' l ']'" := (YoungSG l).
Notation "''irrSG[' l ']'" := (irrSG l).

(** Frobenius character formula for ['SG_n] *)
Theorem Frobenius_char n (la mu : 'P_n) :
  'irrSG[la] (permCT mu) =
  (Vanprod * \prod_(d <- mu) (symp_pol n algCF d))@_(mpart la + rho n).
Proof.
rewrite -/Vanprod Vanprod_alt.
case: n la mu => [//|n] //= la mu.
  rewrite (charSG0 (irrSG_irr _)) cfun1E inE /=.
  rewrite !mnm_n0E !intpartn0 {la mu} rowpartn0E big_nil mulr1.
  by rewrite mcoeff_alt //= map_inj_in_uniq ?enum_uniq // => /= [[]].
rewrite Frobenius_char_coord cycle_typeSn_permCT.
by rewrite mcoeff_symbs ?leqSpred //= rmorph_prod.
Qed.

(** The Murnaghan Nakayama rule for irreducible character ['irrSG[la]] *)
Theorem Murnaghan_Nakayama_char n la (sigma : 'S_n) :
  'irrSG[la] sigma = (MN_coeff la (cycle_typeSn sigma))%:~R.
Proof.
rewrite Frobenius_char_homsymdot MN_coeff_homogP raddf_sum /=.
rewrite (bigD1 la) //= big1 ?addr0 //; first last => [i /negbTE Hi|].
  by rewrite homsymdotZr homsymdotss // eq_sym Hi mulr0.
rewrite homsymdotZr homsymdotss // eqxx mulr1.
by rewrite conj_Cint // Cint_int.
Qed.
Corollary Murnaghan_NakayamaCT n (la mu : 'P_n) :
  'irrSG[la] (permCT mu) = (MN_coeff la mu)%:~R.
Proof. by rewrite Murnaghan_Nakayama_char cycle_typeSn_permCT. Qed.

Corollary irrSG_char_int n (la mu : 'P_n) : 'irrSG[la] (permCT mu) \in Cint.
Proof. by rewrite Murnaghan_NakayamaCT Cint_int. Qed.

Example Wikipedia_Murnaghan_Nakayama :
  let p521 := @IntPartN 8 [:: 5; 2; 1]%N is_true_true in
  let p3311 := @IntPartN 8 [:: 3; 3; 1; 1]%N is_true_true in
  'irrSG[p521] (permCT p3311) = - 2%:~R.
Proof. by rewrite /= Murnaghan_NakayamaCT. Qed.

(** The dimension of the irreducible character ['irrSG[la]] is the number of
    standard tableau of shape [la] *)
Theorem dim_irrSG n (la : 'P_n) : 'irrSG[la] 1%g = #|{: stdtabsh la}|%:R.
Proof.
pose HSC := {homsym algC[n.-1.+1, n]}.
rewrite -permCT_colpartn Frobenius_char_coord cycle_typeSn_permCT.
have -> : 'hp[colpartn n] = 'hh[colpartn n] :> HSC.
  apply val_inj; rewrite /= !prod_gen_colpartn.
  by rewrite sympe1E -symhe1E.
have -> : 'hh[colpartn n] = \sum_la 'K(la, colpartn n) *: 'hs[la] :> HSC.
  apply val_inj.
  by rewrite /= linear_sum /= -![prod_gen _ _]/('h[_]) symh_syms.
rewrite (reindex _ (onW_bij _ (@enum_val_bij _))) /=.
rewrite (eq_bigr
           (fun i : 'I__ => 'K(enum_val i, colpartn n) *: 'hs`_i)); first last.
  move=> /= i _.
  rewrite (nth_map inh); last by rewrite -cardE ltn_ord.
  by congr (_ *: 'hs[_]); apply enum_val_nth.
by rewrite coord_sum_free ?enum_rankK // ?KostkaStd //; exact: symbs_free.
Qed.

Theorem dim_cfReprSG n (la : 'P_n) d (rG : mx_representation algCF 'SG_n d) :
  cfRepr rG = 'irrSG[la] -> d = #|{: stdtabsh la}|.
Proof.
move=> H; have := cfRepr1 rG; rewrite H dim_irrSG => /eqP.
by rewrite eqC_nat => /eqP ->.
Qed.

(** * Littlewood-Richardson rule for irreducible characters *)
Theorem LR_rule_irrSG c d (la : 'P_c) (mu : 'P_d) :
  'Ind['SG_(c + d)] ('irrSG[la] \o^ 'irrSG[mu]) =
  \sum_(nu : 'P_(c + d) | included la nu) 'irrSG[nu] *+ LRyam_coeff la mu nu.
Proof.
apply (can_inj (FcharK (leqSpred (c + d)))).
rewrite Fchar_ind_morph linear_sum //= !Fchar_irrSGE.
apply val_inj; rewrite /= linear_sum /=.
rewrite syms_symsM; apply eq_bigr => nu _.
by rewrite !linearMn /= Fchar_invK // leqSpred.
Qed.


From mathcomp Require Import all_ssreflect.
Require Import all_core rs_base rs_base_prod rs_base_facts.
Require Import FunctionalExtensionality.

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

Section SUMSPACES.
(* This is the sum of represented spaces. *)

Definition linc X Y (phi: names X) (p: questions X * questions Y) :=
@inl (answers X) (answers Y) (phi (p.1)).
Definition rinc X Y (psi: names Y) (p: questions X * questions Y) :=
@inr (answers X) (answers Y) (psi (p.2)).

Definition lslct X Y (phipsi: questions X * questions Y -> answers X + answers Y) :=
	fun q => match phipsi (q, some_question Y) with
		| inl a => a
		| inr b => some_answer X
	end.

Definition rslct X Y (phipsi: questions X * questions Y -> answers X + answers Y) :=
	fun q => match phipsi (some_question X, q) with
		| inl b => some_answer Y
		| inr b => b
	end.

Definition slct X Y (phi: questions X * questions Y -> answers X + answers Y) :=
	match phi (some_question X, some_question Y) with
		| inl a => inl (lslct phi)
		| inr b => inr (rslct phi)
	end.

Lemma lslct_linc (X Y: rep_space) (phi: names X):
	@lslct X Y (linc phi) =  phi.
Proof. by trivial. Qed.

Lemma rslct_rinc (X Y: rep_space) (psi: names Y):
	@rslct X Y (rinc psi) =  psi.
Proof. by trivial. Qed.

Definition sum_rep X Y :=
	fun phipsi xpy => match xpy with
		| inl x => (exists a, phipsi (some_question X, some_question Y) = inl a)
			/\ rep X (lslct phipsi) x
		| inr y => (exists a, phipsi (some_question X, some_question Y) = inr a)
			/\ rep Y (rslct phipsi) y
	end.

Lemma sum_rep_is_rep (X Y: rep_space):
	(@sum_rep X Y) \is_representation.
Proof.
split.
	move => phi; rewrite /sum_rep.
	case => [x | y].
		case => [x' | y'] => [[_ phinx] [_ phinx'] | [[a eq] _] [[b eq'] _]].
			by rewrite (rep_sing X (lslct phi) x x').
		by rewrite eq in eq'.
	case => [x' | y'] => [[[a eq] _] [[b eq'] _] | [_ phinx] [_ phinx']].
		by rewrite eq in eq'.
	by rewrite (rep_sing Y (rslct phi) y y').
case => [xy | xy]; have [phi phin]:= rep_sur _ xy.
	by exists (linc phi); split; first by exists (phi (some_question X)).
by exists (rinc phi); split; first by exists (phi (some_question Y)).
Qed.

Canonical rep_space_sum X Y := @make_rep_space
  ((space X) + (space Y))
  (@questions X * @questions Y)
  (@answers X + @answers Y)
  (@sum_rep X Y)
 	(some_question X, some_question Y)
  (inl (some_answer X))
  (prod_count (countable_questions X) (countable_questions Y))
  (sum_count (countable_answers X) (countable_answers Y))
  (@sum_rep_is_rep X Y).
End SUMSPACES.

Section SUMLEMMAS.
Lemma inl_rec_fun (X Y: rep_space):
	(@inl X Y) \is_recursive_function.
Proof.
by exists (@linc X Y); split; first by exists (phi (some_question X)).
Defined.

Lemma inl_rec (X Y: rep_space):
	(F2MF (@inl X Y)) \is_recursive.
Proof. exact/rec_fun_rec/inl_rec_fun. Defined.

Lemma inr_rec_fun (X Y: rep_space):
	(@inr X Y) \is_recursive_function.
Proof.
by exists (@rinc X Y); split; first by exists (phi (some_question Y)).
Defined.

Lemma inr_rec (X Y: rep_space):
	(F2MF (@inr X Y)) \is_recursive.
Proof. exact/rec_fun_rec/inr_rec_fun. Defined.

Definition paib (X: Type):=
	fun (xx: X + X) => match xx with
		|	inl x => x
		| inr x => x
	end.

Definition paib_frlzr (X: rep_space) :=
	fun phi => @paib (names X) (slct phi).

Lemma paib_frlzr_paib (X: rep_space):
	(@paib_frlzr X) \is_realizer_function_for (@paib X).
Proof.
by rewrite /paib_frlzr/paib/slct; move => phi x; case: x => x [[a ->] phinx].
Qed.

Lemma paib_rec_fun (X: rep_space):
	(@paib X) \is_recursive_function.
Proof. exists (@paib_frlzr X); apply paib_frlzr_paib. Defined.

Lemma paib_rec (X: rep_space):
	(F2MF (@paib X)) \is_recursive.
Proof. exact/rec_fun_rec/paib_rec_fun. Defined.

Lemma sum_assoc_rec_fun (X Y Z: rep_space):
	(fun xyz: X + (Y + Z) => match xyz with
		| inl x => inl (inl x)
		| inr yz => match yz with
			| inl y => inl (inr y)
			| inr z => inr z
		end
	end) \is_recursive_function.
Proof.
exists (fun phi (q: (questions X)* (questions Y) * (questions Z)) =>
	match slct phi with
	| inl psi => linc (linc psi) q
	| inr psi => match slct psi with
		| inl psi' => linc (rinc psi') q
		| inr psi' => rinc psi' q
	end
end).
move => phi x phinx /=.

case: (slct phi).
case: (phi (some_question _)).
		move => _ /=.
Admitted.

Lemma sum_assoc_rec (X Y Z: rep_space):
	(F2MF (fun x: X * (Y * Z) => (x.1, x.2.1,x.2.2))) \is_recursive.
Proof.
exact/rec_fun_rec/prod_assoc_rec_fun.
Defined.

Lemma prod_assoc_inv_rec_fun (X Y Z: rep_space):
	(fun x: X * Y * Z => (x.1.1, (x.1.2, x.2))) \is_recursive_function.
Proof.
exists (fun phi => name_pair (lprj (lprj phi)) (name_pair (rprj (lprj phi)) (rprj phi))).
by move => phi [[x y] z] [[phinx phiny] phinz].
Defined.

Lemma prod_assoc_inv_rec (X Y Z: rep_space):
	(F2MF (fun x: X * Y * Z => (x.1.1, (x.1.2, x.2)))) \is_recursive.
Proof.
exact/rec_fun_rec/prod_assoc_inv_rec_fun.
Defined.

Lemma linc_cont X Y:
	(F2MF (@linc X Y)) \is_continuous.
Proof.
move => phi phifd q; exists ([:: q.1]); split => //.
by move => Fphi/= <- psi [eq _] Fpsi <-; rewrite /linc eq.
Qed.

Lemma inl_hcr (X Y: rep_space):
	(F2MF (@inl X Y)) \has_continuous_realizer.
Proof.
exists (F2MF (@linc X Y)); split; last exact: linc_cont.
by apply frlzr_rlzr; split; first by exists (phi (some_question X)).
Qed.

Lemma rinc_cont X Y:
	(F2MF (@rinc X Y)) \is_continuous.
Proof.
move => phi phifd q; exists ([::q.2]);split => //.
by move => Fphi/= <- psi [eq _] Fpsi <-; rewrite /rinc eq.
Qed.

Lemma inr_hcr (X Y: rep_space):
	(F2MF (@inr X Y)) \has_continuous_realizer.
Proof.
exists (F2MF (@rinc X Y)); split; last exact: rinc_cont.
by apply frlzr_rlzr; split; first by exists (phi (some_question Y)).
Qed.

Definition mfssFG_rlzr (X Y X' Y': rep_space) (F: (names X) ->> (names Y)) (G: (names X') ->> (names Y')):=
	fun (phi: names (rep_space_sum X X')) FGphi =>
		match phi (some_question X, some_question X') with
			| inl y => F (lslct phi) (lslct FGphi) /\ linc (lslct FGphi) = FGphi
			| inr y' => G (rslct phi) (rslct FGphi) /\ rinc (rslct FGphi) = FGphi
		end.

Definition mfssFG_frlzr X Y X' Y' (F: (names X) -> (names Y)) (G: (names X') -> (names Y')):=
	fun (phi: names (rep_space_sum X X')) =>
	match phi (some_question X, some_question X') with
		| inl y => linc (F (lslct phi))
		| inr y' => rinc (G (rslct phi))
	end.

Lemma mfssFG_frlzr_rlzr (X Y X' Y': rep_space) (F: (names X) -> (names Y)) (G: (names X') -> (names Y')):
	F2MF (mfssFG_frlzr F G) =~= mfssFG_rlzr (F2MF F) (F2MF G).
Proof.
split; rewrite /F2MF/mfssFG_rlzr/mfssFG_frlzr.
	by case (s (some_question X, some_question X')) => _ <-.
by case (s (some_question X, some_question X')) => _ [->].
Qed.

Lemma mfssFG_rlzr_spec (X Y X' Y': rep_space) (f: X ->> Y) (g: X' ->> Y') F G:
	F \is_realizer_of f -> G \is_realizer_of g -> (mfssFG_rlzr F G) \is_realizer_of (mfss f g).
Proof.
move => Frf Grg phi [].
case => y [[]].
	case => [x [[[a eq] phinx] /= fxy] prp | x']; last by rewrite {1}/mfss/= => [][].
	have fd: (lslct phi) \from_dom (f o (delta (r:=X))).
		exists y; split; first by exists x.
		by move => b c; rewrite (rep_sing _ (lslct phi) b x) => //; exists y.
	have [[y' [[psi [Fphipsi psiny']]] prop cnd]]:= Frf (lslct phi) fd.
	split.
		exists (inl y');split.
			exists (linc psi); split; rewrite /mfssFG_rlzr; first by rewrite eq.
			by split; [exists (psi (some_question Y)) | rewrite lslct_linc].
		move => psi'; rewrite /mfssFG_rlzr eq => [[b c]].
		have [y'' name]:= prop (lslct psi') b; exists (inl y'').
		by split; first by exists (lslct psi' (some_question Y)); rewrite -c.
	case => y'' [[psi'' [val /= [[a' eq'] name]] cond]]; last first.
		move: val; rewrite /mfssFG_rlzr eq => [[val inc]].
		by rewrite -inc /linc/= in eq'.
	move: val; rewrite /mfssFG_rlzr eq => [[val inc]].
	split; last first.
		case => x'' [[a'' eq''] name']; last by rewrite eq'' in eq.
		rewrite (rep_sing _ (lslct phi) x'' x) => //.
		by exists (inl y).
	exists (inl x); split; first by split; first by exists a.
	have phiy'': (delta (r:=Y)) o F (lslct phi) y''.
		by split; first by exists (lslct psi'').
	have [[this [tmpnm con]]]:= cnd y'' phiy''.
	by rewrite (rep_sing X (lslct phi) x this).
case => [x' | x [[[a eq] phinx] /= fxy] prp]; first by rewrite {1}/mfss/= => [][].
have fd: (rslct phi) \from_dom (g o (delta (r:=X'))).
	exists y; split; first by exists x.
	by move => s b; rewrite (rep_sing _ (rslct phi) s x) => //; exists y.
have [[y' [[psi [Fphipsi psiny']]] prop cnd]]:= Grg (rslct phi) fd.
split.
	exists (inr y'); split.
		exists (rinc psi); split; rewrite /mfssFG_rlzr; first by rewrite eq.
		by split; [exists (psi (some_question Y')) | rewrite rslct_rinc].
	move => psi'; rewrite /mfssFG_rlzr eq => [[b c]].
	have [y'' name]:= prop (rslct psi') b; exists (inr y'').
	by split; first by exists (rslct psi' (some_question Y')); rewrite -c.
case => y'' [[psi'' [val /= [[a' eq'] name]] cond]].
	move: val; rewrite /mfssFG_rlzr eq => [[val inc]].
	by rewrite -inc /rinc/= in eq'.
move: val; rewrite /mfssFG_rlzr eq => [[val inc]].
split; last first.
	case => x'' [[a'' eq''] name']; first by rewrite eq'' in eq.
	rewrite (rep_sing _ (rslct phi) x'' x) => //.
	by exists (inr y).
exists (inr x).
split; first by split; first by exists a.
have phiy'': (delta (r:=Y')) o G (rslct phi) y''.
	by split; first by exists (rslct psi'').
have [[this [tmpnm con]]]:= cnd y'' phiy''.
by rewrite (rep_sing X' (rslct phi) x this).
Qed.

Lemma mfssFG_frlzr_spec (X Y X' Y': rep_space) (f: X -> Y) (g: X' -> Y') F G:
	F \is_realizer_function_for f -> G \is_realizer_function_for g -> (mfssFG_frlzr F G) \is_realizer_function_for (f +s+_f g).
Proof.
intros.
rewrite frlzr_rlzr mfssFG_frlzr_rlzr mfss_fun_mfss.
by apply mfssFG_rlzr_spec; rewrite -frlzr_rlzr.
Qed.

Lemma sum_rec_fun (X Y X' Y': rep_space) (f: X -> Y) (g: X' -> Y'):
	f \is_recursive_function -> g \is_recursive_function -> (f +s+_f g) \is_recursive_function.
Proof.
move => [M /= Mrf] [N /= Nrg].
exists (mfssFG_frlzr M N).
exact/ mfssFG_frlzr_spec.
Defined.

Lemma sum_rec (X Y X' Y': rep_space) (f: X ->> Y) (g: X' ->> Y'):
	f \is_recursive -> g \is_recursive -> (f +s+ g) \is_recursive.
Proof.
move => [M Mrf] [N Nrg].
exists (mfssFG_frlzr M N).
abstract by rewrite rrlzr_rlzr mfssFG_frlzr_rlzr; apply mfssFG_rlzr_spec; rewrite -rrlzr_rlzr.
Defined.

Lemma sum_uprp_fun (X Y Z: rep_space) (f: X -> Z) (g: Y -> Z):
	exists! (F: X + Y -> Z),
		(forall x, F (inl x) = f x)
		/\
		(forall y, F (inr y) = g y).
Proof.
exists (fun xy => paib (mfss_fun f g xy)); rewrite /paib.
by split => // F [eq eq']; apply functional_extensionality => [[x | y]].
Qed.

Lemma sum_uprp_rec_fun (X Y Z: rep_space) (f: X -> Z) (g: Y -> Z):
	f \is_recursive_function -> g \is_recursive_function ->
	exists! (fg: X + Y -> Z), exists (P: fg \is_recursive_function),
		(forall x, fg (inl x) = f x)
		/\
		(forall y, fg (inr y) = g y).
Proof.
intros.
exists (fun xy => paib (mfss_fun f g xy)); split; last rewrite /paib.
	split; last	by split => // F [eq eq']; apply functional_extensionality => [[x | y]].
	by apply/ rec_fun_comp; [ apply: sum_rec_fun X0 X1 | apply paib_rec_fun | ] => /=.
move => fg [fgrec [lfg rfg]].
by apply functional_extensionality; case => /= x; [rewrite -lfg | rewrite -rfg].
Qed.
End SUMLEMMAS.


Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.

Inductive expr {Var: Type}: Type :=
  | impp : expr -> expr -> expr
  | varp : Var -> expr.

Arguments expr Var: clear implicits.

Instance L (Var: Type): Language :=
  Build_Language (expr Var).

Instance minL (Var: Type): MinimumLanguage (L Var) :=
  Build_MinimumLanguage (L Var) impp.

Definition rank {Var: Type}: expr Var -> nat :=
  fix rank (x: expr Var): nat :=
    match x with
    | impp y z => 1 + rank y + rank z
    | varp p => 0
    end.

Definition formula_countable: forall Var, Countable Var -> Countable (expr Var).
  intros.
  assert (forall n, Countable (sig (fun x: expr Var => rank x <= n))).
  + induction n.
    - apply (@bijection_Countable _ Var); [| solve_Countable].
      apply bijection_sym.
      apply (FBuild_bijection _ _ (fun p => exist (fun x: expr Var => rank x <= 0) (varp p) (le_n 0))).
      * hnf; intros.
        inversion H; auto.
      * hnf; intros.
        destruct b as [[] HH]; try solve [inversion HH].
        exists v.
        eauto; f_equal; apply proof_irrelevance.
    - set (s := sig (fun x: expr Var => rank x <= n)).
      apply (@injection_Countable _ (s * s + Var)%type); [| solve_Countable].

      apply (Build_injection _ _ (fun x y =>
        match y with
        | inl (exist _ y _, exist _ z _) => proj1_sig x = impp y z
        | inr p => proj1_sig x = varp p
        end)).
      * hnf; intros.
        destruct a as [[y z | p] ?H].
        (* 1 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (exist _ y H0, exist _ z H1)); auto.
        (* 2 *) exists (inr p); auto.
      * hnf; intros.
        destruct a as [[y z | p] ?H];
        destruct b1 as [[[y1 ?H] [z1 ?H]] | p1]; try solve [inversion H];
        destruct b2 as [[[y2 ?H] [z2 ?H]] | p2]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
      * hnf; intros.
        destruct b as [[[y ?H] [z ?H]] | p];
        destruct a1 as [[y1 z1 | p1] ?H]; try solve [inversion H];
        destruct a2 as [[y2 z2 | p2] ?H]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
  + apply (@injection_Countable _ (sigT (fun n => sig (fun x: expr Var => rank x <= n)))); [| solve_Countable; auto].
    apply (FBuild_injection _ _ (fun x0 => existT (fun n => sig (fun x => rank x <= n)) (rank x0) (exist (fun x => rank x <= rank x0) x0 (le_n (rank x0))))).
    hnf; intros.
    simpl in H.
    inversion H; auto.
Qed.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__equalitysymmetric.
Require Export lemma__parallelcollinear1.
Require Export lemma__parallelcollinear2.
Require Export lemma__tarskiparallelflip.
Require Export logic.
Definition lemma__parallelcollinear : forall A B C c d, (euclidean__defs.TP A B c d) -> ((euclidean__axioms.Col c d C) -> ((euclidean__axioms.neq C d) -> (euclidean__defs.TP A B C d))).
Proof.
intro A.
intro B.
intro C.
intro c.
intro d.
intro H.
intro H0.
intro H1.
assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B c d)) /\ (euclidean__defs.OS c d A B)))) as H2.
- assert ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B c d)) /\ (euclidean__defs.OS c d A B)))) as H2 by exact H.
assert ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B c d)) /\ (euclidean__defs.OS c d A B)))) as __TmpHyp by exact H2.
destruct __TmpHyp as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
split.
-- exact H3.
-- split.
--- exact H5.
--- split.
---- exact H7.
---- exact H8.
- assert (* Cut *) ((c = d) \/ ((c = C) \/ ((d = C) \/ ((euclidean__axioms.BetS d c C) \/ ((euclidean__axioms.BetS c d C) \/ (euclidean__axioms.BetS c C d)))))) as H3.
-- destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
exact H0.
-- assert (* Cut *) (euclidean__defs.TP A B C d) as H4.
--- assert ((c = d) \/ ((c = C) \/ ((d = C) \/ ((euclidean__axioms.BetS d c C) \/ ((euclidean__axioms.BetS c d C) \/ (euclidean__axioms.BetS c C d)))))) as H4 by exact H3.
assert ((c = d) \/ ((c = C) \/ ((d = C) \/ ((euclidean__axioms.BetS d c C) \/ ((euclidean__axioms.BetS c d C) \/ (euclidean__axioms.BetS c C d)))))) as __TmpHyp by exact H4.
destruct __TmpHyp as [H5|H5].
---- assert (* Cut *) (~(~(euclidean__defs.TP A B C d))) as H6.
----- intro H6.
destruct H2 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
apply (@H9 H5).
----- apply (@euclidean__tactics.NNPP (euclidean__defs.TP A B C d)).
------intro H7.
destruct H2 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
assert (* Cut *) (False) as H14.
------- apply (@H10 H5).
------- assert (* Cut *) (False) as H15.
-------- apply (@H6 H7).
-------- contradiction H15.

---- destruct H5 as [H6|H6].
----- assert (* Cut *) (euclidean__defs.TP A B C d) as H7.
------ destruct H2 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
apply (@eq__ind__r euclidean__axioms.Point C (fun c0 => (euclidean__defs.TP A B c0 d) -> ((euclidean__axioms.Col c0 d C) -> ((euclidean__axioms.neq c0 d) -> ((~(euclidean__defs.Meet A B c0 d)) -> ((euclidean__defs.OS c0 d A B) -> (euclidean__defs.TP A B C d))))))) with (x := c).
-------intro H13.
intro H14.
intro H15.
intro H16.
intro H17.
exact H13.

------- exact H6.
------- exact H.
------- exact H0.
------- exact H9.
------- exact H11.
------- exact H12.
------ exact H7.
----- destruct H6 as [H7|H7].
------ assert (* Cut *) (~(~(euclidean__defs.TP A B C d))) as H8.
------- intro H8.
assert (* Cut *) (C = d) as H9.
-------- destruct H2 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
apply (@lemma__equalitysymmetric.lemma__equalitysymmetric C d H7).
-------- apply (@H1 H9).
------- apply (@euclidean__tactics.NNPP (euclidean__defs.TP A B C d)).
--------intro H9.
destruct H2 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
assert (* Cut *) (False) as H16.
--------- apply (@H8 H9).
--------- contradiction H16.

------ destruct H7 as [H8|H8].
------- assert (* Cut *) (euclidean__axioms.BetS C c d) as H9.
-------- destruct H2 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
apply (@euclidean__axioms.axiom__betweennesssymmetry d c C H8).
-------- assert (* Cut *) (euclidean__defs.TP A B C d) as H10.
--------- destruct H2 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
apply (@lemma__parallelcollinear1.lemma__parallelcollinear1 A B C c d H H9).
--------- exact H10.
------- destruct H8 as [H9|H9].
-------- assert (* Cut *) (euclidean__axioms.BetS C d c) as H10.
--------- destruct H2 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
apply (@euclidean__axioms.axiom__betweennesssymmetry c d C H9).
--------- assert (* Cut *) (euclidean__defs.TP A B d c) as H11.
---------- destruct H2 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
assert (* Cut *) ((euclidean__defs.TP B A c d) /\ ((euclidean__defs.TP A B d c) /\ (euclidean__defs.TP B A d c))) as H17.
----------- apply (@lemma__tarskiparallelflip.lemma__tarskiparallelflip A B c d H).
----------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H20.
---------- assert (* Cut *) (euclidean__defs.TP A B C c) as H12.
----------- destruct H2 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
apply (@lemma__parallelcollinear1.lemma__parallelcollinear1 A B C d c H11 H10).
----------- assert (* Cut *) (euclidean__defs.TP A B c C) as H13.
------------ destruct H2 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
assert (* Cut *) ((euclidean__defs.TP B A C c) /\ ((euclidean__defs.TP A B c C) /\ (euclidean__defs.TP B A c C))) as H19.
------------- apply (@lemma__tarskiparallelflip.lemma__tarskiparallelflip A B C c H12).
------------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H22.
------------ assert (* Cut *) (euclidean__defs.TP A B d C) as H14.
------------- destruct H2 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
apply (@lemma__parallelcollinear2.lemma__parallelcollinear2 A B d c C H13 H9).
------------- assert (* Cut *) (euclidean__defs.TP A B C d) as H15.
-------------- destruct H2 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
assert (* Cut *) ((euclidean__defs.TP B A d C) /\ ((euclidean__defs.TP A B C d) /\ (euclidean__defs.TP B A C d))) as H21.
--------------- apply (@lemma__tarskiparallelflip.lemma__tarskiparallelflip A B d C H14).
--------------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H24.
-------------- exact H15.
-------- assert (* Cut *) (euclidean__defs.TP A B C d) as H10.
--------- destruct H2 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
apply (@lemma__parallelcollinear2.lemma__parallelcollinear2 A B C c d H H9).
--------- exact H10.
--- exact H4.
Qed.


Require Import Hask.Prelude.
Require Import Hask.Data.Maybe.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

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

  mappend_assoc : forall a b c, mappend a (mappend b c) = mappend (mappend a b) c;
}.

Arguments mappend {m _} _ _.

Infix "⨂" := mappend (at level 41, right associativity).

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.

#[export]
Program Instance Semigroup_Maybe `{Semigroup a} : Semigroup (Maybe a) := {
  mappend := Maybe_append
}.
Next Obligation.
  destruct a0, b, c; simpl; try reflexivity.
  now rewrite mappend_assoc.
Qed.


(*********************************************************************************

 Monoidal sections

 A section on a displayed monoidal category is data and properties such that we
 can construct a lax/strong monoidal functor from the base to the total category.

Note: after refactoring on March 10, 2023, the prior Git history of this development is found via
git log -- UniMath/CategoryTheory/Monoidal/MonoidalSectionsWhiskered.v

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Section MonoidalSections.

  Import BifunctorNotations.
  Import MonoidalNotations.
  Import DisplayedBifunctorNotations.
  Import DisplayedMonoidalNotations.

  Context {C : category} {D : disp_cat C}.
  Local Notation TD := (total_category D).
  Context (M : monoidal C) (DM : disp_monoidal D M).
  Local Notation TM := (total_monoidal DM).

  Definition section_preserves_tensor_data (sd : section_disp D) : UU
    := ∏ (x y : C),  sd x ⊗⊗_{ DM} sd y -->[ identity (x ⊗_{ M} y)] sd (x ⊗_{ M} y).

  Lemma sectionfunctor_preserves_tensordata
        {sd : section_disp D}
        (spt : section_preserves_tensor_data sd)
    : preserves_tensordata M TM (section_functor sd).
  Proof.
    intros x y.
    use tpair.
    - apply identity.
    - apply spt.
  Defined.

  Definition section_preserves_unit (sd : section_disp D) : UU
    :=  dI_{DM} -->[ identity I_{M}] sd I_{M}.

  Lemma sectionfunctor_preserves_unit
        {sd : section_disp D}
        (spu : section_preserves_unit sd)
    : preserves_unit M TM (section_functor sd).
  Proof.
    use tpair.
    - apply identity.
    - apply spu.
  Defined.

  Definition smonoidal_data (sd : section_disp D) : UU
    := (section_preserves_tensor_data sd) × (section_preserves_unit sd).
  Definition smonoidal_preserves_tensor {sd : section_disp D} (ms : smonoidal_data sd)
    : section_preserves_tensor_data sd := pr1 ms.
  Definition smonoidal_preserves_unit {sd : section_disp D} (ms : smonoidal_data sd)
    : section_preserves_unit sd := pr2 ms.

  Definition sectionfunctor_fmonoidal_data
             {sd : section_disp D}
             (spt : section_preserves_tensor_data sd)
             (spu : section_preserves_unit sd)
    : fmonoidal_data M TM (section_functor sd)
    := (sectionfunctor_preserves_tensordata spt,,sectionfunctor_preserves_unit spu).

  (* This notation comes from Constructions.v, but there is no Notation module, this has to be added *)
  Notation "# F" := (section_disp_on_morphisms F) (at level 3) : mor_disp_scope.

  Definition section_preserves_tensor_nat_left
             {sd : section_disp D}
             (spt : section_preserves_tensor_data sd)
    : UU
    := ∏ (x y1 y2 : C) (g : C⟦y1,y2⟧),
       (sd x ⊗⊗^{DM}_{l} #sd g) ;; spt x y2
       =
       transportb
         _
         (id_right (x ⊗^{M}_{l} g) @ pathsinv0 (id_left (x ⊗^{M}_{l} g)))
         (spt x y1 ;; #sd (x ⊗^{M}_{l} g)).

  Lemma sectionfunctor_preserves_tensor_nat_left
        {sd : section_disp D}
        {spt : section_preserves_tensor_data sd}
        (sptnl : section_preserves_tensor_nat_left spt)
    : preserves_tensor_nat_left (sectionfunctor_preserves_tensordata spt).
  Proof.
    intros x y1 y2 g.
    use total2_paths_b.
    - cbn.
      rewrite id_left.
      apply id_right.
    - cbn.
      rewrite sptnl.
      apply transportb_transpose_left.
      rewrite transport_f_b.
      apply pathsinv0.
      apply transportf_set.
      apply homset_property.
  Qed.

  Definition section_preserves_tensor_nat_right
             {sd : section_disp D}
             (spt : section_preserves_tensor_data sd)
    : UU
    := ∏ (x1 x2 y : C) (f : C⟦x1,x2⟧),
       (#sd f ⊗⊗^{DM}_{r} sd y) ;; spt x2 y
       =
       transportb
         _
         (id_right (f ⊗^{M}_{r} y) @ pathsinv0 (id_left (f ⊗^{M}_{r} y)))
         (spt x1 y ;; #sd (f ⊗^{M}_{r} y)).

  Lemma sectionfunctor_preserves_tensor_nat_right
        {sd : section_disp D}
        {spt : section_preserves_tensor_data sd}
        (sptnl : section_preserves_tensor_nat_right spt)
    : preserves_tensor_nat_right (sectionfunctor_preserves_tensordata spt).
  Proof.
    intros x1 x2 y f.
    use total2_paths_b.
    - cbn.
      rewrite id_left.
      apply id_right.
    - cbn.
      rewrite sptnl.
      apply transportb_transpose_left.
      rewrite transport_f_b.
      apply pathsinv0.
      apply transportf_set.
      apply homset_property.
  Qed.

  (* This equality I should have somewhere, have to check in different files *)
  Definition equality_for_leftunitality
             (x : C)
    : identity I_{ M} ⊗^{ M}_{r} x · identity (I_{ M} ⊗_{ M} x) · lu^{ M }_{ x}
      =
      lu^{ M }_{ x}.
  Proof.
    rewrite assoc'.
    rewrite (bifunctor_rightid M).
    rewrite id_left.
    apply id_left.
  Qed.

  Definition section_preserves_leftunitality
             {sd : section_disp D}
             (spt : section_preserves_tensor_data sd)
             (spu : section_preserves_unit sd)
    : UU
    := ∏ (x : C),
       spu ⊗⊗^{ DM}_{r} sd x ;; spt I_{ M} x ;; # sd lu^{ M }_{ x}
       =
       transportb
         _
         (equality_for_leftunitality x)
         (dlu^{DM}_{sd x}).

  Definition sectionfunctor_preserves_leftunitality
             {sd : section_disp D}
             {spt : section_preserves_tensor_data sd}
             {spu : section_preserves_unit sd}
             (splu : section_preserves_leftunitality spt spu)
    : preserves_leftunitality
        (sectionfunctor_preserves_tensordata spt)
        (sectionfunctor_preserves_unit spu).
  Proof.
    intro x.
    use total2_paths_b.
    - cbn.
      rewrite assoc'.
      rewrite (bifunctor_rightid M).
      rewrite id_left.
      apply id_left.
    - cbn.
      rewrite splu.
      apply transportb_transpose_left.
      rewrite transport_f_b.
      apply pathsinv0.
      apply transportf_set.
      apply homset_property.
  Qed.

  (* This equality I should have somewhere, have to check in different files *)
  Definition equality_for_rightunitality (x : C)
    : x ⊗^{ M}_{l} identity I_{ M} · identity (x ⊗_{ M} I_{ M}) · ru^{ M }_{ x}
      =
      ru^{ M }_{ x}.
  Proof.
    rewrite assoc'.
    rewrite (bifunctor_leftid M).
    rewrite id_left.
    apply id_left.
  Qed.

  Definition section_preserves_rightunitality
             {sd : section_disp D}
             (spt : section_preserves_tensor_data sd)
             (spu : section_preserves_unit sd)
    : UU
    := ∏ (x : C),
       sd x ⊗⊗^{DM}_{l} spu ;; spt x I_{ M} ;; # sd ru^{ M }_{ x}
       =
       transportb
         _
         (equality_for_rightunitality x)
         (dru^{DM}_{sd x}).

  Definition sectionfunctor_preserves_rightunitality
             {sd : section_disp D}
             {spt : section_preserves_tensor_data sd}
             {spu : section_preserves_unit sd}
             (spru : section_preserves_rightunitality spt spu)
    : preserves_rightunitality
        (sectionfunctor_preserves_tensordata spt)
        (sectionfunctor_preserves_unit spu).
  Proof.
    intro x.
    use total2_paths_b.
    - cbn.
      rewrite assoc'.
      rewrite (bifunctor_leftid M).
      rewrite id_left.
      apply id_left.
    - cbn.
      rewrite spru.
      apply transportb_transpose_left.
      rewrite transport_f_b.
      apply pathsinv0.
      apply transportf_set.
      apply homset_property.
  Qed.

  (* This equality I should have somewhere, have to check in different files *)
  Definition equality_for_associativity
             (x y z : C)
    : identity (x ⊗_{ M} y) ⊗^{ M}_{r} z · identity ((x ⊗_{ M} y) ⊗_{ M} z) · α^{ M }_{ x, y, z}
      =
      α^{ M }_{ x, y, z} · x ⊗^{ M}_{l} identity (y ⊗_{ M} z) · identity (x ⊗_{ M} (y ⊗_{ M} z)).
  Proof.
    rewrite assoc'.
    rewrite (bifunctor_leftid M).
    rewrite id_left.
    rewrite id_right.
    rewrite id_right.
    rewrite (bifunctor_rightid M).
    apply id_left.
  Qed.

  Definition section_preserves_associativity
             {sd : section_disp D}
             (spt : section_preserves_tensor_data sd)
    : UU
    := ∏ (x y z : C),
       spt x y ⊗⊗^{ DM}_{r} sd z ;; spt (x ⊗_{ M} y) z ;; # sd α^{ M }_{ x, y, z}
       =
       transportb
         _
         (equality_for_associativity x y z)
         (dα^{ DM }_{ sd x, sd y, sd z} ;; sd x ⊗⊗^{ DM}_{l} spt y z ;; spt x (y ⊗_{ M} z)).

  Definition sectionfunctor_preserves_associativity
             {sd : section_disp D}
             {spt : section_preserves_tensor_data sd}
             (spa : section_preserves_associativity spt)
    : preserves_associativity (sectionfunctor_preserves_tensordata spt).
  Proof.
    intros x y z.
    use total2_paths_b.
    - cbn.
      rewrite assoc'.
      rewrite (bifunctor_leftid M).
      rewrite id_right.
      rewrite id_right.
      rewrite id_left.
      rewrite (bifunctor_rightid M).
      apply id_left.
    - cbn.
      rewrite spa.
      apply transportb_transpose_left.
      rewrite transport_f_b.
      apply pathsinv0.
      apply transportf_set.
      apply homset_property.
  Qed.

  Definition smonoidal_laxlaws {sd : section_disp D} (ms : smonoidal_data sd) : UU
    := (section_preserves_tensor_nat_left
          (smonoidal_preserves_tensor ms))
       × (section_preserves_tensor_nat_right
            (smonoidal_preserves_tensor ms))
       × (section_preserves_associativity
            (smonoidal_preserves_tensor ms))
       × (section_preserves_leftunitality
            (smonoidal_preserves_tensor ms)
            (smonoidal_preserves_unit ms))
       × (section_preserves_rightunitality
            (smonoidal_preserves_tensor ms)
            (smonoidal_preserves_unit ms)).

  Definition smonoidal_preserves_tensornatleft
             {sd : section_disp D}
             {ms : smonoidal_data sd}
             (msl : smonoidal_laxlaws ms)
    : section_preserves_tensor_nat_left (smonoidal_preserves_tensor ms)
    := pr1 msl.

  Definition smonoidal_preserves_tensornatright
             {sd : section_disp D}
             {ms : smonoidal_data sd}
             (msl : smonoidal_laxlaws ms)
    : section_preserves_tensor_nat_right (smonoidal_preserves_tensor ms)
    := pr1 (pr2 msl).

  Definition smonoidal_preserves_associativity
             {sd : section_disp D}
             {ms : smonoidal_data sd}
             (msl : smonoidal_laxlaws ms)
    : section_preserves_associativity (smonoidal_preserves_tensor ms)
    := pr1 (pr2 (pr2 msl)).

  Definition smonoidal_preserves_leftunitality
             {sd : section_disp D}
             {ms : smonoidal_data sd}
             (msl : smonoidal_laxlaws ms)
    : section_preserves_leftunitality
        (smonoidal_preserves_tensor ms)
        (smonoidal_preserves_unit ms)
    := pr1 (pr2 (pr2 (pr2 msl))).

  Definition smonoidal_preserves_rightunitality
             {sd : section_disp D}
             {ms : smonoidal_data sd}
             (msl : smonoidal_laxlaws ms)
    : section_preserves_rightunitality
        (smonoidal_preserves_tensor ms)
        (smonoidal_preserves_unit ms)
    := pr2 (pr2 (pr2 (pr2 msl))).

  Definition smonoidal_lax (sd : section_disp D) : UU
    := ∑ (ms : smonoidal_data sd), smonoidal_laxlaws ms.

  Definition smonoidal_sdata
             {sd : section_disp D}
             (sm : smonoidal_lax sd)
    : smonoidal_data sd := pr1 sm.

  Coercion smonoidal_sdata : smonoidal_lax >-> smonoidal_data.

  Definition smonoidal_slaxlaws
             {sd : section_disp D}
             (sm : smonoidal_lax sd)
    : smonoidal_laxlaws sm
    := pr2 sm.

  Definition sectionfunctor_fmonoidal_laxlaws
             {sd : section_disp D}
             {ms : smonoidal_data sd}
             (ml : smonoidal_laxlaws ms)
    : fmonoidal_laxlaws
        (sectionfunctor_fmonoidal_data
           (smonoidal_preserves_tensor ms)
           (smonoidal_preserves_unit ms))
    := (sectionfunctor_preserves_tensor_nat_left (smonoidal_preserves_tensornatleft ml),,
        sectionfunctor_preserves_tensor_nat_right (smonoidal_preserves_tensornatright ml),,
        sectionfunctor_preserves_associativity (smonoidal_preserves_associativity ml),,
        sectionfunctor_preserves_leftunitality (smonoidal_preserves_leftunitality ml),,
        sectionfunctor_preserves_rightunitality (smonoidal_preserves_rightunitality ml)).

  Definition sectionfunctor_fmonoidal_lax
             {sd : section_disp D}
             (ms : smonoidal_lax sd)
    : fmonoidal_lax M TM (section_functor sd)
    := (sectionfunctor_fmonoidal_data
          (smonoidal_preserves_tensor ms)
          (smonoidal_preserves_unit ms)
        ,,
        sectionfunctor_fmonoidal_laxlaws (smonoidal_slaxlaws ms)).

  (* We now define a strong monoidal section and show that each such section induces a strong monoidal functor *)
  Definition smonoidal_strongtensor
             {sd : section_disp D}
             (spt : section_preserves_tensor_data sd)
    : UU
    := ∏ (x y : C),
       is_z_iso_disp
         (identity_z_iso (x⊗_{M} y))
         (spt x y).

  Definition smonoidal_strongunit
             {sd : section_disp D}
             (spu : section_preserves_unit sd)
    : UU
    := is_z_iso_disp
         (identity_z_iso (I_{M}))
         spu.

  Definition smonoidal_stronglaws
             {sd : section_disp D}
             (ms : smonoidal_data sd)
    : UU
    := smonoidal_strongtensor (smonoidal_preserves_tensor ms)
       ×
       smonoidal_strongunit (smonoidal_preserves_unit ms).

  Definition smonoidal (sd : section_disp D) : UU
    := ∑ (ms : smonoidal_lax sd), smonoidal_stronglaws ms.

  Definition smonoidal_smonoidallax
             {sd : section_disp D}
             (sm : smonoidal sd)
    : smonoidal_lax sd
    := pr1 sm.
  Coercion smonoidal_smonoidallax : smonoidal >-> smonoidal_lax.

  Definition smonoidal_smonoidalstronglaws
             {sd : section_disp D}
             (sm : smonoidal sd)
    : smonoidal_stronglaws sm
    := pr2 sm.

  Definition smonoidal_smonoidalstrongtensor
             {sd : section_disp D}
             (sm : smonoidal sd)
    : smonoidal_strongtensor (smonoidal_preserves_tensor sm)
    := pr1 (smonoidal_smonoidalstronglaws sm).

  Definition smonoidal_smonoidalstrongunit
             {sd : section_disp D}
             (sm : smonoidal sd)
    : smonoidal_strongunit (smonoidal_preserves_unit sm)
    := pr2 (smonoidal_smonoidalstronglaws sm).

  Definition sectionfunctor_preservestensorstrongly
             {sd : section_disp D}
             {ms : smonoidal sd}
             (pfstrong : smonoidal_strongtensor (smonoidal_preserves_tensor ms))
    : preserves_tensor_strongly
        (sectionfunctor_preserves_tensordata
           (smonoidal_preserves_tensor ms)).
  Proof.
    intros x y.
    use tpair.
    - use tpair.
      + apply identity.
      + exact (pr1 (pfstrong x y)).
    - use tpair.
      + use total2_paths_b.
        * apply id_left.
        * apply (pr2 (pr2 (pfstrong x y))).
      + use total2_paths_b.
        * apply id_left.
        * apply (pr1 (pr2 (pfstrong x y))).
  Defined.

  Definition sectionfunctor_preservesunitstrongly
             {sd : section_disp D}
             {ms : smonoidal sd}
             (pfstrong : smonoidal_strongunit (smonoidal_preserves_unit ms))
    : preserves_unit_strongly
        (sectionfunctor_preserves_unit (smonoidal_preserves_unit ms)).
  Proof.
    use tpair.
    - use tpair.
      + apply identity.
      + exact (pr1 pfstrong).
    - use tpair.
      + use total2_paths_b.
        * apply id_left.
        * apply (pr22 pfstrong).
      + use total2_paths_b.
        * apply id_left.
        * apply (pr1 (pr2 pfstrong)).
  Defined.

  Definition sectionfunctor_fmonoidal
             {sd : section_disp D}
             (ms : smonoidal sd)
    : fmonoidal M TM (section_functor sd)
    := (sectionfunctor_fmonoidal_lax ms ,,
        sectionfunctor_preservestensorstrongly (smonoidal_smonoidalstrongtensor ms) ,,
        sectionfunctor_preservesunitstrongly (smonoidal_smonoidalstrongunit ms)).
End MonoidalSections.


Require Export GeoCoq.Elements.OriginalProofs.euclidean_tactics.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_TCreflexive :
   forall A B C,
   Triangle A B C ->
   Cong_3 A B C A B C.
Proof.
intros.
assert (Cong A B A B) by (conclude cn_congruencereflexive).
assert (Cong B C B C) by (conclude cn_congruencereflexive).
assert (Cong A C A C) by (conclude cn_congruencereflexive).
assert (Cong_3 A B C A B C) by (conclude_def Cong_3 ).
close.
Qed.

End Euclid.


Require Export desargues2Dmore.
Require Export desargues3Dspecial.

Module DesarguesxD (DecPoints: FSetInterface.WS) (M: RankProjectiveSpace DecPoints).

Module Export Desargues_2D := Desargues2Dfinal2 DecPoints M.
Module Export Desargues_3D := Desargues3Dspecial DecPoints M.

Section desargues_theorem.
Variables A' B' C' : Point.
Variables A B C : Point.

Variables O : Point.

Variable rABC : rk(triple A B C)=3.
Variable rA'B'C' : rk(triple A' B' C')=3.

Variable rABO : rk(triple A B O)=3.
Variable rACO :rk(triple A C O)=3.
Variable rBCO : rk (triple B C O)=3.

Variable rAA'O : rk(triple A A' O)=2.
Variable rBB'O : rk(triple B B' O)=2.
Variable rCC'O : rk(triple C C' O)=2.

Variable rAA' : rk(couple A A')=2.
Variable rBB' : rk(couple B B')=2.
Variable rCC' : rk(couple C C')=2.

Variables alpha beta gamma : Point.

Variable rABgamma : rk(triple A B gamma)=2.
Variable rA'B'gamma : rk(triple A' B' gamma)=2.

Variable rACbeta : rk(triple A C beta)=2.
Variable rA'C'beta : rk(triple A' C' beta)=2.

Variable rBCalpha : rk(triple B C alpha)=2.
Variable rB'C'alpha : rk(triple B' C' alpha) =2.

Lemma Desargues_xD : rk (triple alpha beta gamma) <= 2.
Proof.
assert  (rk(union (triple A B C) (triple A' B' C'))=3 \/
rk(union (triple A B C) (triple A' B' C'))>=4).
assert (rk(union (triple A B C) (triple A' B' C'))>=3).
rewrite <- rABC.
apply matroid2; fsetdecide_no_hyps.
omega.
elim H.
intro rABCA'B'C'.
assert (rk(union (triple A B C) (union (triple A' B' C') (singleton O)))=3 ).
clear H.
apply le_antisym.
setoid_replace (union (triple A B C) (union (triple A' B' C') (singleton O))) with
(add O (union (triple A B C) (triple A' B' C'))) by fsetdecide_no_hyps.
apply (stays_in_plane (union (triple A B C) (triple A' B' C')) A A' O); auto.
omega.
fsetdecide_no_hyps.
fsetdecide_no_hyps.
rewrite <- rABC.
apply matroid2; fsetdecide_no_hyps.
rename H0 into rABCA'B'C'O.

eapply (Desargues_plane A' B' C' A B C O);assumption.

intro.
eapply (Desargues A B C A' B' C' alpha beta gamma O); auto.
setoid_replace (union (triple A' B' C') (triple A B C)) with (union (triple A B C) (triple A' B' C')) by (unfold Equal; split; fsetdecide_no_hyps).
omega.
Qed.

End desargues_theorem.

Lemma Desargues_xD'
     : forall A' B' C' A B C O0 : Point,
       rk (triple A B C) = 3 ->
       rk (triple A' B' C') = 3 ->
       rk (triple A B O0) = 3 ->
       rk (triple A C O0) = 3 ->
       rk (triple B C O0) = 3 ->
       rk (triple A A' O0) = 2 ->
       rk (triple B B' O0) = 2 ->
       rk (triple C C' O0) = 2 ->
       rk (couple A A') = 2 ->
       rk (couple B B') = 2 ->
       rk (couple C C') = 2 ->
       forall alpha beta gamma : Point,
       rk (triple A B gamma) = 2 ->
       rk (triple A' B' gamma) = 2 ->
       rk (triple A C beta) = 2 ->
       rk (triple A' C' beta) = 2 ->
       rk (triple B C alpha) = 2 ->
       rk (triple B' C' alpha) = 2 -> rk (triple alpha beta gamma) <= 2.
exact Desargues_xD.
Qed.

End DesarguesxD.


Require Import IFOL.Util.RHVec.
Require Import IFOL.Util.Witness.
Require Import IFOL.Syntax.Signature.

Definition sort_dom S : Type := S -> Type.

Definition f_sym_dom {S} (eval_S : sort_dom S) (f : f_arity S) : Type :=
  RHVec eval_S (f_args f) -> eval_S (f_out f).

Definition f_sig_dom {S} (eval_S : sort_dom S) (f_sg : f_sig S) : Type :=
  forall (f : f_symbols f_sg), f_sym_dom eval_S (f_arities f).

Definition r_sym_dom {S} (eval_S : sort_dom S) (r : r_arity S) : Type :=
  RHVec eval_S (r_args r) -> Prop.

Definition r_sig_dom {S} (eval_S : sort_dom S) (r_sg : r_sig S) : Type :=
  forall (r : r_symbols r_sg), r_sym_dom eval_S (r_arities r).

Record sig_dom {S} (eval_S : sort_dom S) (sg : sig S) : Type := {
  func_dom : f_sig_dom eval_S (func sg);
  rel_dom : r_sig_dom eval_S (rel sg)
  }.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=   Cons : natural -> lst -> lst | Nil : lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rotate (rotate_arg0 : natural) (rotate_arg1 : lst) : lst
           := match rotate_arg0, rotate_arg1 with
              | Zero, x => x
              | Succ n, Nil => Nil
              | Succ n, Cons y x => rotate n (append x (Cons y Nil))
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.

Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rotate (len x) (append x y)) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite append_assoc.
      rewrite IHx. lfind. Admitted.