Require Import EquivDec.
Require Import SetoidClass.
Require Import RelationClasses.

Require Import Calculi.

Set Primitive Projections.
Set Universe Polymorphism.
Set Default Goal Selector "!".

Axiom well_order : Type.
Axiom well_order_zero : well_order.
Axiom well_order_one : well_order.
Axiom well_order_succ : well_order -> well_order.
Axiom well_order_arbitrary_sum :
  forall (I : Type) (F : I -> well_order), well_order.

Require Import Category.Instance.Algebra.

(** Propositional Languages *)
(* Def. 2.59 in “PT for Fuzzy L.” *)
  (* corresponds to the signature of an algebra (in the context of univ. algebra). *)
Definition PropType := Signature.
  (* Using the trick of Andrej Bauer
     https://gist.github.com/andrejbauer/3cc438ab38646516e5e9278fdb22022c
     of defining arity not via [nat] but via the amount of elements in a type.
  *)

Definition Equinumerous (A B : Type) :=
  { p : (A -> B) * (B -> A) |
    (forall x, (fst p) (snd p x) = x) /\
      (forall x, (snd p) (fst p x) = x) }.

Require Import Category.Theory.Isomorphism.
Import Category.Instance.Coq.

(* [P0] is extended by [P1] *)
Record PropTypeExtension (P0 P1 : PropType) :=
  {
    PTE_connective : P0.(operations) -> P1.(operations);
    PTE_connective_inj : forall x y,
      PTE_connective x = PTE_connective y -> x = y;
    PTE_connective_arity :
    forall x, (op_arity x) ≅[Coq] (op_arity (PTE_connective x));
  }.

  (* NOTE: The def. of [PropFormula] is identical to the definition of
  the term algebra in the context of univ. algebra. *)
Section PropositionalLanguage.
  Variables (L : PropType) (var : Type).
  (* Necessary for making [PropFormula_eq] (provably) transitive,
     without having to assume proof-irrelevance or somesuch. *)
  Context `{Lc_dec : EqDec L.(operations) eq}.

  (* The type [var] indexes the variables. *)
  Definition PropFormula := @Terms L var.

  (* [A] is a subformula of [B] iff [subformula A B] *)
  Inductive subformula : PropFormula -> PropFormula -> Prop :=
  | subformula_refl A : subformula A A
  | subformula_compat A c (f : op_arity c -> PropFormula) i :
    subformula A (f i) ->
    subformula A (term_op c f).

  (* Assigns each [PropFormula] a well-order, i.e. an ordinal. *)
  Fixpoint complexity (A : PropFormula) : well_order :=
    match A with
    | term_atom _ => well_order_one
    | term_op c f =>
        well_order_succ (well_order_arbitrary_sum
                           _ (fun i => complexity (f i)))
    end.

  Import Category.Lib.Setoid.
  Existing Instance Algebra.Terms_Setoid.

  (* Add well-founded recursion on the complexity to complete this.
     And a sufficient condition on each [op_arity o]. *)
  Fixpoint Terms_equiv_EqDec
        (EqDec_C : EqDec L.(operations) eq)
        (EqDec_V : EqDec var eq)
    (x y : Terms var) :
    (x ≈ y) + ( x ≈ y -> Empty_set ).
  Proof.
    refine (
    match x, y with
    | term_atom v0, term_atom v1 =>
        if EqDec_V v0 v1 then
          inl _
        else
          inr _
    | term_op c0 f0, term_op c1 f1 =>
        if EqDec_C c0 c1 then
          _
        else
          inr _
    | term_atom _, term_op _ _ => inr _
    | term_op _ _, term_atom _ => inr _
    end).
    - red in e. subst.
      constructor.
    - intros.
      red in c.
      inversion X; subst; clear X.
      unshelve epose proof (c _). { reflexivity. }
      contradiction.
    - intros.
      inversion X; subst; clear X.
    - intros.
      inversion X; subst; clear X.
    - inversion e; subst; clear e.
      assert ((forall i, f0 i ≈ f1 i) + ((forall i, f0 i ≈ f1 i) -> Empty_set)).
      { (* TODO: Add a recursion here. somehow. *)
        admit.
      }
      destruct X; [left|right].
      + constructor. assumption.
      + intros.
        inversion X; subst; clear X.
        apply Eqdep_dec.inj_pair2_eq_dec in H, H1; try assumption.
        subst. auto.
    - intros.
      inversion X; subst; clear X.
      apply Eqdep_dec.inj_pair2_eq_dec in H1, H3; try assumption.
      subst.
      unshelve epose proof (c _). { reflexivity. }
      contradiction.
  Admitted.

  Definition PropHilbertCalculus
             {rules : Type} (rules_inferences : rules -> _) : Calculus :=
    {|
      structures := PropFormula;
      rules := rules;
      rules_inferences := rules_inferences;
    |}.
End PropositionalLanguage.

Variant impl_neg :=
| impl | neg.

Definition impl_neg_Sig :=
  {| connective := impl_neg;
    connective_arity :=
    fun p =>
      match p with
      | impl => unit + unit
      | neg => unit
      end%type;
  |}.

Definition INS_neg {var} (A : PropFormula impl_neg_Sig var) :
  PropFormula impl_neg_Sig var :=
  PF_connective
    impl_neg_Sig var neg
    (fun _ => A).

Definition INS_impl {var} (A B : PropFormula impl_neg_Sig var) :
  PropFormula impl_neg_Sig var :=
  PF_connective
    impl_neg_Sig var impl
    (fun p =>
       match p with
       | inl _ => A
       | inr _ => B
       end).

Definition HCPC_CL1 {var} (A B : PropFormula impl_neg_Sig var)
  : PropFormula impl_neg_Sig var :=
  INS_impl A (INS_impl B A).

Definition HCPC_CL2 {var} (A B C : PropFormula impl_neg_Sig var)
  : PropFormula impl_neg_Sig var :=
  INS_impl (INS_impl A (INS_impl B C))
           (INS_impl (INS_impl A B) (INS_impl A C)).

Definition HCPC_CL3 {var} (A B : PropFormula impl_neg_Sig var)
  : PropFormula impl_neg_Sig var :=
  INS_impl
    (INS_impl (INS_neg A)
              (INS_neg B))
    (INS_impl B A).

Require Import List.
Import ListNotations.

Definition INS_MP {var} A B :
  Inference (PropFormula impl_neg_Sig var) :=
  {|
    premises := [A; INS_impl A B];
    conclusion := B
  |}.

Definition Inference_Axiom {S} (A : S) : Inference S :=
  {|
    premises := [];
    conclusion := A;
  |}.

Variant HCPC_rules :=
  HCPCr_CL1 | HCPCr_CL2 | HCPCr_CL3 | HCPCr_MP.

Definition HCPC : Calculus :=
  PropHilbertCalculus
    impl_neg_Sig
    nat
    (fun r : HCPC_rules =>
       match r with
       | HCPCr_MP =>
           (fun p => exists A B, p = INS_MP A B)
       | HCPCr_CL1 =>
           (fun p => exists A B, p = Inference_Axiom (HCPC_CL1 A B))
       | HCPCr_CL3 =>
           (fun p => exists A B, p = Inference_Axiom (HCPC_CL3 A B))
       | HCPCr_CL2 => (fun p => exists A B C, p = Inference_Axiom (HCPC_CL2 A B C))
       end).

Require Import Ensembles.

Fact HCPC_impl_refl A :
  @Derivable HCPC (Empty_set _) (INS_impl A A).
Proof.
  unshelve eexists.
  - constructor.
    { split.
      2: apply (Some HCPCr_MP).
      apply (INS_impl A A).
    }
    refine [_; _].
    + constructor.
      2: apply nil.
      split.
      2: apply (Some HCPCr_CL1).
      apply (INS_impl A (INS_impl A A)).
    + constructor.
      { split.
        { apply (INS_impl
                   (INS_impl A (INS_impl A A))
                   (INS_impl A A)).
        }
        apply (Some HCPCr_MP).
      }
      refine [_;_].
      * constructor.
        2: apply nil.
        split.
        2: apply (Some HCPCr_CL1).
        apply (INS_impl
                 A
                 (INS_impl
                    (INS_impl A A)
                    A)).
      * constructor.
        2: apply nil.
        split.
        2: apply (Some HCPCr_CL2).
        apply (INS_impl
                 (INS_impl
                    A
                    (INS_impl
                       (INS_impl A A)
                       A))
                 (INS_impl
                    (INS_impl A (INS_impl A A))
                    (INS_impl A A))).
  - split.
    2: reflexivity.
    repeat constructor; red; simpl.
    + eexists _, _.
      reflexivity.
    + eexists _, _.
      reflexivity.
    + eexists _, _, _. reflexivity.
    + eexists _, _. reflexivity.
    + eexists _, _. reflexivity.
Qed.

Section PropositionalHilbertCalculus.
End PropositionalHilbertCalculus.
(* Claim: If for a [PropType] all connectives have an arity on which
one can do recursion (i.e. in "practice" at most countable) and [var]
has decidable equality (and some decidability or recursion on the type
[connective] of the signature), then [subformula] is
decidable. Equality is then probably also decidable. We can probably
show the converse as well. *)

Section SequentCalculus.
  (* A sequent calculus is determined by its language and its rules.
     It shall be possible to compare sequent calculi over the same language. *)
  (* How to best abstract what a rule is? *)
End SequentCalculus.

(* MAYBE: There are multiple ways to do sequent calculus: using lists
   or using multisets or using sets. We could formalize all of these
   and provide "bridge" theorems between them. I.e. a sequent calculus
   using sets has contraction as a multiset calculus and a multiset
   calculus has exchange as a list calculus.
*)

(* MAYBE: Define boolean algebras and use this to give a semantics to
   classical logic *)

(*Section Classical_Propositional_Logic.*)
  (* This def. is too specific. Lift it to the more general system.
Inductive Formula : Set :=
| var (n : nat)
| not : Formula -> Formula
| and : Formula -> Formula -> Formula
| or : Formula -> Formula -> Formula
| impl : Formula -> Formula -> Formula.

*)

Variant BA_Connectives :=
| BA_and | BA_or | BA_neg | BA_bot | BA_top.

Let Empty := Datatypes.Empty_set.

Definition BooleanAlgebraSig : PropType :=
  {|
    connective := BA_Connectives;
    connective_arity :=
    fun c =>
      match c with
      | BA_and => unit + unit
      | BA_or => unit + unit
      | BA_neg => unit
      | BA_bot => Empty
      | BA_top => Empty
      end%type;
|}.

Record FOLanguage :=
  { FOL_predicate : Type;
    FOL_predicate_arity : FOL_predicate -> Type;
    FOL_function : Type;
    FOL_function_arity : FOL_function -> Type;
    FOL_connective : Type;
    FOL_connective_arity : FOL_connective -> Type;
  }.

Section FirstOrderLanguage.
  Variables (L : FOLanguage) (var : Type).
  Context `{Lf_dec : EqDec L.(FOL_function) eq}.
  Context `{Lp_dec : EqDec L.(FOL_predicate) eq}.
  Context `{Lc_dec : EqDec L.(FOL_connective) eq}.

  Inductive FOLTerm : Type :=
  | FOL_Tvar : var -> FOLTerm
  | FOL_Tfun (f : L.(FOL_function)) (a : L.(FOL_function_arity) f -> FOLTerm) : FOLTerm.

  Inductive FOLTerm_eq : FOLTerm -> FOLTerm -> Prop :=
  | FOLT_eq_var v :
    FOLTerm_eq (FOL_Tvar v) (FOL_Tvar v)
  | FOLT_eq_fun f a0 a1 :
    (forall i, FOLTerm_eq (a0 i) (a1 i)) ->
    FOLTerm_eq (FOL_Tfun f a0) (FOL_Tfun f a1).

  Instance FOLTerm_eq_Refl : Reflexive FOLTerm_eq.
  Proof.
    red; intros.
    induction x; constructor; assumption.
  Qed.

  Instance FOLTerm_eq_Sym : Symmetric FOLTerm_eq.
  Proof.
    red; intros.
    induction H; constructor; assumption.
  Qed.

  Instance FOLTerm_eq_Equivalence : Equivalence FOLTerm_eq.
  Proof.
    split; try typeclasses eauto.
    red; intros.
    revert z H0.
    induction H; intros z Hz; inversion Hz; subst; clear Hz.
    { constructor. }
    apply Eqdep_dec.inj_pair2_eq_dec in H3.
    2: assumption.
    subst. constructor. auto.
  Qed.

  (* First-order language with equality. *)
  Inductive FOLFormula : Type :=
  | FOL_eq : FOLTerm -> FOLTerm -> FOLFormula
  | FOL_pred (p : L.(FOL_predicate)) (t : L.(FOL_predicate_arity) p -> FOLTerm) : FOLFormula
  | FOL_conn (c : L.(FOL_connective)) (f : L.(FOL_connective_arity) c -> FOLFormula) : FOLFormula
  | FOL_all : var -> FOLFormula -> FOLFormula
  | FOL_ex : var -> FOLFormula -> FOLFormula.

  Inductive FOLFormula_eq : FOLFormula -> FOLFormula -> Prop :=
  | FOL_eq_eq t00 t01 t10 t11 :
    FOLTerm_eq t00 t10 ->
    FOLTerm_eq t01 t11 ->
    FOLFormula_eq (FOL_eq t00 t01) (FOL_eq t10 t11)
  | FOL_eq_pred p t0 t1 :
    (forall i, FOLTerm_eq (t0 i) (t1 i)) ->
    FOLFormula_eq (FOL_pred p t0) (FOL_pred p t1)
  | FOL_eq_conn c f0 f1 :
    (forall i, FOLFormula_eq (f0 i) (f1 i)) ->
    FOLFormula_eq (FOL_conn c f0) (FOL_conn c f1)
  | FOL_eq_all v f0 f1 :
    FOLFormula_eq f0 f1 ->
    FOLFormula_eq (FOL_all v f0) (FOL_all v f1)
  | FOL_eq_ex v f0 f1 :
    FOLFormula_eq f0 f1 ->
    FOLFormula_eq (FOL_ex v f0) (FOL_ex v f1).

  Instance FOLFormula_eq_Refl : Reflexive FOLFormula_eq.
  Proof using.
    red; intros.
    induction x; constructor; try assumption; reflexivity.
  Qed.

  Instance FOLFormula_eq_Symm : Symmetric FOLFormula_eq.
  Proof using.
    red; intros.
    induction H; constructor; try assumption;
      intros; symmetry; auto.
  Qed.

  Instance FOLFormula_eq_Equivalence : Equivalence FOLFormula_eq.
  Proof using Lc_dec Lf_dec Lp_dec.
    split; try typeclasses eauto.
    red; intros.
    revert z H0.
    induction H; intros z Hz; inversion Hz; subst; clear Hz;
      constructor; auto.
    - (* FOL_eq *)
      transitivity t10; assumption.
    - (* FOL_eq *)
      transitivity t11; assumption.
    - (* FOL_pred *)
      apply Eqdep_dec.inj_pair2_eq_dec in H2.
      2: assumption.
      subst. intros.
      transitivity (t1 i); auto.
    - (* FOL_conn *)
      apply Eqdep_dec.inj_pair2_eq_dec in H3.
      2: assumption.
      subst. intros. apply H0.
      auto.
  Qed.
End FirstOrderLanguage.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.

(** The terminal object in category C is an object t such that for any object a,
    there is a unique arrow ! : a -> t. *)
Class Terminal (C : Category) : Type :=
{
  terminal : C;
  t_morph : ∀ (d : Obj), (d --> terminal)%morphism;
  t_morph_unique : ∀ (d : Obj) (f g : (d --> terminal)%morphism), f = g
}.

Arguments terminal {_} _.
Arguments t_morph {_} _ _.
Arguments t_morph_unique {_} _ _ _ _.

Coercion terminal : Terminal >-> Obj.

Notation "𝟙_ C" := (Terminal C) (at level 75) : object_scope.

(** (The) terminal object is unique up to isomorphism. *)
Theorem Terminal_iso {C : Category} (T T' : (𝟙_ C)%object) :
  (T ≃ T')%isomorphism.
Proof.
  apply (Build_Isomorphism _ _ _ (t_morph _ _) (t_morph _ _));
  apply t_morph_unique.
Qed.

(** The initial is the dual of the terminal object. *)
Definition Initial (C : Category) := (𝟙_ (C ^op))%object.
Existing Class Initial.

Notation "𝟘_ C" := (Initial C) (at level 75) : object_scope.


(* Copyright (c) 2014, Robert Dockins *)

Require Import List.
Require Import NArith.

Require Import basics.
Require Import categories.
Require Import preord.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import plotkin.
Require Import profinite.
Require Import embed.
Require Import joinable.
Require Import directed.
Require Import cont_functors.
Require Import bilimit.

(**  * Sum and product functors

     Here we define the functors for sum and produce in the category
     of embeddings and show that they are continuous.
  *)

Section prod_functor.
  Variable hf:bool.
  Variables A B C D:ob (EMBED hf).

  Variable f:A ⇀ B.
  Variable g:C ⇀ D.

  Program Definition prod_fmap : PLT.prod A C ⇀ PLT.prod B D
    := Embedding hf (PLT.prod A C) (PLT.prod B D) (fun x => (f (fst x), g (snd x)))
         _ _ _ _.
  Next Obligation.
    intros. destruct a as [a c]. destruct a' as [a' c']. simpl.
    destruct H. simpl in *.
    split; simpl; apply embed_mono; auto.
  Qed.
  Next Obligation.
    intros. destruct a as [a c]. destruct a' as [a' c']. simpl.
    destruct H. simpl in *.
    split; simpl.
    - apply embed_reflects in H. auto.
    - apply embed_reflects in H0. auto.
  Qed.
  Next Obligation.
    intros [b d]. simpl.
    destruct hf; auto.
    simpl.
    destruct (embed_directed0 f b).
    destruct (embed_directed0 g d).
    exists (x,x0). simpl. split; auto.
  Qed.
  Next Obligation.
    intros.
    destruct a as [a c].
    destruct b as [a' c']. simpl in *.
    destruct (embed_directed2 f (fst y) a a') as [p [?[??]]].
    - destruct H; auto.
    - destruct H0; auto.
    - destruct (embed_directed2 g (snd y) c c') as [q [?[??]]].
      + destruct H; auto.
      + destruct H0; auto.
      + exists (p,q). simpl.
        repeat split; auto.
  Qed.

End prod_functor.

Program Definition prodF hf
  : functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf) :=

  Functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf)
     (fun (AB:ob (PROD (EMBED hf) (EMBED hf))) =>
         PLT.prod (@obl (EMBED hf) (EMBED hf) AB)
                  (@obr (EMBED hf) (EMBED hf) AB))
     (fun (AB CD:ob (PROD (EMBED hf) (EMBED hf))) (f:AB → CD) =>
       prod_fmap hf _ _ _ _
         (@homl (EMBED hf) (EMBED hf) AB CD f)
         (@homr (EMBED hf) (EMBED hf) AB CD f))
     _ _ _.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  apply embed_lift'; simpl; intros.
  destruct x as [x y]. simpl.
  destruct H. simpl in *.
  destruct H; destruct H0; split; split; simpl; auto.
  - apply H.
  - apply H0.
  - apply H1.
  - apply H2.
Qed.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  destruct g; simpl in *.
  destruct h; simpl in *.
  destruct H; simpl in *.
  apply embed_lift'; simpl; intros.
  split; split; simpl.
  - rewrite H. auto.
  - rewrite H0; auto.
  - rewrite H; auto.
  - rewrite H0; auto.
Qed.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  destruct g; simpl in *.
  destruct H; simpl in *.
  apply embed_lift'; simpl; intros.
  split; split; simpl.
  - rewrite H. auto.
  - rewrite H0; auto.
  - rewrite H; auto.
  - rewrite H0; auto.
Qed.

Lemma prodF_continuous hf : continuous_functor (prodF hf).
Proof.
  hnf; intros.
  apply decompose_is_colimit.
  simpl. intros.
  destruct x as [x y].
  generalize (fstF_continuous _ _ I DS CC X). intros.
  generalize (sndF_continuous _ _ I DS CC X). intros.
  destruct (colimit_decompose hf I _ _ X0 x) as [i [x' ?]].
  destruct (colimit_decompose hf I _ _ X1 y) as [j [y' ?]].
  simpl in *.
  destruct (choose_ub I i j) as [k [??]].
  exists k.
  exists (homl (ds_hom DS i k H) x', homr (ds_hom DS j k H0) y').
  simpl.
  generalize (cocone_commute CC i k H).
  generalize (cocone_commute CC j k H0).
  intros. destruct H1. destruct H2.
  rewrite H2 in e.
  rewrite H3 in e0.
  simpl in *.
  destruct e; destruct e0; split; split; auto.
Qed.

Section sum_functor.
  Variable hf:bool.
  Variables A B C D:ob (EMBED hf).

  Variable f:A ⇀ B.
  Variable g:C ⇀ D.

  Definition sum_fmap_func (x:A+C) : B+D :=
    match x with
    | inl a => inl (f a)
    | inr b => inr (g b)
    end.

  Program Definition sum_fmap : PLT.sum A C ⇀ PLT.sum B D
    := Embedding hf (PLT.sum A C) (PLT.sum B D) sum_fmap_func _ _ _ _.
  Next Obligation.
    intros. destruct a as [a|c].
    - destruct a' as [a'|c']; simpl.
      + apply embed_mono; auto.
      + elim H.
    - destruct a' as [a'|c']; simpl.
      + elim H.
      + apply embed_mono; auto.
  Qed.
  Next Obligation.
    intros.
    destruct a as [a|c].
    - destruct a' as [a'|c']. simpl.
      + simpl in H. red in H. simpl in H.
        apply embed_reflects in H. auto.
      + elim H.
    - destruct a' as [a'|c']. simpl.
      + destruct H.
      + red in H. simpl in H.
        apply embed_reflects in H. auto.
  Qed.
  Next Obligation.
    intro y. simpl in *. unfold sum_fmap_func.
    destruct hf; auto.
    destruct y as [b|d].
    - destruct (embed_directed0 f b).
      exists (inl x). auto.
    - destruct (embed_directed0 g d).
      exists (inr x). auto.
  Qed.
  Next Obligation.
    intros.
    destruct y as [y|y].
    - destruct a as [a|a]; [ | elim H ].
      destruct b as [b|b]; [ | elim H0 ].
      unfold sum_fmap_func in *.
      destruct (embed_directed2 f y a b) as [p [?[??]]]; auto.
      exists (inl p). auto.
    - destruct a as [a|a]; [ elim H |].
      destruct b as [b|b]; [ elim H0 |].
      unfold sum_fmap_func in *.
      destruct (embed_directed2 g y a b) as [p [?[??]]]; auto.
      exists (inr p). auto.
  Qed.
End sum_functor.

Program Definition sumF hf
  : functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf) :=

  Functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf)
     (fun (AB:ob (PROD (EMBED hf) (EMBED hf))) =>
         PLT.sum (@obl (EMBED hf) (EMBED hf) AB)
                 (@obr (EMBED hf) (EMBED hf) AB))
     (fun (AB CD:ob (PROD (EMBED hf) (EMBED hf))) (f:AB → CD) =>
       sum_fmap hf _ _ _ _
         (@homl (EMBED hf) (EMBED hf) AB CD f)
         (@homr (EMBED hf) (EMBED hf) AB CD f))
     _ _ _.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  apply embed_lift'; simpl; intros.
  destruct x as [x|x]; simpl.
  - destruct H. simpl in *.
    destruct H; split; [ apply H | apply H1 ].
  - destruct H. simpl in *.
    destruct H0. split; [ apply H0 | apply H1 ].
Qed.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  destruct g; simpl in *.
  destruct h; simpl in *.
  destruct H; simpl in *.
  apply embed_lift'; simpl; intros.
  unfold sum_fmap_func.
  destruct x as [x|x].
  - destruct H; split; [ apply H | apply H1 ].
  - destruct H0; split; [ apply H0 | apply H1 ].
Qed.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  destruct g; simpl in *.
  destruct H; simpl in *.
  apply embed_lift'; simpl; intros.
  unfold sum_fmap_func.
  destruct x as [x|x].
  - destruct H; split; [apply H | apply H1 ].
  - destruct H0; split; [ apply H0 | apply H1 ].
Qed.

Lemma sumF_continuous hf : continuous_functor (sumF hf).
Proof.
  hnf; intros.
  apply decompose_is_colimit.
  simpl. intros.
  destruct x as [x|x].
  - generalize (fstF_continuous _ _ I DS CC X). intros.
    destruct (colimit_decompose hf I _ _ X0 x) as [i [x' ?]].
    exists i. exists (inl x').
    simpl. destruct e; auto.
  - generalize (sndF_continuous _ _ I DS CC X). intros.
    destruct (colimit_decompose hf I _ _ X0 x) as [i [x' ?]].
    exists i. exists (inr x').
    simpl. destruct e; auto.
Qed.


From mathcomp Require Import all_ssreflect all_algebra all_fingroup.

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

Section Grid.

(******************************************************************************)
(*                                                                            *)
(*                           MODELISATION                                     *)
(*                                                                            *)
(******************************************************************************)

(* Une grille c'est 9 entiers                                                 *)
(*     0 1 2                                                                  *)
(*     3 4 5                                                                  *)
(*     6 7 8                                                                  *)

Definition grid := (nat * nat * nat * nat * nat * nat * nat * nat * nat)%type.

(* Les index pour les cases                                                   *)

Definition index := 'I_9.

(* Grille initiale                                                            *)

Definition grid0 : grid := (0, 0, 0, 0, 0, 0, 0, 0, 0).

(* Retourne la valeur d'une case                                              *)

Definition get (g : grid)  (i : index) : nat :=
  let: (a0, a1, a2, a3, a4, a5, a6, a7, a8) := g in
  if i == 0 :> nat then a0 else
  if i == 1 :> nat then a1 else
  if i == 2 :> nat then a2 else
  if i == 3 :> nat then a3 else
  if i == 4 :> nat then a4 else
  if i == 5 :> nat then a5 else
  if i == 6 :> nat then a6 else
  if i == 7 :> nat then a7 else a8.

(* Calcule la somme des éléments voisins pour un index donné                  *)

Definition sum (g : grid)  (i : index) : nat :=
  let: (a0, a1, a2, a3, a4, a5, a6, a7, a8) := g in
  if i == 0 :> nat then a1 + a3 + a4 else
  if i == 1 :> nat then a0 + a2 + a3 + a4 + a5 else
  if i == 2 :> nat then a1 + a4 + a5 else
  if i == 3 :> nat then a0 + a1 + a4 + a6 + a7 else
  if i == 4 :> nat then a0 + a1 + a2 + a3 + a5 + a6 + a7 + a8 else
  if i == 5 :> nat then a1 + a2 + a4 + a7 + a8 else
  if i == 6 :> nat then a3 + a4 + a7 else
  if i == 7 :> nat then a3 + a4 + a5 + a6 + a8
                   else a4 + a5 + a7.

(* Fonction de mise à jour générique, la fonction f donne la valeur à mettre  *)

Definition update (g : grid) f (i : index) :=
let: (a1, a2, a3, a4, a5, a6, a7, a8, a9) := g in
let b := f g i in
   if i == 0 :> nat then ( b, a2, a3, a4, a5, a6, a7, a8, a9) else
   if i == 1 :> nat then (a1,  b, a3, a4, a5, a6, a7, a8, a9) else
   if i == 2 :> nat then (a1, a2,  b, a4, a5, a6, a7, a8, a9) else
   if i == 3 :> nat then (a1, a2, a3,  b, a5, a6, a7, a8, a9) else
   if i == 4 :> nat then (a1, a2, a3, a4,  b, a6, a7, a8, a9) else
   if i == 5 :> nat then (a1, a2, a3, a4, a5,  b, a7, a8, a9) else
   if i == 6 :> nat then (a1, a2, a3, a4, a5, a6,  b, a8, a9) else
   if i == 7 :> nat then (a1, a2, a3, a4, a5, a6, a7,  b, a9)
                    else (a1, a2, a3, a4, a5, a6, a7, a8,  b).

(* Ajouter un 1 en position i                                                 *)

Definition o_update g i := update g (fun g i => 1) i.

(* Ajouter la somme des voisins en position i                                 *)

Definition s_update g i := update g sum i.

(* Un parcours dans la grille c'est une permutation de toutes les cases       *)

Definition walk := 'S_9.

(* Calcule la grille pour le parcours w                                       *)

Definition w_update g (w : index -> index) :=
 (* on ajoute tous d'abord deux 1                                             *)
 (let g0 := o_update g  (w 0%:R) in
  let g1 := o_update g0 (w 1%:R) in
 (* et ensuite des sommes                                                     *)
  let g2 := s_update g1 (w 2%:R) in
  let g3 := s_update g2 (w 3%:R) in
  let g4 := s_update g3 (w 4%:R) in
  let g5 := s_update g4 (w 5%:R) in
  let g6 := s_update g5 (w 6%:R) in
  let g7 := s_update g6 (w 7%:R) in
  let g8 := s_update g7 (w 8%:R) in
  g8)%R.

Definition w_val w :=
  let g1 := w_update grid0 w in get g1 (w 8%:R)%R.

(* Ce que l'on veut prouver \max_(w : path) (w_val w) = 53, on fait cela par  *)
(* du calcul prouvé                                                           *)

Check \max_(w : walk) (w_val w).

(******************************************************************************)
(*                                                                            *)
(*                           CALCUL                                           *)
(*                                                                            *)
(******************************************************************************)

(* Toutes les façons d'insérer un élements dans une liste                     *)

Fixpoint insertl A (i : A) (l : seq A) : seq (seq A) :=
  (i :: l) ::
    if l is a :: l' then [seq a :: l | l <- insertl i l']
   else [::].

(* Calcul le max de f sur toutes les permutations.                            *)

Fixpoint get_max (n m : nat) (max : nat) f (l : seq 'I_m.+2)  :=
  if n is n1.+1 then
  let ls := insertl (n1%:R)%R l in
  foldr (fun l max => get_max n1 max f l) max ls
  else maxn max (f l).

Definition f_of_l n (l : seq 'I_n) (i : 'I_n) := nth i l i.

(* Calcul du maximum                                                          *)

Definition all_max :=
  get_max 9 0 (fun l => w_val (f_of_l l)) [::].

Lemma all_max_57 : all_max = 57.
Proof. by vm_compute. Qed.

(******************************************************************************)
(*                                                                            *)
(*                           PREUVE                                           *)
(*                                                                            *)
(******************************************************************************)

Lemma mem_insertl (A : eqType) (i : A) (l l1 : seq A) :
  l1 \in insertl i l -> l1 =i i :: l.
Proof.
elim: l l1 => //= [|a l IH] l1; rewrite in_cons => /orP[/eqP->|] //.
case/mapP=> l2 /IH l2Iil -> i1.
rewrite !in_cons; case: (i1 == _); first by rewrite orbT.
by rewrite l2Iil !orFb.
Qed.

Lemma size_insertl (A : eqType) (i : A) (l l1 : seq A) :
  l1 \in insertl i l -> size l1 = (size l).+1.
Proof.
elim: l l1 => //= [|a l IH] l1; rewrite in_cons => /orP[/eqP->|] //.
by case/mapP=> l2 /IH <- ->.
Qed.

(* Une liste ordonnée par rapport à une permutation                           *)

Definition ordLS (n : nat) (p : 'S_n) l :=
  sorted (fun x y => p^-1%g x < p^-1%g y) l.

Lemma ordLSE n p a b (l : seq 'I_n) :
  ordLS p [:: a, b & l] = (p^-1 a < p^-1 b)%g && ordLS p [:: b & l].
Proof. by []. Qed.

Lemma ordLS_in n p a b (l : seq 'I_n) :
  ordLS p (a :: l) -> b \in l -> p^-1%g a < p^-1%g b.
Proof.
move=> oC bIl.
have /subseq_path/(_ oC) : subseq [:: b] l by rewrite sub1seq.
by rewrite /= andbT => -> // x y z; apply: ltn_trans.
Qed.

Lemma ordLS_nth n p (l : seq 'I_n.+1) i j :
  ordLS p l -> i < j < size l -> p^-1%g (nth ord0 l i) < p^-1%g (nth ord0 l j).
Proof.
elim: l i j => // [i [|j]| a l IH [|i] [|j] Ol iLj] //; try by rewrite andbC.
  by apply: (ordLS_in Ol); apply: mem_nth; case/andP: iLj.
by apply: IH => //; case: (l) Ol => // a1 l1 /andP[].
Qed.

Lemma ordLS_nth_ge n p (l : seq 'I_n.+1) i :
  ordLS p l -> i < size l -> i <= p^-1%g (nth ord0 l i).
Proof.
move=> Ol; elim: i => // i IH iLs.
have /(ordLS_nth Ol) : i < i.+1 < size l by rewrite leqnn.
by apply/leq_trans/IH/(leq_trans _ iLs).
Qed.

Lemma ordLS_nth_le n p (l : seq 'I_n.+1) i :
  ordLS p l -> i < size l -> p^-1%g (nth ord0 l i) <= n - (size l - i.+1).
Proof.
case: l => // a l Ol.
rewrite [size _]/= ltnS subSS => /subKn -{1}<-.
elim: (_ - i) (leq_subr i (size l)) => [_|i1 IH i1Ls].
  by rewrite !subn0 -ltnS ltn_ord.
rewrite -ltnS.
have /(leq_trans _)-> // :  n -i1 <= (n - i1.+1).+1.
  case: (ltnP i1 n)=> [HH|]; first by rewrite -subSn //.
  by rewrite -subn_eq0 => /eqP->.
apply: leq_trans (IH (ltnW i1Ls)).
apply: ordLS_nth => //; rewrite ltn_sub2l //.
by apply: (leq_trans (leq_subr _ _)).
Qed.

Lemma ordLS_enum n p (l : seq 'I_n.+1) :
  ordLS p l -> (size l == n.+1) = (l == [seq p i | i <- enum 'I_n.+1]).
Proof.
move=> Ol; apply/eqP/eqP=> [sE|->]; last by rewrite size_map size_enum_ord.
apply: (@eq_from_nth _ ord0) => [|i iLs].
   by rewrite size_map size_enum_ord.
rewrite (nth_map ord0) ?size_enum_ord -1?sE //.
apply: (@perm_inj _ p^-1%g); rewrite permK.
apply/val_eqP => /=.
rewrite eqn_leq !nth_enum_ord -1?sE // ordLS_nth_ge //.
have {2}->: i = n - (size l - i.+1).
  by rewrite sE subSS subKn // -ltnS -sE.
by rewrite ordLS_nth_le.
Qed.

Lemma insertl_ordLS n (p : 'S_n.+2) i (l : seq 'I_n.+2) :
  i \notin l -> ordLS p l -> exists l1, (l1 \in insertl i l) && ordLS p l1.
Proof.
elim: l i => [i _ _|a l IH i iNal Oal] //.
- by exists [:: i]; rewrite mem_head.
have Ol : ordLS p l.
  by case: (l) Oal => //= b l1; rewrite /ordLS /= => /andP[].
have oNl : i \notin l.
  by apply: contra iNal; rewrite in_cons orbC => ->.
case: (ltnP (p^-1%g i) (p^-1%g a)) => [iLa|].
  by exists [:: i, a & l]; rewrite mem_head /ordLS /= iLa.
rewrite leq_eqVlt=> /orP[|aLi].
  by move/val_eqP/perm_inj=> aLi; move: iNal; rewrite aLi in_cons eqxx.
have [l1 /andP[l1I ppl1]] := IH _ oNl Ol.
exists (a :: l1).
rewrite in_cons mem_map ?l1I ?orbT; last by move=> i1 j1 [].
case: (l1) ppl1 (mem_insertl l1I) => // a1 l2.
rewrite ordLSE => -> a1l2Iil; rewrite andbT andTb.
case: (boolP (a1 == i)) => [/eqP-> //|a1Di].
have := a1l2Iil i; rewrite !in_cons eqxx => /= /idP /orP[/eqP<- //|iIL2].
apply: ordLS_in Oal _.
by have := a1l2Iil a1; rewrite !in_cons eqxx (negPf a1Di) /= => <-.
Qed.

Lemma w_val_eq (f1 f2 : index -> index) : f1 =1 f2 -> w_val f1 = w_val f2.
Proof.
move=> f1Ef2.
congr (get _ _); last by rewrite f1Ef2.
by rewrite /w_update !f1Ef2.
Qed.

Lemma leq_get_max m k v f (l : seq 'I_m.+2) : v <= get_max k v f l.
Proof.
elim: k v l => /= [|k IH] v l; first by apply: leq_maxl.
by elim: insertl => //= a l1 IH1; apply: leq_trans (IH _ _).
Qed.

(* On peut enfin prouver le résultat voulu                                    *)

Lemma result : \max_(w : walk) (w_val w) = 57.
Proof.
apply/eqP; rewrite eqn_leq; apply/andP; split; last first.
  pose l : seq 'I_9 := ([::0%:R;2%:R;1%:R;3%:R;4%:R;6%:R;7%:R;5%:R;8%:R])%R.
  have Il :  injectiveb [ffun i => f_of_l l i].
    apply: perm_proof => [].
    by (do 10 try case => //) => i; (do 10 try case => //) => j;
    rewrite /f_of_l //= => /val_eqP /= HH; apply/val_eqP.
  have<-: w_val (f_of_l l) = 57 by vm_compute.
  have/w_val_eq<- : Perm Il =1 f_of_l l.
    by move=> x; rewrite [@fun_of_perm]unlock /= ffunE.
  by exact: (@leq_bigmax _ (fun p : 'S_9 => w_val p) (Perm Il)).
apply/bigmax_leqP=> /= p _; rewrite -all_max_57 /all_max.
have: (forall i : 'I_9 , i \in [::] -> 9 <= i) by [].
have: ordLS p [::] by [].
have: size ([::] : seq 'I_9) + 9 = 9 by [].
suff F n l m :
  size l + n = 9 -> ordLS p l -> (forall i : 'I_9, i \in l -> n <= i) ->
  w_val p <= get_max n m (fun l0 : seq 'I_9 => w_val (f_of_l l0)) l.
    by apply: F.
elim: n l m => /= [|k IH] l v Es Ol Ltk.
  move/eqP: Es; rewrite addn0 (ordLS_enum Ol) => /eqP->.
  set f := f_of_l _; suff /w_val_eq-> : f =1 p by apply: leq_maxr.
  by move=> i; rewrite /f /f_of_l (nth_map ord0) ?size_enum_ord // nth_ord_enum.
have kE : (k%:R : 'I_9)%R = k :> nat.
  have kL9 : k < 9 by rewrite -Es addnS ltnS leq_addl.
  by rewrite (natr_Zp (Ordinal kL9)).
have kNIl : (k%:R)%R \notin l by apply/negP => /Ltk; rewrite kE ltnn.
have [l1 /andP[l1Ii Ol1]] := insertl_ordLS kNIl Ol.
have HH  : forall v,  w_val p <= get_max k v (fun l => w_val (f_of_l l)) l1.
  move=> v1; apply: IH => //.
    by rewrite (size_insertl l1Ii) -[X in _ = X]Es addnS.
  move=> i; rewrite (mem_insertl l1Ii) in_cons => /orP[/eqP->|] //.
    by rewrite kE.
  by move=> iIl; apply/ltnW/Ltk.
elim: insertl l1Ii => //= a1 l2 IH1.
rewrite in_cons => /orP[/eqP<-|l1Il2] /=; first by apply: HH.
by apply: leq_trans (IH1 _) (leq_get_max _ _ _ _).
Qed.

End Grid.