From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable tP_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable supp_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable rT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable midpoint_ : Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable eF_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_NCdistinct_1 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable proposition_10_2 : (forall A B : Universe, (exists X : Universe, (A <> B -> (betS_ A X B /\ cong_ X A X B)))).
Variable lemma_congruenceflip_3 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable defmidpoint_4 : (forall A B C : Universe, (midpoint_ A B C -> (betS_ A B C /\ cong_ A B B C))).
Variable defmidpoint2_5 : (forall A B C : Universe, ((betS_ A B C /\ cong_ A B B C) -> midpoint_ A B C)).
Variable lemma_betweennotequal_6 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_extension_7 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable deftriangle_8 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_9 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable lemma_inequalitysymmetric_10 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_congruencesymmetric_11 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruencetransitive_12 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable axiom_betweennesssymmetry_13 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable defcollinear_14 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_15 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_16 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_17 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_18 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_19 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_20 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinear4_21 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_collinearorder_22 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_NCorder_23 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable lemma_NChelper_24 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable proposition_42B_25 : (forall B C D E J K R Xa Xb Xc Xe : Universe, (exists X Z : Universe, ((triangle_ Xa Xb Xc /\ (midpoint_ Xb Xe Xc /\ (~(col_ J D K) /\ (midpoint_ B E C /\ (cong_ E C Xe Xc /\ ~(col_ R E C)))))) -> (pG_ X E C Z /\ (eF_ Xa Xb Xe Xc X E C Z /\ (congA_ C E X J D K /\ oS_ R X E C)))))).
Variable defparallelogram_26 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_27 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable lemma_parallelNC_28 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Variable proposition_44_29 : (forall A B D J N R Xa Xb Xc : Universe, (exists X Y Z : Universe, ((triangle_ Xa Xb Xc /\ (~(col_ J D N) /\ ~(col_ A B R))) -> (pG_ A B X Y /\ (congA_ A B X J D N /\ (eF_ Xa Xb Z Xc A B X Y /\ (midpoint_ Xb Z Xc /\ tS_ X A B R))))))).
Variable lemma_equalanglessymmetric_30 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_equalanglestransitive_31 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_parallelflip_32 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable lemma_parallelsymmetric_33 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).
Variable lemma_paralleldef2B_34 : (forall A B C D : Universe, (par_ A B C D -> tP_ A B C D)).
Variable deftarski_parallel_35 : (forall A B C D : Universe, (tP_ A B C D -> (A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))))).
Variable deftarski_parallel2_36 : (forall A B C D : Universe, ((A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))) -> tP_ A B C D)).
Variable proposition_29C_37 : (forall B D E G H : Universe, ((par_ G B H D /\ (oS_ B D G H /\ betS_ E G H)) -> (congA_ E G B G H D /\ rT_ B G H G H D))).
Variable lemma_equalanglesNC_38 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable lemma_ABCequalsCBA_39 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_RTcongruence_40 : (forall A B C D E F P Q R : Universe, ((rT_ A B C D E F /\ congA_ A B C P Q R) -> rT_ P Q R D E F)).
Variable lemma_RTsymmetric_41 : (forall A B C D E F : Universe, (rT_ A B C D E F -> rT_ D E F A B C)).
Variable lemma_ray4_1_42 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_43 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_44 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable proposition_14_45 : (forall A B C D E : Universe, ((rT_ A B C D B E /\ (out_ B C D /\ tS_ E D B A)) -> (supp_ A B C D E /\ betS_ A B E))).
Variable proposition_30_46 : (forall A B C D E F G H K : Universe, ((par_ A B E F /\ (par_ C D E F /\ (betS_ G H K /\ (col_ A B G /\ (col_ E F H /\ (col_ C D K /\ (A <> G /\ (E <> H /\ C <> K)))))))) -> par_ A B C D)).
Variable lemma_collinearparallel_47 : (forall A B C Xc Xd : Universe, ((par_ A B Xc Xd /\ (col_ Xc Xd C /\ C <> Xd)) -> par_ A B C Xd)).
Variable lemma_Playfair_48 : (forall A B C D E : Universe, ((par_ A B C D /\ par_ A B C E) -> col_ C D E)).
Variable lemma_ray5_49 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_equalanglesreflexive_50 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_equalangleshelper_51 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable defoppositeside_52 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_53 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_planeseparation_54 : (forall A B C D E : Universe, ((oS_ C D A B /\ tS_ D A B E) -> tS_ C A B E)).
Variable lemma_oppositesidesymmetric_55 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ Q A B P)).
Variable lemma_diagonalsmeet_56 : (forall A B C D : Universe, (exists X : Universe, (pG_ A B C D -> (betS_ A X C /\ betS_ B X D)))).
Variable axiom_paste4_57 : (forall A B C D F G H J K L M P Ce Cm : Universe, ((eF_ A B Cm D F K H G /\ (eF_ D B Ce C G H M L /\ (betS_ A P C /\ (betS_ B P D /\ (betS_ K H M /\ (betS_ F G L /\ (betS_ B Cm D /\ (betS_ B Ce C /\ (betS_ F J M /\ betS_ K J L))))))))) -> eF_ A B C D F K M L)).
Variable axiom_EFsymmetric_58 : (forall A B C D Ca Cb Cc Cd : Universe, (eF_ A B C D Ca Cb Cc Cd -> eF_ Ca Cb Cc Cd A B C D)).
Variable lemma_3_7b_59 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ B C D) -> betS_ A B D)).
Variable defray_60 : (forall A B C : Universe, (exists X : Universe, (out_ A B C -> (betS_ X A C /\ betS_ X A B)))).
Variable defray2_61 : (forall A B C X : Universe, ((betS_ X A C /\ betS_ X A B) -> out_ A B C)).
Variable lemma_samesidesymmetric_62 : (forall A B P Q : Universe, (oS_ P Q A B -> (oS_ Q P A B /\ (oS_ P Q B A /\ oS_ Q P B A)))).
Variable lemma_samesidecollinear_63 : (forall A B C P Q : Universe, ((oS_ P Q A B /\ (col_ A B C /\ A <> C)) -> oS_ P Q A C)).

Theorem proposition_45_64 : (forall A B C D E J K N O R S : Universe, (exists X Z U : Universe, ((~(col_ J E N) /\ (~(col_ A B D) /\ (~(col_ C B D) /\ (betS_ A O C /\ (betS_ B O D /\ (R <> K /\ ~(col_ K R S))))))) -> (pG_ X K Z U /\ (congA_ X K Z J E N /\ (eF_ X K Z U A B C D /\ (out_ K R Z /\ oS_ X S K Z))))))).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Game.
Require Import BaseGame.
Require Import TurnGame.

Definition card_value:Type := { v:nat | (v >= 2 /\ v <= 14) }.
Inductive card_suit :Type := | heart:card_suit | club:card_suit | diamond:card_suit | spades:card_suit.
Definition card:Type := card_value * card_suit.

Definition bounded_nat (bound:nat) : Type := {x:nat | x < bound}.
Definition get_nat (bound:nat) (x:bounded_nat bound) :=
  match x with
  | exist _ n _ => n
  end.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf1 : natural) (lf2 : natural) : natural := lf1.


Require Import DschingisKhan.Prelude.PreludeInit.
Require Import DschingisKhan.Prelude.PreludeMath.
Require Import DschingisKhan.Prelude.PreludeUtil.

Module ExcludedMiddle.

  Axiom classic : forall P : Prop, P \/ ~ P.

  Lemma NNPP (P : Prop)
    (NNP : ~ ~ P)
    : P.
  Proof. pose proof (classic P) as [? | ?]; [trivial | contradiction NNP]. Qed.

  Lemma proof_irrelevance (P : Prop)
    : pirrel_STMT P.
  Proof. eapply exclusive_middle_implies_proof_irrelevance; exact classic. Qed.

  Lemma projT2_eq (A : Type) (B : A -> Type) (x : A)
    : projT2_eq_STMT A B x.
  Proof. eapply eq_rect_eq_iff_projT2_eq, pirrel_iff_eq_rect_eq, proof_irrelevance. Qed.

End ExcludedMiddle.


Require Export FunctorCategory Category.Product.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope functor_scope.

Section Law4.
  Context `{Funext}.
  Variable C1 : PreCategory.
  Variable C2 : PreCategory.
  Variable D : PreCategory.

  Local Open Scope morphism_scope.

  Local Ltac do_exponential4_helper rew_comp :=
    intros; simpl;
    repeat (simpl;
            match goal with
              | _ => reflexivity
              | _ => progress rew_comp
              | _ => rewrite !FIdentityOf
              | _ => rewrite !LeftIdentity
              | _ => rewrite !RightIdentity
              | _ => try_associativity_quick ltac:(f_ap)
              | _ => rewrite !Commutes
              | _ => try_associativity_quick ltac:(rewrite !Commutes)
            end).

  Section functor.
    Local Ltac do_exponential4
      := do_exponential4_helper ltac:(rewrite !FCompositionOf).

    Definition ExponentialLaw4Functor_ObjectOf
    : [C1, [C2, D]]%category -> [C1 * C2, D]%category.
    Proof.
      intro F; hnf in F |- *.
      refine (Build_Functor
                (C1 * C2) D
                (fun c1c2 => F (fst c1c2) (snd c1c2))
                (fun s d m => F (fst d) ₁ (snd m) ∘ (F ₁ (fst m)) (snd s))
                _
                _);
        abstract do_exponential4.
    Defined.

    Definition ExponentialLaw4Functor_MorphismOf
               s d (m : Morphism [C1, [C2, D]] s d)
    : Morphism [C1 * C2, D]
               (ExponentialLaw4Functor_ObjectOf s)
               (ExponentialLaw4Functor_ObjectOf d).
    Proof.
      simpl.
      refine (Build_NaturalTransformation
                (ExponentialLaw4Functor_ObjectOf s)
                (ExponentialLaw4Functor_ObjectOf d)
                (fun c => m (fst c) (snd c))
                _);
        abstract (
            repeat match goal with
                     | [ |- appcontext[ComponentsOf ?T ?x ∘ ComponentsOf ?U ?x] ] =>
                       change (T x ∘ U x) with ((Compose (C := [_, _]) T U) x)
                     | _ => f_ap
                     | _ => rewrite !Commutes
                     | _ => do_exponential4
                   end
          ).
    Defined.

    Definition ExponentialLaw4Functor
    : Functor [C1, [C2, D]] [C1 * C2, D].
    Proof.
      refine (Build_Functor
                [C1, [C2, D]] [C1 * C2, D]
                ExponentialLaw4Functor_ObjectOf
                ExponentialLaw4Functor_MorphismOf
                _
                _);
      abstract by nt_eq.
    Defined.
  End functor.

  Section inverse.
    Local Ltac do_exponential4_inverse
      := do_exponential4_helper ltac:(rewrite <- !FCompositionOf).

    Section ObjectOf.
      Variable F : Functor (C1 * C2) D.

      Definition ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf
      : C1 -> [C2, D]%category.
      Proof.
        intro c1.
        refine (Build_Functor
                  C2 D
                  (fun c2 => F (c1, c2))
                  (fun s2 d2 m2 => F.(MorphismOf) (s := (c1, s2)) (d := (c1, d2)) (Identity c1, m2))
                  _
                  _);
          abstract do_exponential4_inverse.
      Defined.

      Definition ExponentialLaw4Functor_Inverse_ObjectOf_MorphismOf
                 s d (m : Morphism C1 s d)
      : Morphism [C2, D]
                 (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf s)
                 (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf d).
      Proof.
        refine (Build_NaturalTransformation
                  (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf s)
                  (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf d)
                  (fun c => F.(MorphismOf) (s := (s, c)) (d := (d, c)) (m, Identity c))
                  _);
        abstract do_exponential4_inverse.
      Defined.

      Definition ExponentialLaw4Functor_Inverse_ObjectOf
      : [C1, [C2, D]]%category.
      Proof.
        refine (Build_Functor
                  C1 [C2, D]
                  ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf
                  ExponentialLaw4Functor_Inverse_ObjectOf_MorphismOf
                  _
                  _);
        abstract (nt_eq; do_exponential4_inverse).
      Defined.
    End ObjectOf.

    Section MorphismOf.
      Definition ExponentialLaw4Functor_Inverse_MorphismOf_ComponentsOf
                 s d (m : Morphism [C1 * C2, D] s d)
      : forall c, Morphism [C2, D]
                           ((ExponentialLaw4Functor_Inverse_ObjectOf s) c)
                           ((ExponentialLaw4Functor_Inverse_ObjectOf d) c).
      Proof.
        intro c.
        refine (Build_NaturalTransformation
                  ((ExponentialLaw4Functor_Inverse_ObjectOf s) c)
                  ((ExponentialLaw4Functor_Inverse_ObjectOf d) c)
                  (fun c' => m (c, c'))
                  _).
        abstract do_exponential4_inverse.
      Defined.

      Definition ExponentialLaw4Functor_Inverse_MorphismOf
                 s d (m : Morphism [C1 * C2, D] s d)
      : Morphism [C1, [C2, D]]
                 (ExponentialLaw4Functor_Inverse_ObjectOf s)
                 (ExponentialLaw4Functor_Inverse_ObjectOf d).
      Proof.
        refine (Build_NaturalTransformation
                  (ExponentialLaw4Functor_Inverse_ObjectOf s)
                  (ExponentialLaw4Functor_Inverse_ObjectOf d)
                  (ExponentialLaw4Functor_Inverse_MorphismOf_ComponentsOf m)
                  _).
        abstract (nt_eq; do_exponential4_inverse).
      Defined.
    End MorphismOf.

    Arguments ExponentialLaw4Functor_Inverse_MorphismOf_ComponentsOf / _ _ _ _ .

    Definition ExponentialLaw4Functor_Inverse
    : Functor [C1 * C2, D] [C1, [C2, D]].
    Proof.
      refine (Build_Functor
                [C1 * C2, D] [C1, [C2, D]]
                ExponentialLaw4Functor_Inverse_ObjectOf
                ExponentialLaw4Functor_Inverse_MorphismOf
                _
                _);
      abstract by nt_eq.
    Defined.
  End inverse.
End Law4.


Require Import Coq.omega.Omega.
Require Import MathClasses.interfaces.abstract_algebra MathClasses.theory.ua_packed.
Require MathClasses.interfaces.universal_algebra MathClasses.varieties.monoids.

Notation msig := varieties.monoids.sig.
Notation Op := (universal_algebra.Op msig False).
Notation App := (universal_algebra.App msig False _ _).

Import universal_algebra.

Section contents.
  (* Ideally, we would like to operate exclusively on the universal term representation(s).
   If Coq had decent support for dependent pattern matching, this would be no problem.
   Unfortunately, Coq does not, and so we resort to defining an ad-hoc data type for
   monoidal expressions, with nasty conversions to and from the universal term
   representation(s): *)

  Context (V: Type).

  Notation uaTerm := (universal_algebra.Term0 msig V tt).
  Notation Applied := (@ua_packed.Applied msig V tt).

  Inductive Term := Var (v: V) | Unit | Comp (x y: Term).

  Fixpoint to_ua (e: Term): Applied :=
    match e with
    | Var v => ua_packed.AppliedVar msig v tt
    | Unit => ua_packed.AppliedOp msig monoids.one (ua_packed.NoMoreArguments msig tt)
    | Comp x y => ua_packed.AppliedOp msig monoids.mult
       (MoreArguments msig tt _ (to_ua x) (MoreArguments msig tt _ (to_ua y) (NoMoreArguments msig tt)))
    end.

  Definition from_ua (t: Applied): { r: Term | to_ua r ≡ t }.
  Proof with reflexivity.
    refine (better_Applied_rect msig (λ s,
       match s return (ua_packed.Applied msig s → Type) with
       | tt => λ t, {r : Term | to_ua r ≡ t}
       end) _ _ t).
    simpl.
    intros []; simpl.
     intros.
     exists (Comp (` (fst (forallSplit msig _ _ X)))
       (` ((fst (forallSplit msig _ _ (snd (forallSplit msig _ _ X))))))).
     do 3 dependent destruction x.
     simpl in *.
     destruct X. destruct p, s. destruct s0.
     simpl. subst...
    exists Unit.
    dependent destruction x...
   intros v [].
   exists (Var v)...
  Defined.

  Fixpoint measure (e: Term): nat :=
    match e with
    | Var v => 0%nat
    | Unit => 1%nat
    | Comp x y => S (2 * measure x + measure y)
    end.

  Context `{Monoid M}.

  Notation eval vs := (universal_algebra.eval msig (λ _, (vs: V → M))).

  Program Fixpoint internal_simplify (t: Term) {measure (measure t)}:
      { r: Term | ∀ v, eval v (curry (to_ua r)) = eval v (curry (to_ua t)) } :=
    match t with
    | Var _ => t
    | Unit => t
    | Comp Unit y => internal_simplify y
    | Comp x Unit => internal_simplify x
    | Comp ((Var _) as x) y => Comp x (internal_simplify y)
    | Comp (Comp x y) z => internal_simplify (Comp x (Comp y z))
    end.

  Solve Obligations with (program_simpl; simpl; try apply reflexivity; omega).

  Next Obligation.
   destruct internal_simplify.
   simpl.
   rewrite e.
   transitivity (mon_unit & universal_algebra.eval msig (λ _, v) (curry (to_ua y))).
    symmetry.
    apply left_identity.
   reflexivity.
  Qed.

  Next Obligation.
   destruct internal_simplify.
   simpl.
   rewrite e.
   transitivity (universal_algebra.eval msig (λ _, v) (curry (to_ua x)) & mon_unit).
    symmetry.
    apply right_identity.
   reflexivity.
  Qed.

  Next Obligation. destruct internal_simplify. simpl. rewrite e. reflexivity. Qed.
  Next Obligation. destruct internal_simplify. simpl. rewrite e. simpl. apply associativity. Qed.

  Program Definition simplify (t: uaTerm): { r: uaTerm | ∀ v, eval v r = eval v t } :=
    curry (to_ua (internal_simplify (from_ua (decode0 t)))).

  Next Obligation.
   destruct @internal_simplify. simpl.
   destruct @from_ua in e. simpl in *.
   rewrite e.
   rewrite e0.
   rewrite @curry_decode0.
   reflexivity.
  Qed.

  (* This would be a nice theorem to prove:

  Require varieties.open_terms.

  Instance: Equiv V := eq.

  Goal ∀ (x y: uaTerm), open_terms.ee msig msig monoids.Laws (ne_list.one tt) x y →
   ` (simplify x) ≡ ` (simplify y).
  Proof.

  *)

End contents.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e416m2e208m1_7limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Morphisms Base.

Definition cup x y := union (pair x y).

Instance Proper_cup : Proper (V_eq ==> V_eq ==> V_eq) cup.
Proof.
unfold cup; repeat intro; repeat f_equiv; assumption.
Qed.

Lemma cup_spec : forall x y z, z ∈ cup x y <-> z ∈ x \/ z ∈ y.
Proof.
intros x y z; split; intro H.
+ apply union_spec in H; destruct H as [u [Hu Hm]].
  apply pair_spec in Hm; destruct Hm as [Hm|Hm];
  rewrite <- Hm; intuition.
+ apply union_spec; destruct H as [Hm|Hm].
  - exists x; split; [assumption|apply pair_spec; left; reflexivity].
  - exists y; split; [assumption|apply pair_spec; right; reflexivity].
Qed.

Lemma cup_idem : forall x, cup x x ≅ x.
Proof.
intros x; apply extensionality; apply included_spec; intros z Hz.
+ apply cup_spec in Hz; intuition.
+ apply cup_spec; intuition.
Qed.

Definition cap x y := comprehension x (fun z => z ∈ y).

Instance Proper_cap : Proper (V_eq ==> V_eq ==> V_eq) cap.
Proof.
intros x1 x2 Hx y1 y2 Hy; unfold cap; f_equiv; [assumption|].
intros z1 z2 Hz; rewrite Hy, Hz; reflexivity.
Qed.

Lemma cap_spec : forall x y z, z ∈ cap x y <-> (z ∈ x /\ z ∈ y).
Proof.
intros x y z; split; intros H.
+ apply comprehension_spec in H; [|intros x1 x2 Hx; rewrite Hx; reflexivity].
  assumption.
+ apply comprehension_spec; [|assumption].
  intros x1 x2 Hx; rewrite Hx; reflexivity.
Qed.


Require Import Eqdep_dec.
Require Import EquivDec.

Section Classes.
  Context {A : Type}.
  Context {dec : EqDec A (@eq A)}.

  Theorem UIP_refl : forall {x : A} (p1 : x = x), p1 = refl_equal _.
    intros.
    eapply UIP_dec. apply equiv_dec.
  Qed.

  Theorem UIP_equal : forall {x y : A} (p1 p2 : x = y), p1 = p2.
    eapply UIP_dec. apply equiv_dec.
  Qed.

  Lemma inj_pair2 :
    forall (P:A -> Type) (p:A) (x y:P p),
      existT P p x = existT P p y -> x = y.
  Proof.
    intros. eapply inj_pair2_eq_dec; auto.
  Qed.

End Classes.

Global Instance option_eqdec T (_ : EqDec T (@eq T)) : EqDec (option T) (@eq (option T)).
  red; refine (
  fun a b =>
    match a, b with
      | None, None => left (refl_equal _)
      | Some a, Some b => match equiv_dec a b with
                            | left pf => left match (pf : a = b) in _ = t return Some a = Some t with
                                                | refl_equal => refl_equal
                                              end
                            | right pf => right (fun pf' => pf _)
                          end
      | None , Some _ => right _
      | Some _ , None => right _
    end).
  inversion pf'; reflexivity.
  abstract (intro; congruence).
  abstract (intro; congruence).
Defined.

(*
Global Instance list_eqdec T (_ : EqDec T (@eq T)) : EqDec (list T) (@eq (list T)).
  red; refine (
  fun a b =>
    match a, b with
      | None, None => left (refl_equal _)
      | Some a, Some b => match equiv_dec a b with
                            | left pf => left _
                            | right pf => right _
                          end
      | _ , _ => right _
    end).
  abstract (rewrite pf; reflexivity).
  abstract (intro H; apply pf; inversion H; reflexivity).
  abstract (intro; congruence).
  abstract (intro; congruence).
Defined.
*)

Ltac notVar X :=
  match X with
    | _ _ => idtac
    | _ _ _ => idtac
    | _ _ _ _ => idtac
    | _ _ _ _ _ => idtac
    | _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ _ _ _ => idtac
  end.

Ltac uip_all :=
  repeat match goal with
           | [ H : _ = _ |- _ ] => rewrite H
           | [ |- context [ match ?X in _ = t return _ with
                              | refl_equal => _
                            end ] ] => notVar X; generalize X
           | [ |- context [ eq_rect_r _ _ ?X ] ] => notVar X; generalize X
         end;
  intros;
    repeat match goal with
             | [ H : ?X = ?X |- _ ] => rewrite (UIP_refl H) in *
           end.

Require Export EquivDec.


Require Utf8.

Require Import S00_setoid_basics.

Inductive Identity {A: Set}(x: A) : A -> Set
  := Identity_refl : Identity x x.

Notation "x == y" := (Identity x y)
                       (at level 70, no associativity, only parsing).

Notation "x =={ A } y" := (@Identity A x y)
                            (at level 70, no associativity, only parsing).

Definition rfl {A : Set}{x : A} : x == x
  := Identity_refl x.

Theorem Identity_congr {A B: Set}(f:A -> B)(x y:A):
Identity x y -> Identity (f x) (f y).
Proof.
  intro P. destruct P. apply rfl.
Defined.

Definition Identity_trans  {A: Set}{a b c:A}:
Identity a b -> Identity b c -> Identity a c.
  intros p q. destruct p. apply q.
Defined.

Definition Identity_sym  {A: Set}{a b:A}:
Identity a b -> Identity b a.
  intros p. destruct p. apply rfl.
Defined.

Notation "p ⁻¹" := (Identity_sym p)
                     (at level 3, no associativity).

Notation "p ⊙ᵐ q" := (Identity_trans p q)
                      (at level 34, right associativity).

Notation "f ↱ᵐ p" := (Identity_congr f _ _ p)
                      (at level 100).

Definition ap {A B : Set}{f : A → B}{x x' : A}
  : x == x' → f x == f x'
  := Identity_congr f x x'.

Definition setcmp {A B C : Set}
  : (A → B) → (B → C) → A → C
  := fun f g x => g (f x).

Notation "g · f" := (setcmp f g) (at level 34, right associativity).

Definition transp {A : Set}(B : A → Set){x x' : A} :
  x == x' → B x → B x'.

  intro p. destruct p. apply (λ y, y).
Defined.

Notation "B •ᵐ p" := (transp B p)
                      (at level 9, right associativity).

Definition Identity_congr_dep {A : Set}(B : A → Set)
           (f : ∀ x, B x){x x' : A} :
  ∀ u : x == x', (B•ᵐu (f x)) == (f x').

  intro u. destruct u. apply Identity_refl.
Defined.

Notation "f ↱ᵈᵐ p" := (Identity_congr_dep _ f p)
                        (at level 100).

Definition HIdΠ {A : Set}{B : A → Set}(f f' : ∀ x : A, B x) : Set :=
  ∀ x, f x == f' x.

Definition Id2HΠ {A : Set}{B : A → Set}{f f' : ∀ x : A, B x} :
  f == f' → HIdΠ f f'.

intro p. destruct p. unfold HIdΠ. apply (λ x, Identity_refl (f x)).
Defined.

Definition transpCongr {A : Set}{B : A → Set}{x x' : A}(p : x == x'){y y' : B x}
  : y == y' → B•ᵐp y == B•ᵐp y'.

  intros q. destruct p. apply q.
Defined.

Definition transpIsFunct {A : Set}{B : A → Set}{x x' x'' : A}
           (p : x == x')(q : x' == x'') :
  B•ᵐ(p⊙ᵐq) == B•ᵐq · B•ᵐp.

  destruct p. apply Identity_refl.
Defined.

Definition transpfunct {A : Set}{B : A → Set}{x x' x'' : A}
           (p : x == x')(q : x' == x'')
  : ∀ y y', (B•ᵐq · B•ᵐp) y == y' → B•ᵐ(p⊙ᵐq) y == y'.

  intros y y' r. apply (Identity_trans (b := (B•ᵐq · B•ᵐp) y)).
  apply (Id2HΠ (transpIsFunct p q) y). apply r.
  (*destruct p. apply r.*)
Defined.

Definition transpfunct_rev {A : Set}{B : A → Set}{x x' x'' : A}
           (p : x == x')(q : x' == x''){y : B x}{y' : B x''}
  : B•ᵐ(p⊙ᵐq) y == y' → (B•ᵐq · B•ᵐp) y == y'.

  intros r. apply (Identity_trans (b := B•ᵐ(p⊙ᵐq) y)).
  apply Identity_sym. apply (Id2HΠ (transpIsFunct p q) y).
  apply r.
Defined.

Definition transpEq {A : Set}(B : A → Set){x x' : A}
           (p p' : x == x')(h : p == p') :
  B•ᵐp == B•ᵐp'.

  apply ((λ u, B•ᵐu)↱ᵐh).
Defined.

Definition transpIsEqv1 {A : Set}(B : A → Set){x x' : A}
           (p : x == x') :
  ∀ y, B•ᵐp (B•ᵐp⁻¹ y) == y.

  destruct p. apply Identity_refl.
Defined.

Definition transpIsEqv2 {A : Set}(B : A → Set){x x' : A}
           (p : Identity x x') :
  ∀ y, B•ᵐp⁻¹ (B•ᵐp y) == y.

  destruct p. apply Identity_refl.
Defined.

Definition transpflip {A : Set}(B : A → Set){x x' : A}
           (p : Identity x x')
  : ∀ y y', B•ᵐp y == y' → y == B•ᵐp⁻¹ y'.

  intros y y' q. destruct p. apply q.
Defined.

Definition transpflip_inv {A : Set}(B : A → Set){x x' : A}
           (p : Identity x x')
  : ∀ y y', y == B•ᵐp⁻¹ y' → B•ᵐp y == y'.

  intros y y' q. destruct p. apply q.
Defined.

Definition transpcmp {A : Set}(B : A → Set){x x' x'' : A}
           (p : x == x')(q : x' == x''){y : B x}{y' : B x'}{y'' : B x''}
  : B•ᵐp y == y' → B•ᵐq y' == y'' → B•ᵐ(p⊙ᵐq) y == y''.

  intros r s. apply transpfunct.
  refine (_⊙ᵐs).
  apply transpCongr. apply r.
Defined.

Definition HIdΣ {A : Set}{B : A → Set}(z z' : sigT B) : Set :=
  ∃ p : projT1 z == projT1 z', B•ᵐp (projT2 z) == projT2 z'.

Definition extΣ {A : Set}{B : A → Set}(z z' : sigT B) :
              HIdΣ z z' → z == z'.

  destruct z as [a b]. destruct z' as [a' b'].
  intro r. destruct r as [p q]. simpl in *|-.
  destruct p. destruct q.
  apply rfl.
Defined.

Definition EqOver {A : Set}(B : A → Set){x x' : A}(p : x == x')
  : B x → B x' → Set
  := λ y y', B•ᵐp y == y'.

Notation "y ==[ p ] y'" := (EqOver _ p y y')
  (at level 70, no associativity, only parsing).

Definition TotEq {A : Set}(B : A → Set){x x' : A}
  : x == x' → Set
  := λ p, (sigT (λ z, EqOver B p (fst z) (snd z))).

Definition isTotEq {A : Set}(B : A → Set){x x' : A}(p : x == x')
  : ∀ y : B x, ∀ y' : B x', y ==[p] y' → TotEq B p
  :=  λ y y' q, existT _ (y , y') q.

Definition fstTotEq {A : Set}(B : A → Set){x x' : A}{p : x == x'}
  : TotEq B p → B x
  := λ v, fst (projT1 v).

Definition sndTotEq {A : Set}(B : A → Set){x x' : A}{p : x == x'}
  : TotEq B p → B x'
  := λ v, snd (projT1 v).

Definition eqTotEq {A : Set}(B : A → Set){x x' : A}{p : x == x'}(v : TotEq B p)
  : fstTotEq B v ==[p] sndTotEq B v
  := projT2 v.

Lemma domtransp  {A Y : Set}{B : A → Set}{x x' : A}(p : x == x')
  : ∀ f f', f == f' · B•ᵐp → (λ x, B x → Y)•ᵐp f == f'.
Proof.
  intros f f' q. destruct p. apply q.
Qed.


From FA Require Import String DFA NFA NFA2DFA eNFA eNFA2NFA eNFA2DFA Closure.
From mathcomp Require Import all_ssreflect.
Require Import Relations Classes.Equivalence.

Definition Lang := pred String.

Class MNR (L: Lang): Type :=
  mkMNR
  {
    mnr  : relation String;
    rcong: forall (x y: String) (a: Sigma), mnr x y -> mnr (glue x a) (glue y a);
    refin: forall (x y: String), mnr x y -> x \in L <-> y \in L;
    part : finType;
    pmap : String -> part;
    pmapp: forall (x y: String), mnr x y <-> pmap x = pmap y;
    trans: part -> Sigma -> part
  }.

Lemma EquivMNR: forall (L: Lang) (m: MNR L), Equivalence (@mnr L m).
Proof. intros.
       destruct m.
       unshelve econstructor.
       - unfold Reflexive.
         intro x.
         simpl in *.
         apply <- pmapp0.
         reflexivity.
       - unfold Symmetric.
         intros.
         apply <- pmapp0.
         symmetry.
         apply pmapp0.
         simpl in H.
         exact H.
       - unfold Transitive.
         intros.
         apply <- pmapp0.
         pose proof pmapp0 as pmapp.
         simpl in *.
         specialize (pmapp0 x y).
         specialize (pmapp y z).
         edestruct pmapp0.
         rewrite H1.
         edestruct pmapp.
         rewrite H3.
         reflexivity.
         exact H0.
         exact H.
        (*  Unshelve.
         exact a.
         unshelve econstructor. *)
Qed.

Lemma eta {A B C} (f : A -> B -> C) : (fun x y => f x y) = f.
Proof.
cbv. (* I would like to see f = f now *)
reflexivity. (* this proof works in any case, but sometimes syntax matters (rewriting, match...) *)
Defined.

Definition dfa2mnr (d: dfa): MNR (dfa_language d).
Proof. destruct d as (Q, s, delta, F).
       unshelve econstructor.
       - exact (fun x y => dfa_multistep (mkdfa Q s delta F) s x = dfa_multistep (mkdfa Q s delta F) s y).
       - exact Q.
       - intros x.
         exact (dfa_multistep (mkdfa Q s delta F) s x).
       - simpl. intros.
         rewrite H.
         reflexivity.
       - simpl. intros.
         rewrite !inE.
         split.
         unfold dfa_acceptance.
         simpl. intro Ha.
         move=>/existsP in Ha.
         destruct Ha as (z, Ha).
         apply /existsP.
         exists z.
         rewrite <- H.
         exact Ha.

         simpl. intro Ha.
         move=>/existsP in Ha.
         destruct Ha as (z, Ha).
         apply /existsP.
         exists z.
         rewrite H.
         exact Ha.
       - simpl. intros.
         reflexivity.
       - exact delta.
Defined.

Definition mnr2dfa (L: Lang) (R: MNR L): dfa.
Proof. destruct R as (mnr, rcong, refin, part, pmap, pmapp, trans).
       unshelve econstructor.
       - exact part.
       - exact (pmap eps).
       - intros p c.
         exact (trans p c).
       -
Admitted.


From mathcomp Require Import all_ssreflect ssralg ssrint ssrnum finmap matrix.
From mathcomp Require Import rat interval zmodp vector fieldext falgebra.
From mathcomp Require Import boolp classical_sets functions.
From mathcomp Require Import cardinality set_interval mathcomp_extra.
From mathcomp Require Import ereal reals signed topology prodnormedzmodule.
From mathcomp Require Import normedtype sequences mxalgebra.

Import Order.Theory GRing.Theory Num.Def Num.Theory.
Import numFieldTopology.Exports.
Import numFieldNormedType.Exports.
Import normedtype.NbhsNorm.

Import topology.numFieldTopology.Exports.
Import CompleteNormedModule.Exports.

Local Open Scope ring_scope.

Section Examples.

Variables (R: realType) (m n : nat).
(* test examples of sharing using norm properties from ssrnum*)

Example matrix_triangle  (M N : 'M[R]_(m.+1, n.+1)) :
  `|M + N| <= `|M| + `|N|.
Proof.  apply ler_norm_add. Qed.

Example matrix_norm_positive (A : 'M[R]_(m.+1, n.+1)) :
        0 <= `|A|.
Proof. apply normr_ge0. Qed.

End Examples.

Section Inverse.

Variables (R: realType) (m n : nat).

Lemma eqmx_mulr (b a1 a2: 'M[R]_m.+1) :
        a1 = a2 -> a1 * b = a2 * b.
Proof.
by move => H; rewrite H.
Qed.

Lemma mulr_eqmx : forall  (b a1 a2: 'M[R]_m.+1) ,
        b \is a GRing.unit -> a1 *m b = a2 *m b -> a1 = a2.
Proof.
move => b a1 a2  H1 H2.
have : a1 * b * b^-1 = a2 * b * b^-1 by apply eqmx_mulr; apply H2.
rewrite -!mulrA mulrV // !mulr1 //.
Qed.

Lemma invmx_mul (A B: 'M[R]_m.+1) :
        A \in unitmx -> B \in unitmx ->
        invmx (A *m B) = invmx B *m invmx A.
Proof.
move => H1 H2.
have H3: A *m B \in unitmx by (rewrite unitmx_mul; apply/andP => //=).
have H4: invmx (A *m B) * (A *m B) = invmx B *m invmx A * (A *m B).
 rewrite -mulmxE (mulVmx H3) mulmxE mulrA -mulmxE.
 rewrite -!mulmxA [invmx A *m (A *m B)]mulmxA (mulVmx H1) mul1mx (mulVmx H2) //.
apply (mulr_eqmx _ _ _ H3 H4).
Qed.

Lemma invmx_pert (A E: 'M[R]_m.+1) :
        A \in unitmx -> 1 + invmx A * E \in unitmx ->
        invmx (A + E) = invmx (1 + invmx A * E) * invmx A.
Proof.
move => H1 H2.
have H3: invmx (A + E) = invmx (A * (1 + invmx A * E)).
rewrite mulrDr mulrA mulr1 -mulmxE (mulmxV H1) mul1mx //.
rewrite H3 (invmx_mul _ _ H1) //.
Qed.

End Inverse.

Section MatrixFacts.

Variables (m n : nat) (R: realType).

Variable g : {linear 'rV[R]_m.+1 -> 'rV[R]_n.+1}.

Lemma trmxeq (m' n' : nat) (A B : 'M[R]_(m',n')) : A = B -> A^T = B^T.
Proof. by move => H; rewrite H. Qed.

Lemma trmx_mul_rV_lin1 u : (u *m lin1_mx g)^T = (g u)^T.
Proof. by apply trmxeq; apply mul_rV_lin1. Qed.

Lemma trmxZ a (A : 'M[R]_n) : (a *: A)^T = a *: (A^T).
Proof.  by apply/matrixP =>  k i /[!mxE]. Qed.

End MatrixFacts.

Section Maps.

(** Notes:
 contractive maps are defined in sequences *)
Variables (m n : nat) (R: realType).
Variables (Sv : set 'cV[R]_(m.+1)).

Definition f_app (f : 'rV[R]_m -> 'rV[R]_m)
        (u: 'rV[R]_m)  := fun n => iter n f u.

Goal forall (f : 'rV[R]_m -> 'rV[R]_m) (u: 'rV[R]_m) ,
       f_app f u 1 = f u.
rewrite/f_app/iter //. Qed.

Goal forall (f : 'rV[R]_m -> 'rV[R]_m) (u: 'rV[R]_m) ,
       f_app f u 0 =  u.
rewrite/f_app/iter //. Qed.

Canonical mat_R_CompleteNormedModule (m' n' : nat) :=
  [completeNormedModType R of (matrix R m'.+1 n'.+1)].

Lemma Banach_test : forall (f' : {fun Sv >-> Sv}) ,
  is_contraction f' -> closed Sv -> (Sv !=set0)%classic ->
        exists2 x:'cV_m.+1, Sv x & x = f' x .
Proof.
move => f' A B C; apply banach_fixed_point => //.
Qed.

Definition lin2_mx {m' n' : nat} (f: 'cV[R]_n'.+1 -> 'cV[R]_m'.+1) :
  'M[R]_(m'.+1, n'.+1) := \matrix[lin1_mx_key]_(j, i) f (delta_mx i 0) j 0.

Variable f : {linear 'cV[R]_n.+1 -> 'cV[R]_m.+1}.
Variable g : {linear 'rV[R]_m.+1 -> 'rV[R]_n.+1}.

Lemma mul_cV_lin2 (u : 'cV_n.+1):
   lin2_mx f *m u = f u.
Proof.
by rewrite {2}[u]matrix_sum_delta linear_sum; apply/colP=> i;
rewrite mxE summxE; apply eq_bigr => j _; rewrite big_ord1 linearZ !mxE mulrC.
Qed.

Variable fs : {fun Sv >-> Sv}.
Axiom linear_fs : linear fs.

Canonical fs' := Linear linear_fs.

Lemma Banach_tests :
  is_contraction fs' -> closed Sv -> (Sv !=set0)%classic ->
        exists2 x:'cV_m.+1, Sv x & x = fs' x .
Proof.
move => A B C; apply banach_fixed_point => //.
Qed.

Lemma mul_cV_lin2'  (u : 'cV_m.+1):
   lin2_mx fs *m u = fs' u.
Proof.
by rewrite {2}[u]matrix_sum_delta linear_sum; apply/colP=> i;
rewrite mxE summxE; apply eq_bigr => j _; rewrite big_ord1 linearZ !mxE mulrC.
Qed.

(* Search normr matrix_normedZmodType *)

Lemma linear_exists (m' n' : nat) (A: 'M[R]_(m'.+1,n'.+1)) :
  exists f, forall u : 'cV_(n'.+1) , f u = A *m u /\ linear f.
Proof.
Admitted.

Lemma subMultNorm (A: 'M[R]_m.+1) (u : 'cV_m.+1) :
  `| A *m u | <= `|A| * `|u|.
Proof.
rewrite /normr /= !mx_normE.
Search normr.
Search BigOp.bigop normr.
Admitted.

Lemma mx_norm_is_klipschitz :
  forall (k : R) (HBND: `|lin2_mx fs| <= k),   k.-lipschitz_Sv fs.
Proof.
move => k HBND.
rewrite/dominated_by/globally /= => x Hx.
rewrite -linearB // .
rewrite -mul_cV_lin2'.
eapply le_trans => [ | ].
apply subMultNorm =>  //.
Admitted.

Lemma norm_lt_contraction:
  `|lin2_mx fs| < 1 -> is_contraction fs.
Proof.
move => H.
exists `|lin2_mx fs|%:nng => // (* see signed.v; x%:nng explicitly casts x to {nonneg R} *).
unfold contraction; simpl.
split => [//|].
apply mx_norm_is_klipschitz => //.
Qed.

(* definition of the matrix condition number *)
Definition kappa (A : 'M[R]_m.+1) := `|(invmx A)| * `|A|.

Lemma Neumann_bound' (A : 'M[R]_m.+1):
        (1 - A) * \sum_(0 <= i < n.+1) A^i.
Proof.

Lemma Neumann_bound (F : 'M[R]_m.+1):
        `|invmx(1 - F)| <=  \sum_(0 <= i < n.+1) `|F|^i.
Proof.
unfold norm.


Definition plus (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x: X) => n X f (m X f x).

Example plus_1 : plus zero one = one.
Proof.
  intros. simpl.
  reflexivity.
Qed.

Example plus_2 : plus two three = plus three two.
Proof.
  intros. simpl.
  reflexivity.
Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof.
  intros. simpl.
  reflexivity.
Qed.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Add LoadPath "src/".
Require Import Model.

(*
  The axiom of regularity does not hold in this set theory.
  The weaker form of regularity holds, and its necessary to
  prove extensionality: a positive set does cannot belong to itself.
*)
Theorem weak_regularity: forall {x}, low x -> iin x x -> False.
Proof.
  induction x; simpl low; auto; intros.
  destruct H1. apply (H x).
  - destruct (s x); simpl; auto.
  - assert (H1' := H1). destruct (s x) in H1; destruct H1.
    destruct (H2 x).
    apply (in_sound_left (eeq_sym H1')).
    apply (in_sound_right (eeq_sym H1')).
    exists x. assumption.
Qed.

(*
  The lemma [pos_neg_ext_neq] below is fundamental to
  prove extensionality. It proves that a positive set cannot
  be extensionally equal to a negative set.

  In order to prove [pos_neg_ext_neq], we first prove the
  auxiliary [pos_univ]. It says that if a positive set is
  extensionally equal to a negative set, then one can
  express the universal set (defined as negative) as a
  positive set.
  This, together with weak regularity, yields the required
  contradiction.
*)

Definition f_sum {X Y} f g (z: X + Y): set := match z with
  | inl x => f x
  | inr y => g y
end.

Lemma pos_univ: forall X f Y g, (forall z, iin z (@Pos X f) <-> iin z (@Neg Y g)) -> (forall z, iin z (@Pos (X + Y) (f_sum f g))).
Proof.
  intros. simpl iin in *.
  pose proof (H z).
  destruct (classic (exists x : X, eeq (f x) z)).
  - destruct H1. exists (inl x). simpl f_sum. assumption.
  - cut (exists y : Y, eeq (g y) z). intro. destruct H2.
    exists (inr x). auto.
  destruct H0. pose proof (fun T => H1 (H2 T)).
  apply NNPP. intro. apply H3. intros. apply H4. exists x. auto.
Qed.

Lemma pos_neg_ext_neq: forall X f Y g, (forall z, iin z (@Pos X f) <-> iin z (@Neg Y g)) -> False.
Proof.
  intros.
  pose proof (pos_univ _ _ _ _ H).
  apply (@weak_regularity (@Pos (X + Y) (f_sum f g)) I). apply H0.
Qed.

Lemma ext_pos: forall X f Y g, (forall z, iin z (@Pos X f) <-> iin z (@Pos Y g)) -> eeq (@Pos X f) (@Pos Y g).
Proof.
  intros. simpl; split; intro.
  - destruct (H (f x)). simpl iin in H0.
    cut (exists x0 : X, eeq (f x0) (f x)). intro. destruct (H0 H2). exists x0. apply eeq_sym. assumption. exists x. apply eeq_refl.
  - destruct (H (g y)). simpl iin in H1.
  cut (exists x : Y, eeq (g x) (g y)). intro. destruct (H1 H2). exists x. assumption. exists y. apply eeq_refl.
Qed.

Lemma ext_neg: forall X f Y g, (forall z, iin z (@Neg X f) <-> iin z (@Neg Y g)) -> eeq (@Pos X f) (@Pos Y g).
Proof.
  intros. simpl; split; intro.
  - destruct (H (f x)). simpl iin in H1.
    apply NNPP. intro.
    cut (forall x0 : Y, eeq (g x0) (f x) -> False). intro.
    pose proof (H1 H3). apply (H4 x). apply eeq_refl. intros.
    pose proof (eeq_sym H3). revert H4. clear H3. revert x0.
    apply not_ex_all_not. assumption.
  - destruct (H (g y)). simpl iin in H0.
  apply NNPP. intro.
  cut (forall x : X, eeq (f x) (g y) -> False). intro.
  pose proof (H0 H3). apply (H4 y). apply eeq_refl.
  apply not_ex_all_not. assumption.
Qed.

Theorem extensionality: forall x y, x ≡ y <-> forall z, z ∈ x <-> z ∈ y.
Proof.
  intros. split. intros. split; apply in_sound_right; auto. apply eeq_sym. assumption.
  destruct x; destruct y.
  - apply ext_pos.
  - intros. destruct (pos_neg_ext_neq _ _ _ _ H).
  - intros. cut (forall z : set, iin z (@Pos X0 s0) <-> iin z (@Neg X s)).
    intro. destruct (pos_neg_ext_neq _ _ _ _ H0).
    intro z. apply iff_sym. apply (H z).
  - apply ext_neg.
Qed.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms
  MathClasses.interfaces.canonical_names MathClasses.theory.categories MathClasses.theory.ua_mapped_operations.

Require MathClasses.categories.varieties.

Section contents.

  Context (et: EquationalTheory) `{InVariety et A} `{InVariety et B}
    `{!HomoMorphism et A B ab} `{!HomoMorphism et B A ba}
    (i: iso_arrows (varieties.arrow et ab) (varieties.arrow et ba)).

  Arguments ab {a} _.
  Arguments ba {a} _.

  Let ab_proper a: Proper ((=) ==> (=)) (@ab a).
  Proof. apply _. Qed.

  Let ba_proper a: Proper ((=) ==> (=)) (@ba a).
  Proof. apply _. Qed.

  Let epA: ∀ V n, Proper ((=) ==> eq ==> (=)) (@eval _ A _ V n) := _.
  Let epB: ∀ V n, Proper ((=) ==> eq ==> (=)) (@eval _ B _ V n) := _.
    (* hints. shouldn't be necessary *)

  Let ab_ba: ∀ b (a: B b), ab (ba a) = a := proj1 i.
  Let ba_ab: ∀ b (a: A b), ba (ab a) = a := proj2 i.

  Program Lemma transfer_eval n (t: Term et nat n) (v: Vars et B nat):
    eval et (A:=A) (λ _ i, ba (v _ i)) t = map_op _ (@ba) (@ab) (eval et v t).
  Proof with auto; try reflexivity.
   induction t; simpl in *; intros...
    set (eval et (λ (a: sorts et) (i : nat), ba (v a i)) t2).
    eapply transitivity.
     apply (@epA nat (ne_list.cons y t1) (λ a i, ba (v a i))
         (λ a i, ba (v a i)) (reflexivity _) t2 t2 (reflexivity _)
         : Proper ((=) ==> op_type_equiv (sorts et) A t1)%signature o).
     now apply IHt2.
    subst o.
    rewrite (IHt1 (ba (eval et v t3)) (ba (eval et v t3)))...
    apply (@map_op_proper (sorts et) B A _ _ _ _ _ _).
    unfold compose in *.
    rapply (epB _ _ v v (reflexivity _) t2 t2 (reflexivity _)).
    apply ab_ba.
   generalize
     (@algebra_propers _ A _ _ _ o)
     (@algebra_propers _ B _ _ _ o).
   generalize (@preserves et A B _ _ _ _ (@ab) _ o).
   fold (@algebra_op et A _ o) (@algebra_op et B _ o).
   generalize (@algebra_op et A _ o), (@algebra_op et B _ o).
   induction (et o); simpl; repeat intro.
    rewrite <- ba_ab, H1...
   apply IHo0.
     eapply Preservation_proper''; eauto; intros; try apply _.
     symmetry. apply H3, ab_proper, H4.
    apply H2...
   apply H3...
  Qed. (* todo: make [reflexivity] work as a hint. further cleanup. *)

  Program Lemma transfer_eval' n (t: Term et nat n) (v: Vars et B nat):
    map_op _ (@ab) (@ba) (eval et (A:=A) (λ _ i, ba (v _ i)) t) = eval et v t.
  Proof with auto.
   intros.
   pose proof (@map_op_proper (sorts et) A B _ _ _ _ _ _).
   rewrite transfer_eval.
   apply (@map_iso _ A B _ _ (@ab) (@ba) ab_ba).
   apply _.
  Qed.

  Program Lemma transfer_statement_and_vars (s: Statement et) (v: Vars et B nat):
    eval_stmt et v s ↔ eval_stmt et (A:=A) (λ _ i, ba (v _ i)) s.
  Proof with auto; reflexivity.
   intros.
   induction s; simpl; intuition.
    rewrite transfer_eval. symmetry.
    rewrite transfer_eval. symmetry.
    apply (map_op_proper _ _ _)...
   rewrite <- transfer_eval'. symmetry.
   rewrite <- transfer_eval'. symmetry.
   apply (map_op_proper _ _ _)...
  Qed.

  Theorem transfer_statement (s: Statement et): (∀ v, eval_stmt et (A:=A) v s) → (∀ v, eval_stmt et (A:=B) v s).
  Proof with intuition auto.
   intros ? v.
   assert (v = (λ _ i, ab (ba (v _ i)))) as P.
    destruct i. intros a a0. symmetry...
   rewrite P, transfer_statement_and_vars...
  Qed.

End contents.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Morphisms.
Require Export Category.Theory.Isomorphism.
Require Export Category.Functor.Bifunctor.
Require Export Category.Structure.Monoidal.
Require Export Category.Structure.Monoidal.Naturality.

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

Section SymmetricMonoidal.

Context `{@Monoidal C}.

Class SymmetricMonoidal := {
  twist {x y} : x ⨂ y ≅ y ⨂ x;
  twist_natural : natural (@twist);

  twist_invol {x y} : twist ∘ twist ≈ id[x ⨂ y];

  hexagon_identity {x y z} :
    tensor_assoc ∘ twist ∘ tensor_assoc
      << (x ⨂ y) ⨂ z ~~> y ⨂ (z ⨂ x) >>
    id ⨂ twist ∘ tensor_assoc ∘ twist ⨂ id
}.

Corollary bimap_twist `{SymmetricMonoidal} {x y z w} (f : x ~> z) (g : y ~> w) :
  twist ∘ g ⨂ f ∘ twist ≈ f ⨂ g.
Proof.
  spose (fst twist_natural _ _ f _ _ g) as X.
  normal.
  rewrite <- comp_assoc.
  rewrites.
  rewrite comp_assoc.
  rewrite twist_invol; cat.
Qed.

End SymmetricMonoidal.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import RobustSSCHPreservation.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section RobustSSCHCriterion.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Type.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.
  Local Definition hprop__S := hprop trace__S.
  Local Definition hprop__T := hprop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition par__S := par Source.
  Local Definition par__T := par Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition rhsat__S := rhsat Source_Semantics.
  Local Definition rhsat__T := rhsat Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).

  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  Variable rel : trace__S -> trace__T -> Prop.

  Local Definition adjunction :=  induced_connection rel.

  Local Definition τ' : prop__S -> prop__T := α adjunction.
  Local Definition σ' : prop__T -> prop__S := γ adjunction.

  Local Definition rel_adjunction_law : Adjunction_law τ' σ' := adjunction_law adjunction.

  Definition rel_RSCHC := forall P C__T, exists C__S,
       ( forall t, sem__T (plug__T (P ↓) C__T) t -> exists s, rel s t /\ sem__S (plug__S P C__S) s).

  Local Definition sCl_σ : hprop__T -> hprop__S := sCl_σ σ'.
  Local Definition sCl_τ : hprop__S -> hprop__T := sCl_τ τ'.

  Local Definition sCl_τRhP := sCl_τRhP compilation_chain
                                        Source_Semantics Target_Semantics
                                        τ'.

  Local Definition sCl_σRhP := sCl_σRhP compilation_chain
                                        Source_Semantics Target_Semantics
                                        σ'.

  Lemma sCl_σRhP_sCl_τRhP : (forall (P : par__S) (H__T : hprop__T), SSC H__T ->  sCl_σRhP P H__T) <->
                            (forall (P : par__S) (H__S : hprop__S), SSC H__S -> sCl_τRhP P H__S).
  Proof.
    split.
    + move => Hσ P H__S ssc_H rsat_source.
      have rsat_sigma_tau : rhsat__S P (sCl_σ (sCl_τ H__S)).
      { apply: rhsat_upper_closed. exact rsat_source.
        apply: Galois_snd_lift. exact rel_adjunction_law. exact ssc_H. }
      have τ_ssc : SSC (sCl_τ H__S) by apply: sCl_SCH.
      exact (Hσ P (sCl_τ H__S) τ_ssc rsat_sigma_tau).
    + move => Hτ P H__T ssc_H rsat_source.
      have h_ssc: SSC (sCl_σ H__T) by apply: sCl_SCH.
      move: (Hτ P (sCl_σ H__T) h_ssc rsat_source).
      move => HHH. eapply rhsat_upper_closed. exact HHH.
      apply: Galois_fst_lift; eauto. exact rel_adjunction_law.
  Qed.

  Theorem rel_RSCHC_sClτRSCHP : rel_RSCHC <-> (forall (P : par__S) (H__S : hprop__S), SSC H__S -> sCl_τRhP P H__S).
  Proof.
    split.
    - move => Htilde P H H_ssc. setoid_rewrite contra_τRhP.
      move => [C__T Hsem].
      move: (Htilde P C__T) => [C__S HH]. exists C__S => Hfalse.
      apply: Hsem.
      exists (τ' (beh__S (plug__S P C__S))). split.
      + by exists (beh__S (plug__S P C__S)).
      + move => t Ht. destruct (HH t Ht) as [s [Hs1 Hs2]]. now exists s.
    - move => Hτ P Ct.
      have Hssc : SSC (fun b: prop__S =>  ~ beh__T (plug__T (P↓) Ct) ⊆ τ' b).
      { move => b1 Hb1 b2 b1_b2 Hb2. apply: Hb1. firstorder. }
      specialize (Hτ P (fun b: prop__S =>  ~ beh__T (plug__T (P↓) Ct) ⊆ τ' b) Hssc).
      apply contra in Hτ. move: Hτ. rewrite !neg_rhsat.
      move => [Cs Hbeh]. move/NNPP: Hbeh.
      exists Cs => t Hsem_t. move: (Hbeh t Hsem_t). firstorder.
      move => Hf. specialize (Hf Ct).
      destruct Hf as [b' [Hb' Hbb]]. destruct Hb' as [bs [Hbs1 Hbs2]]. now subst.
  Qed.

  Theorem rel_RTC_σRTP : rel_RSCHC <-> (forall (P : par__S) (H__T : hprop__T), SSC H__T ->  sCl_σRhP P H__T).
  Proof. by rewrite sCl_σRhP_sCl_τRhP rel_RSCHC_sClτRSCHP. Qed.

End RobustSSCHCriterion.