Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
Require Import finfun bigop finset.

Axiom SET : Type.

Definition Var := nat.
Definition Term := nat.

(*
Definition equalS : nat := 0.
Definition memS : nat := 1.
Definition notS : nat := 2.
Definition orS : nat := 3.
Definition andS : nat := 4.
Definition implS : nat := 5.
Definition forallS : Term -> nat :=
  fun t => 6.
Definition existsS : Term -> nat :=
  fun t => 7.
*)

Inductive Fml : Type :=
  | equalityS : Var -> Var -> Fml
  | membershipS : Var -> Var -> Fml
  | notS : Fml -> Fml
  | orS : Fml -> Fml -> Fml
  | andS : Fml -> Fml -> Fml
  | implS : Fml -> Fml -> Fml
  | forallS : Var -> Fml -> Fml
  | existsS : Var -> Fml -> Fml.

Notation "x _=_ y" := (equalityS x y) (at level 50).
Notation "x _∈_ y" := (membershipS x y) (at level 50).
Notation "￢ x" := (notS x) (at level 51).
Notation "x ∨ y" := (orS x y) (at level 51).
Notation "x ∧ y" := (andS x y) (at level 51).
Notation "x → y" := (implS x y) (at level 51).
Notation "∀ x , y" := (forallS x y) (at level 51).
Notation "∃ x , y" := (existsS x y) (at level 51).

(* Syntactic comparison and eqType for Fml.                                *)

Fixpoint eqFml F G {struct F} :=
  match F, G with
    | equalityS m0 m1, equalityS n0 n1 => (m0 == n0) && (m1 == n1)
    | membershipS m0 m1, membershipS n0 n1 => (m0 == n0) && (m1 == n1)
    | notS F0, notS G0 => eqFml F0 G0
    | orS F0 F1, orS G0 G1 => eqFml F0 G0 && eqFml F1 G1
    | andS F0 F1, andS G0 G1 => eqFml F0 G0 && eqFml F1 G1
    | implS F0 F1, implS G0 G1 => eqFml F0 G0 && eqFml F1 G1
    | forallS m F0, forallS n G0 => (m == n) && eqFml F0 G0
    | existsS m F0, existsS n G0 => (m == n) && eqFml F0 G0
    | _, _ => false
  end.

Lemma eqFmlP : Equality.axiom eqFml.
Proof.
  move=> F G.
  apply (iffP idP); last first; [move => -> //| ].
  - elim: G => //.
    + move=> v v0 /=.
      by apply/andP.
    + move=> v v0 /=.
      by apply/andP.
    + move=> f H f0 H0 => /=.
      by apply/andP.
    + move=> f H f0 H0 => /=.
      by apply/andP.
    + move=> f H f0 H0 => /=.
      by apply/andP.
    + move=> v f H => /=.
      by apply/andP.
    + move=> v f H => /=.
      by apply/andP.

  - move: G; elim F.
    + move=> v v0; case => v1 v2 //=.
      by move/andP; elim => /eqP -> /eqP ->.
    + move=> v v0; case => v1 v2 //=.
      by move/andP; elim => /eqP -> /eqP ->.
    + move=> f H; case => f0 //=.
      by move/H => ->.
    + move=> f H f0 H0; case => f1 f2 //=.
      by move/andP; elim => /H -> /H0 ->.
    + move=> f H f0 H0; case => f1 f2 //=.
      by move/andP; elim => /H -> /H0 ->.
    + move=> f H f0 H0; case => f1 f2 //=.
      by move/andP; elim => /H -> /H0 ->.
    + move=> v f H; case => v0 f0 //=.
      by move/andP; elim => /eqP -> /H ->.
    + move=> v f H; case => v0 f0 //=.
      by move/andP; elim => /eqP -> /H ->.
Qed.

Canonical Fml_eqMixin := EqMixin eqFmlP.
Canonical Fml_eqType := Eval hnf in EqType Fml Fml_eqMixin.

Implicit Arguments eqFmlP [x y].
Prenex Implicits eqFmlP.

Lemma eqFmlE : eqFml = eq_op. Proof. by []. Qed.

Lemma Fml_irrelevance (F G : nat) (E E' : F = G) : E = E'.
Proof. exact: eq_irrelevance. Qed.

(* eqType準備ここまで *)

Definition X : Fml := 0 _=_ 0 ∧ 1 _=_ 1.

Definition is_atomic (f : Fml) : bool :=
  match f with
   | equalityS x y => true
   | membershipS x y => true
   | _ => false
  end.

Eval compute in (is_atomic (0 _=_ 0)).

Definition is_bounded_qf (f : Fml) : bool :=
  match f with
   | forallS x f0 =>
     match f0 with
       | implS f0 f1 =>
         match f0 with
           | membershipS z w => (z == x)
           | _ => false
         end
       | _ => false
     end
   | existsS x f0 =>
     match f0 with
       | implS f0 f1 =>
         match f0 with
           | membershipS z w => (z == x)
           | _ => false
         end
       | _ => false
     end
   | _ => false
end.

Eval compute in is_bounded_qf (∀1 , (1 _=_ 0)).
  (* ====> false *)
Eval compute in is_bounded_qf (∀1 , (1 _∈_ 2)).
  (* ====> false *)
Example testcase0: is_bounded_qf (∀1 , ((1 _∈_ 2) → (1 _=_ 3))).
  (* ====> true *)
Proof.
  simpl.
  reflexivity.
Qed.

Definition is_not_qf (f : Fml) : bool :=
  match f with
   | forallS x f0 => false
   | existsS x f0 => false
   | _ => true
  end.

Fixpoint is_quantifier_free (f : Fml) : bool :=
  match f with
   | equalityS x y => true
   | membershipS x y => true
   | notS f0 => (is_quantifier_free f0)
   | orS f0 f1 => (is_quantifier_free f0) && (is_quantifier_free f1)
   | andS f0 f1 => (is_quantifier_free f0) && (is_quantifier_free f1)
   | implS f0 f1 => (is_quantifier_free f0) && (is_quantifier_free f1)
   | forallS x f0 => false
   | existsS x f0 => false
end.

Require Import Datatypes.
Check (sum unit unit).

Definition hoge (a : bool) : (unit + unit) :=
  match a with
  | true => inl tt
  | false => inr tt
  end.

Definition bound_var (f : Fml) : (Var+unit) :=
  match f with
    | implS f0 f1 =>
      match f0 with
        | membershipS z w => inl z
        | _ => inr tt
      end
    | _ => inr tt
  end.

Definition is_membership f :=
  match f with
    | membershipS _ _ => true
    | _ => false
  end.

Fixpoint is_Σ_0 (f : Fml) : bool :=
  match f with
   | equalityS x y => true
   | membershipS x y => true
   | notS f0 => (is_Σ_0 f0)
   | orS f0 f1 => (is_Σ_0 f0) && (is_Σ_0 f1)
   | andS f0 f1 => (is_Σ_0 f0) && (is_Σ_0 f1)
   | implS f0 f1 => (is_Σ_0 f0) && (is_Σ_0 f1)
   | forallS x f0 =>
     match f0 with
       | implS f00 f01 => is_membership f00 && (is_Σ_0 f01)
       | _ => false
     end
   | existsS x f0 =>
     match f0 with
       | andS f00 f01 => is_membership f00 && (is_Σ_0 f01)
       | _ => false
     end
  end.

Axiom membership : SET -> SET -> bool.
Notation "x ∈ y" := (membership x y) (at level 20).
Axiom equality : SET -> SET -> bool.
(*
Axiom V : CLASS.
Axiom SET_Axiom : forall X : CLASS, (exists Y : CLASS, X ∈ Y) -> X ∈ V.
Axiom emptyset : CLASS.
Axiom emptyset_axiom : (emptyset ∈ V).
Axiom one : CLASS.
Axiom one_axiom : (emptyset ∈ one).
*)

Definition is_finOrdSet (x : finType) :=
  exists n : nat, x = ordinal_finType n.

Definition is_AssignOf (M : SET) (n : nat) (f : 'I_n -> SET) :=
  forall i , (f i) ∈ M.

Check {set ordinal_finType 0}.

Check [set set0] :|: [set set0].

Check FinSet [ffun x : 'I_3 => false].
Eval compute in (set_type (ordinal_finType 0)) = ordinal_finType 1.

Definition natSet_of_nat (n : nat) :=
  [set: ordinal_finType n].

Check natSet_of_nat.

Check @Ordinal 10 11.

Check [set @Ordinal 10 1 erefl; @Ordinal 10 2 erefl].
Eval compute in (max 10 9).+1.

Check forall (x y:nat),
          let n := (maxn x.+1 y.+1) in
          (@Ordinal (maxn x.+1 y.+1) x (leq_maxl x.+1 y.+1)) = (@Ordinal (maxn x.+1 y.+1) y (leq_maxr x.+1 y.+1)).

(* sumSet x y := {x , y} of type 'I_{maxn x+1 y+1} *)
Definition sumSet (x y : Var) :=
          let n := (maxn x.+1 y.+1) in
          [set (@Ordinal (maxn x.+1 y.+1) x (leq_maxl x.+1 y.+1)) ; (@Ordinal (maxn x.+1 y.+1) y (leq_maxr x.+1 y.+1))].

Check sumSet.

Fixpoint free_VarSet (f : Fml) :=
  match f with
    | equalityS x y => sumSet x y
    | membershipS x y => sumSet x y
    | notS f0 => (free_VarSet f0)
    | orS f0 f1 => (free_VarSet f0) setU (free_VarSet f1)
    | andS f0 f1 => (free_VarSet f0) setU (free_VarSet f1)
    | implS f0 f1 => (free_VarSet f0) setU (free_VarSet f1)
    | forallS x f0 =>
      match f0 with
        | implS f00 f01 => is_membership f00 && (is_Σ_0 f01)
        | _ => false
      end
    | existsS x f0 =>
      match f0 with
        | andS f00 f01 => is_membership f00 && (is_Σ_0 f01)
        | _ => false
      end
  end.

Fixpoint satisfaction (f : Fml) (M : SET) ( : Prop :=
  match f with
   | equalityS x y => equality (s x) (s y)
   | membershipS x y => membership (nth emptyset s x) (nth one s y)
   | notS f0 => ~(satisfaction f0 M s)
   | orS f0 f1 => (satisfaction f0 M s) \/ (satisfaction f1 M s)
   | andS f0 f1 => (satisfaction f0 M s) /\ (satisfaction f1 M s)
   | implS f0 f1 => (satisfaction f0 M s) -> (satisfaction f1 M s)
   | forallS x f0 => forall y : CLASS, (y ∈ M) -> (satisfaction f0 M (set_nth emptyset s x y))
   | existsS x f0 => exists y : CLASS, (y ∈ M) /\ (satisfaction f0 M (set_nth emptyset s x y))
  end.

Notation "M |= f $ s" := (satisfaction f M s) (at level 30).

Definition transitive (M : CLASS) : Prop :=
  forall x y, (x ∈ M) -> (y ∈ x) -> (y ∈ M).

Definition seq_from (s : seq CLASS) (M : CLASS) : bool :=
  let p := (fun x => (x ∈ M)) in
      all p s.

Definition absolute_forMN (f : Fml) (M : CLASS) (N: CLASS) : Prop :=
  forall s : seq CLASS, (seq_from s M) ->
                        ((M |= f $ s) <-> (N |= f $ s)).

Definition absolute_forM (f : Fml) (M : CLASS) : Prop :=
  absolute_forMN f M V.

Lemma Absoluteness_membership : forall x y : Var, forall (M : CLASS), (transitive M) -> absolute_forM (x _∈_ y) M.
Proof.
  move=>x y M.
  move=> Htrans.
  move=> s.
  move=> HsinM.
  have: (nth emptyset s x) ∈ M.
    have: forall n : Var, (find(nth emptyset x n) ∈ M.


Require Export CommaCategory CategoryIsomorphisms.
Require Import Common Notations DefinitionSimplification Eqdep.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section UniversalMorphism.
  (**
     Quoting Wikipedia:
     Suppose that [U : D -> C] is a functor from a category [D] to a
     category [C], and let [X] be an object of [C].  Consider the
     following dual (opposite) notions:
     *)
  Variable C : Category.
  Variable D : Category.

  Local Ltac intro_t :=
    simpl in *;
    repeat intro;
    simpl_eq;
    destruct_sig;
    destruct_head_hnf prod;
    destruct_head_hnf unit;
    destruct_head_hnf and;
    autorewrite with morphism in *;
    subst;
    intuition.

  Section InitialMorphism.
    Local Notation "A ↓ F" := (CosliceCategory A F).
    Variable X : C.
    Variable U : Functor D C.
    (**
       An initial morphism from [X] to [U] is an initial object in the
       category [(X ↓ U)] of morphisms from [X] to [U].  In other
       words, it consists of a pair [(A, φ)] where [A] is an object of
       [D] and [φ: X -> U A] is a morphism in [C], such that the
       following initial property is satisfied:
       (o) Whenever [Y] is an object of [D] and [f : X -> U Y] is a
           morphism in [C], then there exists a unique morphism
           [g : A -> Y] such that the following diagram commutes:
       [[
             φ
         X -----> U A       A
          \        .        .
            \      . U g    . g
           f  \    .        .
               ↘  ↓        ↓
                 U Y        Y

       ]]
       *)
    Definition IsInitialMorphism (Aφ : (X ↓ U)) := IsInitialObject Aφ.
    Definition InitialMorphism := InitialObject (X ↓ U).

    Section coercions.
      Definition InitialMorphism_IsInitialMorphism : forall o : InitialMorphism, IsInitialMorphism o
        := InitialObject_IsInitialObject (C := (X ↓ U)).
      Definition IsInitialMorphism_InitialMorphism : forall o, IsInitialMorphism o -> InitialMorphism
        := IsInitialObject_InitialObject (C := (X ↓ U)).

      Global Coercion InitialMorphism_IsInitialMorphism : InitialMorphism >-> IsInitialMorphism.
      Global Coercion IsInitialMorphism_InitialMorphism : IsInitialMorphism >-> InitialMorphism.
    End coercions.

    Section IntroductionAbstractionBarrier.
      Definition Build_InitialMorphism'
                 (UniversalProperty : { A : D & { φ : Morphism C X (U A) &
                                              (*UniversalProperty : *)
                                              forall (A' : D) (φ' : Morphism C X (U A')),
                                                { m : Morphism D A A' |
                                                  Compose (MorphismOf U m) φ = φ'
                                                  /\
                                                  forall m' : Morphism D A A',
                                                    Compose (MorphismOf U m') φ = φ'
                                                    -> m' = m } } })
      : InitialMorphism.
        pose proof (projT2 UniversalProperty) as φUniversalProperty;
        set (A := projT1 UniversalProperty) in *;
        clearbody A; clear UniversalProperty; simpl in *.
        pose proof (projT2 φUniversalProperty) as UniversalProperty;
        set (φ := projT1 φUniversalProperty) in *;
        clearbody φ; clear φUniversalProperty; simpl in *.
        refine (_ : IsInitialMorphism (existT _ (tt, A) φ)).
        intro o'.
        specialize (UniversalProperty (snd (projT1 o')) (projT2 o')).
        match goal with
          | [ |- { _ : ?T | _ } ] => match eval hnf in T with
                                       | sig ?P => cut (P (@unit_eq _ _, proj1_sig UniversalProperty));
                                                  [ let H := fresh in
                                                    intro H;
                                                      exists (exist _ (@unit_eq _ _, proj1_sig UniversalProperty) H)
                                                  | ]
                                     end
        end;
          abstract intro_t.
      Defined.

      Arguments Build_InitialMorphism' / .
      Local Arguments Object / .
      Local Arguments CommaCategory_Object / .
      Local Arguments CommaCategory_Morphism / .

      Definition Build_InitialMorphism A φ UniversalProperty : InitialMorphism
        := Eval simpl in @Build_InitialMorphism' (existT _ A (existT _ φ UniversalProperty)).
    End IntroductionAbstractionBarrier.

    Section EliminationAbstractionBarrier.
      Variable M : InitialMorphism.

      Definition InitialMorphism_Object : D := snd (projT1 (InitialObject_Object M)).
      Definition InitialMorphism_Morphism : C.(Morphism) X (U (InitialMorphism_Object)) := projT2 (InitialObject_Object M).
      Definition InitialProperty_Morphism (Y : D) (f : C.(Morphism) X (U Y)) : D.(Morphism) InitialMorphism_Object Y
        := snd (proj1_sig (InitialObject_Morphism M (existT (fun ttY => C.(Morphism) X (U (snd ttY))) (tt, Y) f))).
      (* TODO: Automate this better *)
      Lemma InitialProperty (Y : D) (f : C.(Morphism) X (U Y)) :
        unique (fun g => Compose (U.(MorphismOf) g) InitialMorphism_Morphism = f) (InitialProperty_Morphism Y f).
        unfold InitialProperty_Morphism, InitialMorphism_Object, InitialMorphism_Morphism in *.
        split;
        [ intro_proj2_sig_from_goal; autorewrite with morphism in *; assumption
        | abstract (
              intros ? H;
              (* make sure the type of H is right *)
              match type of H with
                | Compose _ _ = f =>
                  (symmetry in H;
                   rewrite <- RightIdentity in H at 1;
                   symmetry in H)
              end;
              symmetry;
              exact (f_equal (@snd _ _)
                             (f_equal (@proj1_sig _ _)
                                      (InitialObject_Property M (existT _ (tt, _) f) (exist _ (unit_eq _ _, _) H))))
            )
        ].
      Qed.
    End EliminationAbstractionBarrier.
  End InitialMorphism.

  Section TerminalMorphism.
    Local Notation "F ↓ A" := (SliceCategory A F).
    Variable U : Functor D C.
    Variable X : C.
    (**
       A terminal morphism from [U] to [X] is a terminal object in the
       comma category [(U ↓ X)] of morphisms from [U] to [X].  In
       other words, it consists of a pair [(A, φ)] where [A] is an
       object of [D] and [φ : U A -> X] is a morphism in [C], such
       that the following terminal property is satisfied:
       (o) Whenever [Y] is an object of [D] and [f : U Y -> X] is a
           morphism in [C], then there exists a unique morphism
           [g : Y -> A] such that the following diagram commutes:
       [[
         Y      U Y
         .       . \
       g .   U g .   \  f
         .       .     \
         ↓       ↓       ↘
         A      U A -----> X
                      φ
       ]]
       *)
    Definition IsTerminalMorphism (Aφ : (U ↓ X)) := IsTerminalObject Aφ.
    Definition TerminalMorphism := TerminalObject (U ↓ X).

    Section coercions.
      Definition TerminalMorphism_IsTerminalMorphism : forall o : TerminalMorphism, IsTerminalMorphism o
        := TerminalObject_IsTerminalObject (C := (U ↓ X)).
      Definition IsTerminalMorphism_TerminalMorphism : forall o, IsTerminalMorphism o -> TerminalMorphism
        := IsTerminalObject_TerminalObject (C := (U ↓ X)).

      Global Coercion TerminalMorphism_IsTerminalMorphism : TerminalMorphism >-> IsTerminalMorphism.
      Global Coercion IsTerminalMorphism_TerminalMorphism : IsTerminalMorphism >-> TerminalMorphism.
    End coercions.

    Section IntroductionAbstractionBarrier.
      Definition Build_TerminalMorphism'
                 (UniversalProperty : { A : D & { φ : Morphism C (U A) X &
                                                               (*UniversalProperty : *)
                                                               forall (A' : D) (φ' : Morphism C (U A') X),
                                                                 { m : Morphism D A' A |
                                                                   Compose φ (MorphismOf U m) = φ'
                                                                   /\
                                                                   forall m' : Morphism D A' A,
                                                                     Compose φ (MorphismOf U m') = φ'
                                                                     -> m' = m } } })
      : TerminalMorphism.
        pose proof (projT2 UniversalProperty) as φUniversalProperty;
        set (A := projT1 UniversalProperty) in *;
        clearbody A; clear UniversalProperty; simpl in *.
        pose proof (projT2 φUniversalProperty) as UniversalProperty;
        set (φ := projT1 φUniversalProperty) in *;
        clearbody φ; clear φUniversalProperty; simpl in *.
        refine (_ : IsTerminalMorphism (existT _ (A, tt) φ)).
        intro o'.
        specialize (UniversalProperty (fst (projT1 o')) (projT2 o')).
        match goal with
          | [ |- { _ : ?T | _ } ] => match eval hnf in T with
                                       | sig ?P => cut (P (proj1_sig UniversalProperty, @unit_eq _ _));
                                                  [ let H := fresh in
                                                    intro H;
                                                      exists (exist _ (proj1_sig UniversalProperty, @unit_eq _ _) H)
                                                  | ]
                                     end
        end;
          abstract intro_t.
      Defined.

      Arguments Build_TerminalMorphism' / .
      Local Arguments Object / .
      Local Arguments CommaCategory_Object / .
      Local Arguments CommaCategory_Morphism / .

      Definition Build_TerminalMorphism A φ UniversalProperty : TerminalMorphism
        := Eval simpl in @Build_TerminalMorphism' (existT _ A (existT _ φ UniversalProperty)).
    End IntroductionAbstractionBarrier.

    Section AbstractionBarrier.
      Variable M : TerminalMorphism.

      Definition TerminalMorphism_Object : D := fst (projT1 (TerminalObject_Object M)).
      Definition TerminalMorphism_Morphism : C.(Morphism) (U (TerminalMorphism_Object)) X := projT2 (TerminalObject_Object M).
      Definition TerminalProperty_Morphism (Y : D) (f : C.(Morphism) (U Y) X) : D.(Morphism) Y TerminalMorphism_Object
        := fst (proj1_sig (TerminalObject_Morphism M (existT (fun Ytt => C.(Morphism) (U (fst Ytt)) X) (Y, tt) f))).
      (* TODO: Automate this better *)
      Lemma TerminalProperty (Y : D) (f : C.(Morphism) (U Y) X) :
        unique (fun g => Compose TerminalMorphism_Morphism (U.(MorphismOf) g) = f) (TerminalProperty_Morphism Y f).
        unfold TerminalProperty_Morphism, TerminalMorphism_Object, TerminalMorphism_Morphism in *;
          simpl in *.
        split;
        [ intro_proj2_sig_from_goal; symmetry in H (* WTF? *); autorewrite with morphism in *; assumption
        | unfold InitialMorphism, TerminalMorphism in *; (* WTF type error *)
          abstract (
              intros ? H;
              (* make sure the type of H is right *)
              match type of H with
                | Compose _ _ = f =>
                  (symmetry in H;
                   rewrite <- LeftIdentity in H at 1)
              end;
              symmetry;
              exact (f_equal (@fst _ _)
                             (f_equal (@proj1_sig _ _)
                                      (TerminalObject_Property M (existT _ (_, tt) f) (exist _ (_, unit_eq _ _) H))))
            )
        ].
      Qed.
    End AbstractionBarrier.
  End TerminalMorphism.

  Section UniversalMorphism.
    Variable U : Functor D C.
    Variable X : C.
    (**
       The term universal morphism refers either to an initial
       morphism or a terminal morphism, and the term universal
       property refers either to an initial property or a terminal
       property.  In each definition, the existence of the morphism
       [g] intuitively expresses the fact that [(A, φ)] is ``general
       enough'', while the uniqueness of the morphism ensures that
       [(A, φ)] is ``not too general''.
       *)
    Definition UniversalMorphism := ((InitialMorphism X U) + (TerminalMorphism U X))%type.

    Section AbstractionBarrier.
      Variable M : UniversalMorphism.

      Definition UniversalMorphism_Object : D :=
        match M with
          | inl M' => InitialMorphism_Object M'
          | inr M' => TerminalMorphism_Object M'
        end.
      Definition UniversalMorphism_Morphism :
        match M with
          | inl _ => Morphism C X (U (UniversalMorphism_Object))
          | inr _ => Morphism C (U (UniversalMorphism_Object)) X
        end.
        unfold UniversalMorphism_Object; destruct M; simpl;
          eapply InitialMorphism_Morphism || eapply TerminalMorphism_Morphism.
      Defined.
      Definition UniversalProperty_Morphism
        (Y : D)
        (f : match M with
               | inl _ => Morphism C X (U Y)
               | inr _ => Morphism C (U Y) X
             end) :
        match M with
          | inl _ => Morphism D UniversalMorphism_Object Y
          | inr _ => Morphism D Y UniversalMorphism_Object
        end.
        unfold UniversalMorphism_Object; destruct M; simpl;
          eapply InitialProperty_Morphism || eapply TerminalProperty_Morphism;
            assumption.
      Defined.

      Definition UniversalPropertyT (Y : D) : Type.
        assert (m := UniversalMorphism_Morphism).
        assert (m' := UniversalProperty_Morphism Y).
        destruct M; simpl in *.
        exact (forall f : Morphism C X (U Y),
          unique
          (fun g : Morphism D UniversalMorphism_Object Y =>
            Compose (MorphismOf U g) m = f)
          (m' f)
        ).
        exact (forall f : Morphism C (U Y) X,
          unique
          (fun g : Morphism D Y UniversalMorphism_Object =>
            Compose m (MorphismOf U g) = f)
          (m' f)
        ).
      Defined.

      Definition UniversalProperty'
        (Y : D) : { T : Type & T }.
        destruct M as [ m | m ].
        exact (existT _ _ (InitialProperty m Y)).
        exact (existT _ _ (TerminalProperty m Y)).
      Defined.

      Definition UniversalProperty'' (Y : D) : { A : Type & A }.
        simpl_definition_by_tac_and_exact (UniversalProperty' Y) ltac:( unfold UniversalProperty in * ).
      Defined.

      Definition UniversalProperty (Y : D) := Eval cbv beta iota zeta delta [UniversalProperty' UniversalProperty''] in projT2 (UniversalProperty'' Y).
    End AbstractionBarrier.
  End UniversalMorphism.
End UniversalMorphism.

Arguments Build_InitialMorphism [C D] X U A φ UniversalProperty.
Arguments Build_TerminalMorphism [C D] U X A φ UniversalProperty.

Ltac intro_from_universal_objects :=
  repeat match goal with
           | [ |- appcontext[TerminalMorphism_Object ?x] ] => unique_pose_with_body x
           | [ _ : appcontext[TerminalMorphism_Object ?x] |- _ ] => unique_pose_with_body x
           | [ |- appcontext[InitialMorphism_Object ?x] ] => unique_pose_with_body x
           | [ _ : appcontext[InitialMorphism_Object ?x] |- _ ] => unique_pose_with_body x
           | [ |- appcontext[UniversalMorphism_Object ?x] ] => unique_pose_with_body x
           | [ _ : appcontext[UniversalMorphism_Object ?x] |- _ ] => unique_pose_with_body x
         end.

Ltac intro_universal_objects :=
  repeat match goal with
           | [ m : TerminalMorphism _ _ |- _ ] => unique_pose_with_body (TerminalMorphism_Object m)
           | [ m : InitialMorphism _ _ |- _ ] => unique_pose_with_body (InitialMorphism_Object m)
           | [ m : UniversalMorphism _ _ |- _ ] => unique_pose_with_body (UniversalMorphism_Object m)
         end.

Ltac intro_universal_morphisms := intro_from_universal_objects;
  repeat match goal with
           | [ m : TerminalMorphism _ _ |- _ ] => unique_pose_with_body (TerminalMorphism_Morphism m)
           | [ m : InitialMorphism _ _ |- _ ] => unique_pose_with_body (InitialMorphism_Morphism m)
           | [ m : UniversalMorphism _ _ |- _ ] => unique_pose_with_body (UniversalMorphism_Morphism m)
         end.

Ltac intro_universal_property_morphisms :=
  repeat match goal with
           | [ m : TerminalMorphism _ _ |- _ ] => unique_pose (TerminalProperty_Morphism m)
           | [ m : InitialMorphism _ _ |- _ ] => unique_pose (InitialProperty_Morphism m)
           | [ m : UniversalMorphism _ _ |- _ ] => unique_pose (UniversalProperty_Morphism m)
         end.

Ltac intro_universal_properties :=
  repeat match goal with
           | [ m : TerminalMorphism _ _ |- _ ] => unique_pose (TerminalProperty m)
           | [ m : InitialMorphism _ _ |- _ ] => unique_pose (InitialProperty m)
           | [ m : UniversalMorphism _ _ |- _ ] => unique_pose (UniversalProperty m)

           | [ _ : appcontext[TerminalProperty_Morphism ?a] |- _ ] => unique_pose (TerminalProperty a)
           | [ _ : appcontext[InitialProperty_Morphism ?a] |- _ ] => unique_pose (InitialProperty a)
           | [ _ : appcontext[UniversalProperty_Morphism ?a] |- _ ] => unique_pose (UniversalProperty a)
           | [ |- appcontext[TerminalProperty_Morphism ?a] ] => unique_pose (TerminalProperty a)
           | [ |- appcontext[InitialProperty_Morphism ?a] ] => unique_pose (InitialProperty a)
           | [ |- appcontext[UniversalProperty_Morphism ?a] ] => unique_pose (UniversalProperty a)

           | [ _ : appcontext[TerminalProperty_Morphism ?a ?b] |- _ ] => unique_pose (TerminalProperty a b)
           | [ _ : appcontext[InitialProperty_Morphism ?a ?b] |- _ ] => unique_pose (InitialProperty a b)
           | [ _ : appcontext[UniversalProperty_Morphism ?a ?b] |- _ ] => unique_pose (UniversalProperty a b)
           | [ |- appcontext[TerminalProperty_Morphism ?a ?b] ] => unique_pose (TerminalProperty a b)
           | [ |- appcontext[InitialProperty_Morphism ?a ?b] ] => unique_pose (InitialProperty a b)
           | [ |- appcontext[UniversalProperty_Morphism ?a ?b] ] => unique_pose (UniversalProperty a b)

           | [ _ : appcontext[TerminalProperty_Morphism ?a ?b ?c] |- _ ] => unique_pose (TerminalProperty a b c)
           | [ _ : appcontext[InitialProperty_Morphism ?a ?b ?c] |- _ ] => unique_pose (InitialProperty a b c)
           | [ _ : appcontext[UniversalProperty_Morphism ?a ?b ?c] |- _ ] => unique_pose (UniversalProperty a b c)
           | [ |- appcontext[TerminalProperty_Morphism ?a ?b ?c] ] => unique_pose (TerminalProperty a b c)
           | [ |- appcontext[InitialProperty_Morphism ?a ?b ?c] ] => unique_pose (InitialProperty a b c)
           | [ |- appcontext[UniversalProperty_Morphism ?a ?b ?c] ] => unique_pose (UniversalProperty a b c)
         end.


(** * Sitpn and Sitpn state definitions. *)

Require Import common.CoqLib.
Require Import common.GlobalTypes.
Require Import common.GlobalFacts.

Require Import SitpnTypes.
Require Import Datatypes.

Import ListNotations.

Set Implicit Arguments.

(** ** Sitpn structure definition *)

(** Defines the Sitpn structure as a record. *)

Record Sitpn  :=
  BuildSitpn {

      (** A list of nat implementing the finite set of places. *)
      places : list nat;

      (** A list of nat implementing the finite set of transitions. *)
      transitions : list nat;

      (** Alias for the set of elements that belong to the [places]
          list. *)
      In_P := (fun p => In p places);
      P := { p | In_P p };

      (** Alias for the set of elements that belong to the
          [transitions] list. *)
      In_T := (fun t => In t transitions);
      T := { t | In_T t };

      (** Given a place p ∈ P and t ∈ T:

          Yields a couple (a, n) where a is the type of the input arc
          between p and t, and n is the weight of the arc (therefore,
          strictly more than zero).

         Yields None if there is no arc between p and t. *)
      pre : P -> T -> option (ArcT * natstar);

      (** The function associating a weight to transition-place edges. *)
      post : T -> P -> option natstar;

      (** The initial marking of the SITPN. *)
      M0 : P -> nat;

      (** Associates a time interval to transitions of the SITPN. *)
      Is : T -> option TimeInterval;

      (** Lists implementing the finite sets of conditions (C),
          actions (A) and functions (F). *)
      conditions : list nat;
      actions : list nat;
      functions : list nat;

      (** Aliases for the set of elements that belong to the
         [conditions] (resp. [actions] and [functions]) list. *)
      In_C := (fun c => In c conditions);
      C := { c | In_C c };

      In_A := (fun a => In a actions);
      A := { a | In_A a };

      In_F := (fun f => In f functions);
      F := { f | In_F f };

      (** The function associating conditions to transitions. *)
      has_C : T -> C -> MOneZeroOne;

      (** The function associating actions to places. *)
      has_A : P -> A -> bool;

      (** The function associating interpretation functions to
          transitions. *)
      has_F : T -> F -> bool;

      (** Priority relation between transitions. *)
      pr : T -> T -> Prop;
      pr_dec : forall x y, {pr x y} + {~pr x y};
      pr_so : IsStrictOrder T pr;

      (** The lists of nat used in an [Sitpn] structure to implement
          finite sets respect the [NoDup] constraint. *)
      nodup_pls : NoDup places;
      nodup_trs : NoDup transitions;
      nodup_conds : NoDup conditions;
      nodup_actions : NoDup actions;
      nodup_funs : NoDup functions;

      (** The functions [pre, post, M0, I__s, has_C, has_A, has_F] and
          also the [pr] relation of a given [sitpn], yield the same
          value for inputs that verify the [P1SigEq] relation. *)

      wi_pre : forall p1 p2 t1 t2, P1SigEq p1 p2 -> P1SigEq t1 t2 -> pre p1 t1 = pre p2 t2;
      wi_post : forall p1 p2 t1 t2, P1SigEq p1 p2 -> P1SigEq t1 t2 -> post t1 p1 = post t2 p2;
      wi_M0 : forall p1 p2, P1SigEq p1 p2 -> M0 p1 = M0 p2;
      wi_Is : forall t1 t2, P1SigEq t1 t2 -> Is t1 = Is t2;
      wi_has_C : forall t1 t2 c1 c2, P1SigEq t1 t2 -> P1SigEq c1 c2 -> has_C t1 c1 = has_C t2 c2;
      wi_has_A : forall p1 p2 a1 a2, P1SigEq p1 p2 -> P1SigEq a1 a2 -> has_A p1 a1 = has_A p2 a2;
      wi_has_F : forall t1 t2 f1 f2, P1SigEq t1 t2 -> P1SigEq f1 f2 -> has_F t1 f1 = has_F t2 f2;
      wi_pr : forall t1 t2 t3 t4, P1SigEq t1 t2 -> P1SigEq t3 t4 -> pr t1 t3 <-> pr t2 t4;
    }.

(** Notations for Sitpn. *)

Notation "a '>~' b" := (pr a b) (at level 0).

(** ** Subsets of P and T, and misc. coercion functions *)

Definition Psubset sitpn Q := { p : P sitpn | Q p }.
Definition Psubset_in_P sitpn (Q : P sitpn -> Prop) (p : Psubset Q) := proj1_sig p.

Definition Tsubset sitpn Q := { t : T sitpn | Q t }.
Definition Tsubset_in_T sitpn (Q : T sitpn -> Prop) (t : Tsubset Q) := proj1_sig t.
Definition Ti (sitpn : Sitpn) := Tsubset (fun t : T sitpn => (Is t) <> None).
Definition Ti_in_T (sitpn : Sitpn) (t : Ti sitpn) := proj1_sig t.

Definition T_in_nat sitpn (t : T sitpn) : nat := proj1_sig t.
Definition P_in_nat sitpn (p : P sitpn) : nat := proj1_sig p.
Definition C_in_nat sitpn (c : C sitpn) : nat := proj1_sig c.
Definition A_in_nat sitpn (a : A sitpn) : nat := proj1_sig a.
Definition F_in_nat sitpn (f : F sitpn) : nat := proj1_sig f.

Definition nat_to_P {sitpn} p := (fun (pf : In_P sitpn p) => exist _ p pf).
Definition nat_to_T {sitpn} t := (fun (pf : In_T sitpn t) => exist _ t pf).
Definition nat_to_C {sitpn} c := (fun (pf : In_C sitpn c) => exist _ c pf).
Definition nat_to_A {sitpn} a := (fun (pf : In_A sitpn a) => exist _ a pf).
Definition nat_to_F {sitpn} f := (fun (pf : In_F sitpn f) => exist _ f pf).

(** Coercions for Sitpn. *)

Coercion P_in_nat : P >-> nat.
Coercion T_in_nat : T >-> nat.
Coercion C_in_nat : C >-> nat.
Coercion A_in_nat : A >-> nat.
Coercion F_in_nat : F >-> nat.

Coercion Psubset_in_P : Psubset >-> P.
Coercion Tsubset_in_T : Tsubset >-> T.
Coercion Ti_in_T : Ti >-> T.

(** ** Sitpn state definition. *)

(** Defines the Sitpn state structure as a record. *)

Record SitpnState (sitpn : Sitpn) :=
  BuildSitpnState {

      (** Current marking of the Sitpn. *)

      M : P sitpn -> nat;

      (** Current state of time counters. *)

      I : Ti sitpn -> nat;

      (** Orders to reset time counters. *)

      reset : Ti sitpn -> bool;

      (** Current condition (Boolean) values. *)

      cond : C sitpn -> bool;

      (** Current activation state for actions and functions. *)

      ex : A sitpn + F sitpn -> bool;

    }.


Require Export XR_Int_part.
Require Export XR_minus_IZR.
Require Export XR_archimed.
Require Export XR_Ropp_le_cancel.
Require Export XR_Rplus_le_reg_l.
Require Export XR_Rplus_lt_compat_r.

Local Open Scope R_scope.

Lemma base_Int_part : forall r,
  IZR (Int_part r) <= r /\ - R1 < IZR (Int_part r) - r .
Proof.
  intro x.
  unfold Int_part.
  rewrite minus_IZR.
  simpl.
  destruct (archimed x) as [ hl hu ].
  unfold Rminus.
  unfold Rminus in hu.
  split.
  {
    apply Ropp_le_cancel.
    rewrite Ropp_plus_distr, Ropp_involutive.
    eapply Rplus_le_reg_l with (IZR (up x)).
    repeat rewrite <- Rplus_assoc.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_l.
    exact hu.
  }
  {
    pattern (-R1) at 1 ; rewrite <- Rplus_0_l.
    repeat rewrite Rplus_assoc.
    rewrite (Rplus_comm (-R1)).
    repeat rewrite <- Rplus_assoc.
    apply Rplus_lt_compat_r.
    apply Rplus_lt_reg_r with x.
    rewrite Rplus_assoc.
    rewrite Rplus_opp_l, Rplus_0_r, Rplus_0_l.
    exact hl.
  }
Qed.


Require Import Coq.Program.Basics.
Require Import TypeclassHierarchy.Instances.Functor.Identity.
Require Import TypeclassHierarchy.Instances.Functor.Maybe.
Require Import TypeclassHierarchy.Instances.Functor.Writer.
Require Import TypeclassHierarchy.Instances.Semigroup.
Require Import TypeclassHierarchy.Interfaces.Functor.

(** Functor *)
Definition f1 : fmap S (Id 5) = Id 6. now compute. Defined.
Definition f2 : fmap S (Just 5) = Just 6. now compute. Defined.
Definition f3 : fmap (fmap S) (Id (Id 5)) = Id (Id 6). now compute. Defined.
Definition f4 : fmap (@fmap Maybe Maybe_Functor nat nat S) (Id (Just 5)) = Id (Just 6).
  now compute.
Defined.

(** TODO: Apply *)

(** Applicative *)
Definition a5 : ap (Just S) (pure 5) = pure 6. now compute. Defined.
Definition a6 : ap (Nothing : Maybe (nat -> nat)) (pure 5) = Nothing. now compute. Defined.
Definition a7 : ap (Just S) Nothing = Nothing. now compute. Defined.

(** TODO: Bind *)

(** Monad *)
Definition m1 : bind (Just 5) pure = Just 5. now compute. Defined.
Definition m2 : bind (Just 0) (compose pure S) = Just 1. now compute. Defined.
Definition m3 : forall A, bind (Nothing : Maybe A) pure = Nothing. now compute. Defined.
Definition m4 : bind (bind (Just 5) (compose pure S)) (compose pure S) = Just 7.
  now compute.
Defined.

Definition m5 : @pure (Writer (list nat)) Writer_Applicative nat 5  = (nil, 5).
  now compute.
Defined.
Definition m6 : @fmap (Writer (list nat)) SG_Writer_Functor nat nat S (@pure (Writer (list nat)) Writer_Applicative nat 5)  = (nil, 6).
  now compute.
Defined.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e322m2e161m1_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e150m3_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Arith List.
Import ListNotations.

(* λ⇅ small-step semantics *)

(* Syntax *)
Inductive exp : Type :=
  | Lit (n : nat)
  | Var (x : nat)
  | Lam (e : exp) (* Implicit f (self) and x (param ident) *)
  | App (e1 e2 : exp)
  | Cons (e1 e2 : exp)
  | Let (e1 e2 : exp) (* Implicit x (ident) *)
  | If (e1 e2 e3 : exp)

  (* ⊕¹ - Unary operators *)
  | IsNum (e : exp)
  | IsCons (e : exp)
  | Car (e : exp)
  | Cdr (e : exp)

  (* ⊕² - Binary operators *)
  | Plus (e1 e2 : exp)
  | Minus (e1 e2 : exp)
  | Times (e1 e2 : exp)
  | Eq (e1 e2 : exp)

  | Lift (e : exp)
  | Run (e1 e2 : exp)

  (* g - Internal small-step forms *)
  | Code (e : exp)
  | Reflect (e : exp)
  | LamC (e : exp) (* Implicit f (self) and x (param ident) *)
  | LetC (e1 e2 : exp). (* Implicit x (ident) *)

Definition is_v (e : exp) : bool :=
  match e with
  | Lit _ | Lam _ | Cons _ _ | Code _ => true
  | _ => false
  end.

(* Environment *)
Definition env : Type := list exp.

Definition lookup (ρ : env) (n : nat) : option exp :=
  nth_error (rev ρ) n.

Definition lit_of_bool (b : bool) : exp :=
  Lit (if b then 1 else 0).

Notation "'?'" := (Lit 42).

Reserved Notation "s --> s'" (at level 40).

(* Reduction rules *)
Inductive step : env * exp -> env * exp -> Prop :=
  | S_Var          ρ x v :       lookup ρ x = Some v ->
                                 (ρ, Var x)                            --> (ρ, v)
  | S_Let          ρ v e :       is_v v = true ->
                                 (ρ, Let v e)                          --> (v :: ρ, e)
  | S_App          ρ e v :       is_v v = true ->
                                 (ρ, App (Lam e) v)                    --> (v :: Lam e :: ρ, e)
  | S_App_Code     ρ e1 e2 :     (ρ, App (Code e1) (Code e2))          --> (ρ, Reflect (App e1 e2))
  | S_If_false     ρ e1 e2 :     (ρ, If (Lit 0) e1 e2)                 --> (ρ, e2)
  | S_If_true      ρ n e1 e2 :   n <> 0 ->
                                 (ρ, If (Lit n) e1 e2)                 --> (ρ, e1)
  | S_If_Code      ρ e0 e1 e2 :  (ρ, If (Code e0) (Code e1) (Code e2)) --> (ρ, Reflect (If e0 e1 e2))
  | S_IsNum_true   ρ n :         (ρ, IsNum (Lit n))                    --> (ρ, Lit 1)
  | S_IsNum_Code   ρ e :         (ρ, IsNum (Code e))                   --> (ρ, Reflect (IsNum e))
  | S_IsNum_false  ρ v n e :     v <> Lit n -> v <> Code e ->
                                 (ρ, IsNum v)                          --> (ρ, Lit 0)
  | S_IsCons_true  ρ e1 e2 :     (ρ, IsCons (Cons e1 e2))              --> (ρ, Lit 1)
  | S_IsCons_Code  ρ e :         (ρ, IsCons (Code e))                  --> (ρ, Reflect (IsCons e))
  | S_IsCons_false ρ v e1 e2 e : v <> Cons e1 e2 -> v <> Code e ->
                                 (ρ, IsCons v)                         --> (ρ, Lit 0)
  | S_Car_Cons     ρ e1 e2 :     (ρ, Car (Cons e1 e2))                 --> (ρ, e1)
  | S_Car_Code     ρ e :         (ρ, Car (Code e))                     --> (ρ, Reflect (Car e))
  | S_Cdr_Cons     ρ e1 e2 :     (ρ, Cdr (Cons e1 e2))                 --> (ρ, e2)
  | S_Cdr_Code     ρ e :         (ρ, Cdr (Code e))                     --> (ρ, Reflect (Cdr e))
  | S_Plus_Lit     ρ n1 n2 :     (ρ, Plus (Lit n1) (Lit n2))           --> (ρ, Lit (n1 + n2))
  | S_Plus_Code    ρ e1 e2 :     (ρ, Plus (Code e1) (Code e2))         --> (ρ, Reflect (Plus e1 e2))
  | S_Minus_Lit    ρ n1 n2 :     (ρ, Minus (Lit n1) (Lit n2))          --> (ρ, Lit (n1 - n2))
  | S_Minus_Code   ρ e1 e2 :     (ρ, Minus (Code e1) (Code e2))        --> (ρ, Reflect (Minus e1 e2))
  | S_Times_Lit    ρ n1 n2 :     (ρ, Times (Lit n1) (Lit n2))          --> (ρ, Lit (n1 * n2))
  | S_Times_Code   ρ e1 e2 :     (ρ, Times (Code e1) (Code e2))        --> (ρ, Reflect (Times e1 e2))
  | S_Eq_Lit       ρ n1 n2 :     (ρ, Eq (Lit n1) (Lit n2))             --> (ρ, lit_of_bool (n1 =? n2))
  | S_Eq_Code      ρ e1 e2 :     (ρ, Eq (Code e1) (Code e2))           --> (ρ, Reflect (Eq e1 e2))
  | S_Lift_Lit     ρ n :         (ρ, Lift (Lit n))                     --> (ρ, Code (Lit n))
  | S_Lift_Cons    ρ e1 e2 :     (ρ, Lift (Cons (Code e1) (Code e2)))  --> (ρ, Reflect (Code (Cons e1 e2)))
  | S_Lift_Lam     ρ e :         (ρ, Lift (Lam e))                     --> (ρ, Lift (LamC ?))
  | S_Lift_LamC    ρ e :         (ρ, Lift (LamC (Code e)))             --> (ρ, Reflect (Code (Lam e)))
  | S_Lift_Code    ρ e :         (ρ, Lift (Code e))                    --> (ρ, Reflect (Code (Lift e)))
  | S_Run_Code     ρ e1 e2 :     (ρ, Run (Code e1) (Code e2))          --> (ρ, Reflect (Code (Run e1 e2)))
  | S_Run_else     ρ v1 e1 e2 :  v1 <> Code e1 ->
                                 (ρ, Run v1 (Code e1))                 --> (ρ, e2)
  | S_Reflect_Code ρ e :         (ρ, Reflect (Code e))                 --> (ρ, ?)
  | S_LetC         ρ e1 e2 :     (ρ, LetC e1 (Code e2))                --> (ρ, Code (Let e1 e2))

  where "s --> s'" := (step s s').


Require Export Two.

Module Arrow.

Section category.
Context (C: Category).

Structure obj := Obj {
  dom: C;
  cod: C;
  arr: dom ~> cod;
}.

Structure hom (f g: obj) := Hom {
  fdom: dom f ~> dom g;
  fcod: cod f ~> cod g;
  comm: fcod ∘ arr f = arr g ∘ fdom;
}.

Lemma obj_eq (f g: obj): f = g <-> dom f = dom g /\ cod f = cod g /\ (forall (ed: dom f = dom g) (ec: cod f = cod g), eq_iso ec ∘ arr f = arr g ∘ eq_iso ed).
Proof.
  split.
  + intros H.
    subst g.
    repeat split.
    intros ed ec.
    rewrite !eq_iso_refl.
    clear ed ec.
    simpl.
    rewrite comp_id_r.
    apply comp_id_l.
  + destruct f as [x y f], g as [x' y' g].
    simpl.
    intros [Hx [Hy H]].
    subst x' y'.
    f_equal.
    rewrite <- comp_id_r, <- (comp_id_l f).
    exact (H eq_refl eq_refl).
Qed.

Lemma hom_eq (f g: obj) (F G: hom f g): F = G <-> fdom _ _ F = fdom _ _ G /\ fcod _ _ F = fcod _ _ G.
Proof.
  split.
  intros H.
  now subst G.
  destruct F, G.
  simpl.
  intros [H0 H1].
  subst fdom1 fcod1.
  f_equal.
  apply proof_irrelevance.
Qed.

Definition id (f: obj): hom f f := {|
  fdom := id (dom f);
  fcod := id (cod f);
  comm := eq_trans (comp_id_l (arr f)) (eq_sym (comp_id_r (arr f)));
|}.

Definition comp {f g h: obj} (F: hom g h) (G: hom f g): hom f h := {|
  fdom := fdom _ _ F ∘ fdom _ _ G;
  fcod := fcod _ _ F ∘ fcod _ _ G;
  comm :=
    eq_trans (eq_trans (eq_trans (eq_trans
      (eq_sym (comp_assoc _ _ _))
      (f_equal _ (comm _ _ G)))
      (comp_assoc _ _ _))
      (f_equal (fun f => f ∘ _) (comm _ _ F)))
      (eq_sym (comp_assoc _ _ _));
|}.

Lemma comp_assoc (a b c d: obj) (f: hom c d) (g: hom b c) (h: hom a b): comp f (comp g h) = comp (comp f g) h.
Proof.
  apply hom_eq; split; simpl.
  all: apply comp_assoc.
Qed.

Lemma comp_id_l (f g: obj) (F: hom f g): comp (id g) F = F.
Proof.
  apply hom_eq; split; simpl.
  all: apply comp_id_l.
Qed.

Lemma comp_id_r (f g: obj) (F: hom f g): comp F (id f) = F.
Proof.
  apply hom_eq; split; simpl.
  all: apply comp_id_r.
Qed.

Definition cat_mixin: Category.mixin_of obj :=
  Category.Mixin obj hom id (@comp) comp_assoc comp_id_l comp_id_r.

Canonical cat: Category :=
  Category.Pack obj cat_mixin.

End category.

Arguments dom {C} _.
Arguments cod {C} _.
Arguments arr {C} _.

Arguments fdom {C f g} _.
Arguments fcod {C f g} _.
Arguments comm {C f g} _.

Definition Dom (C: Category): cat C ~> C := {|
  fobj := dom;
  fmap f g := fdom;
  fmap_id f := eq_refl;
  fmap_comp _ _ _ F G := eq_refl;
|}.

Definition Cod (C: Category): cat C ~> C := {|
  fobj := cod;
  fmap f g := fcod;
  fmap_id f := eq_refl;
  fmap_comp _ _ _ F G := eq_refl;
|}.

End Arrow.

Canonical Arrow.cat.
Coercion Arrow.Obj: hom >-> Arrow.obj.
Notation Arrow := Arrow.cat.

Section TwoFun.
Context (C: Category).

Program Definition TwoFun_to: Arrow C ~> Fun 2 C := {|
  fobj x := Two.F (Arrow.arr x);
  fmap x y f := {|
    transform b :=
      match b return (if b then Arrow.cod x else Arrow.dom x) ~> (if b then Arrow.cod y else Arrow.dom y) with
      | false => Arrow.fdom f
      | true => Arrow.fcod f
      end;
  |};
|}.
Next Obligation.
  destruct x0, y0, f0.
  1, 3: rewrite comp_id_l.
  1, 2: apply comp_id_r.
  apply Arrow.comm.
Qed.
Next Obligation.
  natural_eq b.
  now destruct b.
Qed.
Next Obligation.
  natural_eq x.
  now destruct x.
Qed.

Program Definition TwoFun_from: Fun 2 C ~> Arrow C := {|
  fobj F := {|
    Arrow.dom := F false;
    Arrow.cod := F true;
    Arrow.arr := fmap F (tt: (false: 2) ~> true);
  |};
  fmap F G η := {|
    Arrow.fdom := η false;
    Arrow.fcod := η true;
  |};
|}.
Next Obligation.
  apply naturality.
Qed.
Next Obligation.
  now apply Arrow.hom_eq.
Qed.
Next Obligation.
  now apply Arrow.hom_eq.
Qed.

Lemma TwoFun_inv_l: TwoFun_from ∘ TwoFun_to = id (Arrow C).
Proof.
  fun_eq x y F.
  now destruct x.
  destruct x as [x x' f].
  destruct y as [y y' g].
  rewrite !eq_iso_refl.
  clear H H0.
  simpl.
  rewrite comp_id_l, comp_id_r.
  now apply Arrow.hom_eq.
Qed.

Lemma TwoFun_inv_r: TwoFun_to ∘ TwoFun_from = id (Fun 2 C).
Proof.
  fun_eq F G η.
  destruct (Two.F_unique x) as [a [b [f H]]].
  now subst x.
  destruct (Two.F_unique F) as [x [x' [f HF]]].
  destruct (Two.F_unique G) as [y [y' [g HG]]].
  subst F G.
  rewrite !eq_iso_refl.
  clear H H0.
  simpl.
  rewrite comp_id_l, comp_id_r.
  natural_eq b.
  now destruct b.
Qed.

Definition TwoFun: Arrow C <~> Fun 2 C :=
  Isomorphism.Pack TwoFun_to (Isomorphism.Mixin _ _ _ TwoFun_to TwoFun_from TwoFun_inv_l TwoFun_inv_r).

Lemma Arrow_is_Fun: Arrow C ≃ Fun 2 C.
Proof.
  constructor.
  exact TwoFun.
Qed.
End TwoFun.


From mathcomp Require Import all_ssreflect.
Require Import Setoid.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Reserved Notation "x =l y" (at level 70, no associativity).
Reserved Notation "x =g y" (at level 70, no associativity).
Reserved Notation "x =a/g y" (at level 70, no associativity).
Reserved Notation "x '=1/g' y" (at level 70, no associativity).
Reserved Notation "x '=1/a' y" (at level 70, no associativity).
Reserved Notation "x '=1/a/g' y" (at level 70, no associativity).
Reserved Notation "x '=1/sval' y" (at level 70, no associativity).

Unset Auto Template Polymorphism.

(****************************************************************************)
(** Assumptions and Strict positivisation of functors                      **)
(****************************************************************************)
Class equivalence A : Type :=
  MkEquiv
    { eqRel : A -> A -> Prop;
      e_refl : forall x, eqRel x x;
      e_sym : forall x y, eqRel x y -> eqRel y x;
      e_trans : forall x y z, eqRel x y -> eqRel y z -> eqRel x z;
    }.

Hint Resolve e_refl : ffix.
Hint Resolve e_sym : ffix.
Hint Resolve e_trans : ffix.

Instance def_eq A : equivalence A | 100 :=
  {| eqRel := @eq A;
     e_refl := @erefl A;
     e_sym := @esym A;
     e_trans := @etrans A;
  |}.

Add Parametric Relation (A: Type) (eq : equivalence A) : A (@eqRel A eq)
    reflexivity proved by (@e_refl A eq)
    symmetry proved by (@e_sym A eq)
    transitivity proved by (@e_trans A eq)
      as ExtEq.

Reserved Notation "f =e g" (at level 70, no associativity).
(* Reserved Notation "f =1e g" (at level 70, no associativity). *)
Notation "f =e g" := (eqRel f g).
(* Notation "f =1e g" := (forall x, eqRel (Eq _) (f x) (g x)). *)

Instance ext_eq (A B : Type) (eq_B : equivalence B) : equivalence (A -> B).
Proof.
  apply: (@MkEquiv _ (fun f g =>forall x, eqRel (f x) (g x))).
  - by move=>f x; apply: e_refl.
  - by move=>f g H x; apply: e_sym.
  - by move=>f g h Hf Hg x; apply: e_trans.
Defined.

(** Is position valid in shape? *)
Class functor (S P : Type) :=
  { dom : S -> P -> bool
  }.

Definition App S P {F : functor S P} (X : Type) := {sh : S & sig (dom sh) -> X}.
Arguments App S P [F] X.

Lemma cont_irr S P {F : functor S P} X (sh : S) (f : sig (dom sh) -> X)
  : forall x p1 p2, f (exist _ x p1) = f (exist _ x p2).
Proof. move=> x/= p1 p2; by rewrite (bool_irrelevance p1 p2). Qed.

Definition AppR S P {F : functor S P} (X : Type) {e : equivalence X}
           (x y : App S P X) : Prop
  := projT1 x = projT1 y /\
     (forall e d1 d2, projT2 x (exist _ e d1) =e projT2 y (exist _ e d2)).

Lemma AppR_inv_sh S P {F : functor S P} X {e : equivalence X} x y :
  AppR x y -> projT1 x = projT1 y.
Proof. by case. Qed.

Lemma AppR_inv_k S P {F : functor S P} X {e : equivalence X} x y :
  AppR x y ->
  forall e d1 d2, projT2 x (exist _ e d1) =e projT2 y (exist _ e d2).
Proof. by case. Qed.

Instance App_equiv S P {F : functor S P} (X : Type) {e : equivalence X}
  : equivalence (App S P X).
Proof.
  apply: (@MkEquiv _ (@AppR S P F X e)).
  - move=> [shx kx]; constructor=>//=x d1 d2.
    rewrite (bool_irrelevance d1 d2); by apply: e_refl.
  - move=> x y [Sxy Exy]; split; first by apply/esym.
    by move=> z d1 d2; symmetry.
  - move=> x y z [Sxy Exy] [Syz Eyz]; split; first by rewrite Sxy.
    move=>t d1 d2; have d3: dom (projT1 y) t by move: d1; rewrite Sxy.
    by rewrite (Exy t d1 d3).
Defined.

Structure morph (A B : Type) {eq_A : equivalence A} {eq_B : equivalence B}
  := { app :> A -> B;
       f_eq : forall x y, x =e y -> app x =e app y
     }.
Arguments morph A B _ _ : clear implicits.

Reserved Notation "x ~> y" (at level 95, right associativity, y at level 200).
Notation "x ~> y" := (morph x y _ _).

Instance eq_morph (A B : Type) {eq_A : equivalence A} {eq_B : equivalence B}
  : equivalence (A ~> B).
Proof.
  apply: (@MkEquiv _ (fun f g =>forall x, app f x =e app g x)).
  - by move=>f x; apply: e_refl.
  - by move=>f g H x; apply: e_sym.
  - by move=>f g h Hf Hg x; apply: e_trans.
Defined.

(* Definition arr (A B : Type) (eq_A : equivalence A) (eq_B : equivalence B) *)
(*   := sig (@morph A B eq_A eq_B). *)

Definition fmapA S P {F : functor S P} A B (f : A -> B) (x : App S P A)
  : App S P B := existT _ (projT1 x) (f \o projT2 x).

Lemma fmapA_eqF S P {F : functor S P} A B
      {eq_A : equivalence A} {eq_B : equivalence B}
      (f : A ~> B)
  : forall x y, x =e y -> fmapA f x =e fmapA f y.
Proof.
  move=> [sx kx] [sy ky] [/=Es Ek]; split=>//= e d1 d2.
  by apply/f_eq/Ek.
Qed.

Definition fmap S P {F : functor S P}
           A B {eq_A : equivalence A} {eq_B : equivalence B}
           (f : A ~> B) : App S P A ~> App S P B
  := {| app := _ ; f_eq := fmapA_eqF f |}.

Lemma comp_eq A B C
      {e1 : equivalence A} {e2 : equivalence B} {e3 : equivalence C}
      (f : B ~> C) (g : A ~> B) :
  forall x y, x =e y -> (f \o g) x =e (f \o g) y.
Proof. by move=> x y H; apply/f_eq/f_eq. Qed.

Definition acomp A B C
      {e1 : equivalence A} {e2 : equivalence B} {e3 : equivalence C}
      (f : B ~> C) (g : A ~> B) : A ~> C
  := {| app := _; f_eq := comp_eq f g |}.

Notation "f \o g" := (acomp f g).

Lemma id_eq (A : Type) {eq_A : equivalence A}
  : forall (x y : A), x =e y -> id x =e id y.
Proof. by []. Qed.

Definition id A {eq : equivalence A} : A ~> A :=
  {| app := _; f_eq := @id_eq A eq |}.
Arguments id {A eq}.

Lemma fmap_id S P {F : functor S P} A {eq_A : equivalence A}
  : fmap (S:=S) (P:=P) (A:=A) id =e id.
Proof.
  move=> [s k]/=; rewrite /fmap/=; split=>//= e d1 d2.
  rewrite (bool_irrelevance d2 d1); by reflexivity.
Qed.

Lemma fmap_comp S P {F : functor S P} (A B C : Type)
      {eq_A : equivalence A} {eq_B : equivalence B} {eq_C :equivalence C}
      (f : B ~> C) (g : A ~> B)
  : fmap (f \o g) =e fmap f \o fmap g.
Proof.
  move=> [s k]/=; rewrite /fmap/=; split=>//= e d1 d2.
  rewrite (bool_irrelevance d2 d1); by reflexivity.
Qed.

Add Parametric Morphism S P (F : functor S P)
    (A B : Type) (e1 : equivalence A) (e2 : equivalence B)
  : (@fmap S P F A B e1 e2)
    with signature
    (eqRel (A:=A ~> B))
      ==> (eqRel (A:=App S P A ~> App S P B))
      as fmapMorphism.
Proof.
  move=> f1 f2 Ef [s k]; split=>//= e d1 d2.
  by rewrite (bool_irrelevance d1 d2).
Qed.

Add Parametric Morphism (A B C : Type)
    (eA : equivalence A) (eB : equivalence B) (eC : equivalence C)
  : (@acomp A B C eA eB eC)
    with signature
    (eqRel (A:=B ~> C))
      ==> (eqRel (A:=A ~> B))
      ==> (eqRel (A:=A ~> C))
      as compMorphism.
Proof.
  move=> f1 f2 Ef g1 g2 Eg x=>//=.
  by apply/(e_trans (Ef (g1 x)))/f_eq/Eg.
Qed.

Definition Alg S P {F : functor S P} A {eA : equivalence A} := App S P A ~> A.
Arguments Alg S P {F} A {eA}.
Definition CoAlg S P {F : functor S P} A {eA : equivalence A} := A ~> App S P A.
Arguments CoAlg S P {F} A {eA}.

Inductive LFix S P {F : functor S P} : Type :=
| LFix_in sh : (sig (dom sh) -> @LFix S P F) -> @LFix S P F.
Arguments LFix S P {F}.

Definition l_shape S P {F : functor S P} (x : LFix S P) :=
  match x with
  | LFix_in sh _ => sh
  end.
Definition l_cont S P {F : functor S P} (x : LFix S P) :=
  match x return sig (dom (l_shape x)) -> LFix S P with
  | LFix_in _ k => k
  end.

Fixpoint LFixR S P {F : functor S P} (x y : LFix S P) : Prop :=
  l_shape x = l_shape y /\
  forall e d1 d2,
      LFixR (l_cont (x:=x) (exist _ e d1)) (l_cont (x:=y) (exist _ e d2)).

Lemma LFixR_inv_sh S P {F : functor S P} (x y : LFix S P)
  : LFixR x y -> l_shape x = l_shape y.
Proof. by case: x=>[sx kx]; case: y=>[sy ky] []. Qed.

Lemma LFixR_inv_k S P {F : functor S P} (x y : LFix S P)
  : LFixR x y ->
    forall e d1 d2,
      LFixR (l_cont (x:=x) (exist _ e d1)) (l_cont (x:=y) (exist _ e d2)).
Proof. by case: x=>[sx kx]; case: y=>[sy ky] []. Qed.

Lemma LFixR_refl S P {F : functor S P} (x : LFix S P) : LFixR x x.
Proof.
  elim: x=>// shx k Ih; constructor=>//=x p1 p2.
  by rewrite (bool_irrelevance p1 p2); apply: Ih.
Qed.

Lemma LFixR_sym S P {F : functor S P} (x y : LFix S P) : LFixR x y -> LFixR y x.
Proof.
  elim: x => sx kx Ih in y *; case: y => sy ky /=[/esym-Sxy E].
  split=>// e d1 d2; by apply/Ih/E.
Qed.

Lemma LFixR_trans S P {F : functor S P} (x y z : LFix S P)
  : LFixR x y -> LFixR y z -> LFixR x z.
Proof.
  elim: x=> sx kx Ih in y z *; case: y=> sy ky/=; case: z=> sz kz/=.
  move=> [Sxy Exy] [Syz Eyz]; split; first by rewrite Sxy.
  move=> e d1 d2; apply: Ih; first by apply: Exy; rewrite Syz.
  by apply/Eyz.
Qed.

Instance LFix_Eq S P {F : functor S P} : equivalence (LFix S P) :=
  {| eqRel := @LFixR S P F;
     e_refl := @LFixR_refl S P F;
     e_sym := @LFixR_sym S P F;
     e_trans := @LFixR_trans S P F;
  |}.

Definition l_in_f S P {F : functor S P} (x : App S P (LFix S P)) : LFix S P :=
  LFix_in (projT2 x).

Lemma l_in_eq S P {F : functor S P} x y : x =e y -> l_in_f x =e l_in_f y.
Proof. by case: x=> sx kx; case: y=> sy ky/= [/=Es Ek]; split. Qed.

Definition l_out_f S P {F : functor S P} (x : LFix S P) : App S P (LFix S P) :=
  match x with
  | LFix_in sh k => existT _ sh k
  end.

Lemma l_out_eq S P (F : functor S P) x y : x =e y -> l_out_f x  =e l_out_f y.
Proof. by case: x=> sx kx; case: y=> sy ky/= [/=Es Ek]; split. Qed.

Definition l_in S P (F : functor S P) : Alg S P (LFix S P) :=
  {| app := _; f_eq := @l_in_eq S P F |}.
Arguments l_in {S P F}.
Definition l_out S P (F : functor S P) : CoAlg S P (LFix S P) :=
  {| app := _; f_eq := @l_out_eq S P F |}.
Arguments l_out {S P F}.

Lemma l_in_out S P (F : functor S P) : l_in \o l_out =e id (A:=LFix S P).
Proof.
  move=>[s k]/=; split=>//= e d1 d2; rewrite (bool_irrelevance d1 d2).
  by apply: LFixR_refl.
Qed.

Lemma l_out_in  S P (F : functor S P)
  : l_out \o l_in =e id (A:=App S P (LFix S P)).
Proof.
  move=>[s k]/=; split=>//= e d1 d2; rewrite (bool_irrelevance d1 d2).
  by apply: LFixR_refl.
Qed.

Definition cata_f S P {F : functor S P} A {eA : equivalence A} (g : Alg S P A)
  : LFix S P -> A
  := fix f x :=
       match x with
       | LFix_in s k => g (existT _ s (comp f k))
       end.
Arguments cata_f {S P F A eA} g.

Lemma cata_arr S P {F : functor S P} A {eA : equivalence A} (g : Alg S P A)
  : forall x y, x =e y -> cata_f g x =e cata_f g y.
Proof.
  move=> x y /=; elim: x => sx kx Ih/= in y *; case: y=> sy ky/= [Es Ek].
  apply/(f_eq g); split=>//= e d1 d2; by apply/Ih.
Qed.

Definition cata S P {F : functor S P} A {eA : equivalence A} (g : Alg S P A)
  : LFix S P ~> A
  := {| app := _; f_eq := cata_arr g |}.
Arguments cata {S P F A eA} g.

Lemma cata_univ_r S P {F : functor S P} A {eA : equivalence A} (g : Alg S P A)
      (f : LFix S P ~> A)
  : f =e g \o fmap f \o l_out -> f =e cata g.
Proof.
  move=> H; elim=> sx kx /= Ih; rewrite (H _)/=; apply/f_eq => /=.
  split=>//= e d1 d2; rewrite Ih (bool_irrelevance d1 d2); by auto with ffix.
Qed.

Lemma cata_univ_l S P {F : functor S P} A {eA : equivalence A} (g : Alg S P A)
      (f : LFix S P ~> A)
  : f =e cata g -> f =e g \o fmap f \o l_out.
Proof.
  move=> H; case=> sx kx; rewrite (H _)/=; apply/f_eq => /=.
  split=>//= e d1 d2; rewrite -[cata_f g _]/(cata g _) -(H _).
  by rewrite (bool_irrelevance d2 d1); auto with ffix.
Qed.

Lemma cata_univ S P {F : functor S P} A {eA : equivalence A} (g : Alg S P A)
      (f : LFix S P ~> A)
  : f =e cata g <-> f =e g \o fmap f \o l_out.
Proof. by split;[apply/cata_univ_l|apply/cata_univ_r]. Qed.

(* Finite anamorphisms *)
Inductive FinF S P {F : functor S P} A {eA : equivalence A}
          (h : CoAlg S P A) : A -> Prop :=
| FinF_fold x : (forall e, FinF h (projT2 (h x) e)) -> FinF h x.
Hint Constructors FinF : ffix.

Lemma FinF_inv S P {F : functor S P} A {eA : equivalence A} (h : CoAlg S P A) x
  : FinF h x -> forall e, FinF h (projT2 (h x) e).
Proof. by case. Defined.

(* Finite coalgebras *)
Definition FCoAlg S P {F : functor S P} A {eA : equivalence A} :=
  sig (fun f => forall x, FinF f x).
Arguments FCoAlg S P {F} A {eA}.

Coercion coalg S P {F : functor S P} A {eA : equivalence A}
  : FCoAlg S P A -> A ~> App S P A := sval.

Definition finite S P {F : functor S P} A {eA : equivalence A}
  : forall (h : FCoAlg S P A) x, FinF h x := @proj2_sig _ _.

Definition ana_f_ S P {F : functor S P} A {eA : equivalence A} (h : CoAlg S P A)
  : forall (x : A), FinF h x -> LFix S P
  := fix f x H :=
       let hx := h x in
       LFix_in (fun e => f (projT2 hx e) (FinF_inv H e)).

Lemma ana_f_irr S P {F : functor S P} A {eA : equivalence A} (h : CoAlg S P A)
  : forall (x : A) (F1 F2 : FinF h x), ana_f_ F1 =e ana_f_ F2.
Proof.
  move=>/=; fix Ih 2; move=> x [{}x Fx] F2; move: F2 Fx=> [{}x Fy] Fx/=.
  split=>// e d1 d2; rewrite (bool_irrelevance d2 d1) => {d2}.
  by apply: Ih.
Qed.

Definition ana_f S P {F : functor S P} A {eA : equivalence A} (h : FCoAlg S P A)
  : A -> LFix S P
  := fun x => ana_f_ (finite h x).

Lemma ana_arr S P {F : functor S P} A {eA : equivalence A} (h : FCoAlg S P A)
  : forall x y, x =e y -> ana_f h x =e ana_f h y.
Proof.
  rewrite /ana_f; move=> x y; move: x y (finite h x) (finite h y).
  fix Ih 3; move=> x y [x' Fx] [y' Fy]/=; split.
  - by case: (f_eq h H).
  - move=> e d1 d2 /=; apply: Ih.
    by move: (f_eq h H)=> [E1 /(_ e d1 d2)].
Qed.

Definition ana S P (F : functor S P) A (eA : equivalence A)
           (h : FCoAlg S P A) : A ~> LFix S P
  := {| app := ana_f h; f_eq := ana_arr h |}.

Lemma ana_univ_r S P (F : functor S P) A (eA : equivalence A)
      (h : FCoAlg S P A) (f : A ~> LFix S P)
  : f =e l_in \o fmap f \o h -> f =e ana h.
Proof.
  move=> H; rewrite /ana/ana_f/==>x; move: x (finite h x).
  fix Ih 2; move=> x [{}x Fx].
  rewrite -[LFixR (f x) _]/(@eqRel _ LFix_Eq (f x) _) (H _)/=.
  split=>// e d1 d2; rewrite (bool_irrelevance d2 d1); by apply: Ih.
Qed.

Lemma ana_univ_l S P {F : functor S P} A {eA : equivalence A}
      (h : FCoAlg S P A) (f : A ~> LFix S P)
  : f =e ana h -> f =e l_in \o fmap f \o h.
Proof.
  move=> H x; move: x (finite h x).
  fix Ih 2; move=> x [{}x Fx].
  rewrite (H _) /=/ana_f; move: (finite h x)=>Fx'; move: Fx' Fx.
  move=>[{}x Fx'] Fx/=; split=>// e d1 d2; rewrite (bool_irrelevance d2 d1).
  move: (H (projT2 (coalg h x) (exist _ e d1))); rewrite /ana/ana_f/=.
  rewrite -![LFixR _ _]/(@eqRel _ LFix_Eq _ _).
  rewrite ana_f_irr =><-/=; by apply: LFixR_refl.
Qed.

Lemma ana_univ S P {F : functor S P} A {eA : equivalence A}
      (h : FCoAlg S P A) (f : A ~> LFix S P)
  : f =e ana h <-> f =e l_in \o fmap f \o h.
Proof. by split;[apply/ana_univ_l|apply/ana_univ_r]. Qed.

(** Hylomorphisms **)

Definition hylo_f_ S P {F : functor S P}
           A B {eA : equivalence A} {eB : equivalence B}
           (g : Alg S P B) (h : CoAlg S P A)
  : forall (x : A), FinF h x -> B
  := fix f x H :=
       match h x as h0
             return
             (forall e : {x0 : P | dom (projT1 h0) x0}, FinF h (projT2 h0 e)) ->
             B
       with
       | existT s_x c_x => fun H => g (existT _ s_x (fun e => f (c_x e) (H e)))
       end (FinF_inv H).

Lemma hylo_f_irr S P {F : functor S P}
           A B {eA : equivalence A} {eB : equivalence B}
           (g : Alg S P B) (h : CoAlg S P A)
  : forall (x : A) (F1 F2 : FinF h x), hylo_f_ g F1 =e hylo_f_ g F2.
Proof.
  move=>/=; fix Ih 2; move=> x [{}x Fx] F2; move: F2 Fx=> [{}x Fy] Fx/=.
  move: (h x) Fx Fy => [s_x c_x]/= Fx Fy.
  apply/f_eq=>/=; split=>//= e d1 d2; rewrite (bool_irrelevance d2 d1)=>{d2}.
  by apply: Ih.
Qed.

Definition hylo_f S P {F : functor S P}
           A B {eA : equivalence A} {eB : equivalence B}
           (g : Alg S P B) (h : FCoAlg S P A)
  := fun x => hylo_f_ g (finite h x).

Lemma hylo_arr S P {F : functor S P}
           A B {eA : equivalence A} {eB : equivalence B}
           (g : Alg S P B) (h : FCoAlg S P A)
  : forall x y, x =e y -> hylo_f g h x =e hylo_f g h y.
Proof.
  rewrite /hylo_f; move=> x y; move: x y (finite h x) (finite h y).
  fix Ih 3; move=> x y [x' Fx] [y' Fy]/= H.
  move: (@f_eq _ _ _ _ h _ _ H).
  move: (h x') (h y') Fx Fy => [s_x c_x] [s_y c_y]/= Fx Fy [/=Es Ec].
  apply/f_eq=>/=; split=>//= e d1 d2.
  by apply/Ih/Ec.
Qed.

Definition hylo S P {F : functor S P}
           A B {eA : equivalence A} {eB : equivalence B}
           (g : Alg S P B) (h : FCoAlg S P A)
  : A ~> B
  := {| app := _ ; f_eq := hylo_arr g h |}.

Lemma hylo_univ_r S P {F : functor S P}
      A B {eA : equivalence A} {eB : equivalence B}
      (g : Alg S P B) (h : FCoAlg S P A) (f : A ~> B)
  : f =e g \o fmap f \o h -> f =e hylo g h.
Proof.
  move=> H; rewrite /hylo/hylo_f/==>x; move: x (finite h x).
  fix Ih 2; move=> x Fx; rewrite (H _)/=/fmap/=; case: Fx=> {}x Fx/=.
  move: (h x) Fx => [s_x c_x]/= Fx.
  apply/f_eq => /=; split=>//= e d1 d2.
  by rewrite (bool_irrelevance d2 d1); apply/Ih.
Qed.

Lemma hylo_univ_l S P {F : functor S P}
      A B {eA : equivalence A} {eB : equivalence B}
      (g : Alg S P B) (h : FCoAlg S P A) (f : A ~> B)
  : f =e hylo g h -> f =e g \o fmap f \o h.
Proof.
  move=> H x; move: x (finite h x).
  fix Ih 2; move=> x [{}x Fx].
  rewrite (H _) /=/hylo_f; move: (finite h x)=>Fx'; move: Fx' Fx.
  move=>[{}x Fx']/=; case: (h x) Fx' => /=s_x c_x Fx' Fx.
  apply/f_eq; split=>//= e d1 d2.
  rewrite (bool_irrelevance d2 d1) (H _) /=/hylo_f/= hylo_f_irr.
  by eauto with ffix.
Qed.

Lemma hylo_univ S P {F : functor S P}
      A B {eA : equivalence A} {eB : equivalence B}
      (g : Alg S P B) (h : FCoAlg S P A) (f : A ~> B)
  : f =e hylo g h <-> f =e g \o fmap f \o h.
Proof. by split;[apply/hylo_univ_l|apply/hylo_univ_r]. Qed.

Corollary hylo_unr S P {F : functor S P}
      A B {eA : equivalence A} {eB : equivalence B}
      (g : Alg S P B) (h : FCoAlg S P A)
  : hylo g h =e g \o fmap (hylo g h) \o h.
Proof. by rewrite -hylo_univ; reflexivity. Qed.

Lemma fin_out S P (F : functor S P) : forall x, FinF l_out x.
Proof. by elim=>s k Ih; constructor; apply: Ih. Qed.

Definition f_out S P (F : functor S P) : FCoAlg S P (LFix S P) :=
  exist _ _ (@fin_out S P F).
Arguments f_out {S P F}.

Lemma hylo_cata S P {F : functor S P} B {eB : equivalence B} (g : Alg S P B)
  : cata g =e hylo g f_out.
Proof. by rewrite hylo_univ; apply/cata_univ; reflexivity. Qed.

Lemma hylo_ana  S P {F : functor S P} A {eA : equivalence A} (h : FCoAlg S P A)
  : ana h =e hylo l_in h.
Proof. by rewrite hylo_univ; apply/ana_univ; reflexivity. Qed.

Lemma compA A B C D {eA : equivalence A} {eB : equivalence B}
      {eC : equivalence C} {eD : equivalence D}
      (f : C ~> D) (g : B ~> C) (h : A ~> B)
  : f \o (g \o h) =e (f \o g) \o h.
Proof. move=>x; by eauto with ffix. Qed.

Lemma idKl A B {eA : equivalence A} {eB : equivalence B} (f : A ~> B)
  : f \o id =e f.
Proof. move=> x; by eauto with ffix. Qed.

Lemma idKr A B {eA : equivalence A} {eB : equivalence B} (f : A ~> B)
  : id \o f =e f.
Proof. move=> x; by eauto with ffix. Qed.

Lemma splitC A B C
      {eA : equivalence A} {eB : equivalence B} {eC : equivalence C}
      (f1 f2 : B ~> C) (g1 g2 : A ~> B)
  : f1 =e f2 -> g1 =e g2 -> f1 \o g1 =e f2 \o g2.
Proof. by move=>->->; eauto with ffix. Qed.

Lemma hylo_fusion_l S P {F : functor S P} A B C
      {eA : equivalence A} {eB : equivalence B} {eC : equivalence C}
      (h1 : FCoAlg S P A) (g1 : Alg S P B) (g2 : Alg S P C) (f2 : B ~> C)
      (E2 : f2 \o g1 =e g2 \o fmap f2)
  : f2 \o hylo g1 h1 =e hylo g2 h1.
Proof.
  rewrite hylo_univ.
  rewrite fmap_comp.
  rewrite compA.
  rewrite -E2.
  rewrite -compA.
  rewrite -compA.
  rewrite [in g1 \o (_ \o _)]compA.
  rewrite -hylo_unr.
  by reflexivity.
Qed.

Lemma hylo_fusion_r S P {F : functor S P} A B C
      {eA : equivalence A} {eB : equivalence B} {eC : equivalence C}
      (h1 : FCoAlg S P B) (g1 : Alg S P C) (h2 : FCoAlg S P A)
      (f1 : A ~> B) (E1 : h1 \o f1 =e fmap f1 \o h2)
  : hylo g1 h1 \o f1 =e hylo g1 h2.
Proof.
  rewrite hylo_univ.
  rewrite fmap_comp.
  rewrite -compA.
  rewrite -compA.
  rewrite -E1.
  rewrite compA.
  rewrite compA.
  rewrite -hylo_unr.
  by reflexivity.
Qed.

Lemma deforest S P {F : functor S P} A B C
      {eA : equivalence A} {eB : equivalence B} {eC : equivalence C}
      (h1 : FCoAlg S P A) (g1 : Alg S P B) (h2 : FCoAlg S P B) (g2 : Alg S P C)
      (INV: h2 \o g1 =e id)
  : hylo g2 h2 \o hylo g1 h1 =e hylo g2 h1.
Proof.
  apply/hylo_fusion_l.
  rewrite [in H in H =e _]hylo_unr.
  rewrite -compA INV idKl.
  reflexivity.
  Restart.
  apply/hylo_fusion_r.
  rewrite [in H in H =e _]hylo_unr.
  rewrite compA compA INV idKr.
  reflexivity.
Qed.

Corollary cata_ana_hylo S P (F : functor S P)
          A B {eA : equivalence A} {eB : equivalence B}
          (g : Alg S P B) (h : FCoAlg S P A)
  : cata g \o ana h =e hylo g h.
Proof. by rewrite hylo_cata hylo_ana; apply/deforest/l_out_in. Qed.

Section ExQsort.

  (* Defining a tree *)

  (* shapes *)
  Inductive Ts A := | Leaf | Node (ELEM : A).
  Inductive Tp := | Lbranch | Rbranch. (* positions *)
  Definition t_dom A (s : Ts A) : Tp -> bool := (* position valid in shape? *)
    match s with
    | Node _ => fun=>true
    | _ => fun=> false
    end.
  Instance tree_func A : functor (Ts A) Tp :=
    { dom := @t_dom  A
    }.

  Lemma dom_leaf_false A : {y | t_dom (Leaf A) y} -> False.
  Proof. by move=>[]. Qed.
  Definition dom_leaf A B (x : {y | t_dom (Leaf A) y}) : B :=
    False_rect _ (dom_leaf_false x).

    Print App.
  Definition a_leaf (A X : Type)
    : App (Ts A) Tp X := existT _ (Leaf A) (@dom_leaf A X).
  Definition a_node A X (x : A) (l r : X) : App (Ts A) Tp X :=
    existT _ (Node x) (fun p => match proj1_sig p with
                                | Lbranch => l
                                | Rbranch => r
                                end).

  Definition a_out A X (x : App (Ts A) Tp X)
    : option (A * X * X)
    := match x with
       | existT s k =>
         match s return (sig (t_dom s) -> X) -> _ with
         | Leaf => fun=> None
         | Node x =>
           fun k=>
             Some (x,
                   k (exist _ Lbranch is_true_true),
                   k (exist _ Rbranch is_true_true))
         end k
       end.
  (* end tree *)

  Definition m_merge (x : App (Ts nat) Tp (seq nat)) : seq nat :=
    match a_out x with
    | None => [::]
    | Some (h, l, r) => l ++ h :: r
    end.
  Lemma m_merge_arr : forall x y, x =e y -> m_merge x =e m_merge y.
  Proof.
    move=>[[|hx]//= kx] [[|hy]//= ky] [//= [<-]] H.
    by rewrite /m_merge/= !H.
  Qed.
  Definition merge : Alg (Ts nat) Tp (seq nat)
    := {| app := m_merge; f_eq := m_merge_arr |}.

  Definition m_split (x : seq nat) : App (Ts nat) Tp (seq nat) :=
    match x with
    | [::] => a_leaf _ _
    | h :: t
      => a_node h
                (List.filter (fun x => x <= h) t)
                (List.filter (fun x => x > h) t)
    end.
  Lemma m_split_arr : forall x y, x =e y -> m_split x =e m_split y.
  Proof. by move=> x y ->; eauto with ffix. Qed.
  Definition c_split : CoAlg (Ts nat) Tp (seq nat)
    := {| app := m_split; f_eq := m_split_arr |}.

  (* Needs to be defined, otherwise msort does not reduce! *)
  Lemma split_fin : forall x, FinF c_split x.
  Proof.
    move=>x; move: {-1}(size x) (leqnn (size x))=> n.
    elim: n => [|n Ih] in x *; case: x=> [|h t]/=;
      eauto=>E; constructor=>/=; case; [by []| by [] | move=>[] /= _; apply/Ih].
    - by rewrite size_filter (leq_trans (count_size _ _)).
    - by rewrite size_filter (leq_trans (count_size _ _)).
  Qed.

  Definition tsplit : FCoAlg (Ts nat) Tp (seq nat)
    := exist _ c_split split_fin.
  Definition msort : seq nat -> seq nat := hylo merge tsplit.
End ExQsort.

From Coq Require Extraction ExtrOcamlBasic ExtrOcamlNatInt.
Extract Inlined Constant leq => "(<=)".
Extract Inductive reflect => "bool" ["true" "false"].
Set Extraction TypeExpand.
(* Set Extraction Conservative Types. *)
Extraction Inline Coq.ssr.ssrbool.pred.
Extraction Inline Coq.ssr.ssrbool.rel.
Extraction Inline projT1.
Extraction Inline projT2.
Extraction Inline eq_op.
Extraction Inline Equality.class.
Extraction Inline Equality.op.
Extraction Inline Equality.axiom.
Extraction Inline Equality.sort.
Extraction Inline nat_eqMixin.
Extraction Inline nat_eqType.

Extraction Inline app.
Extraction Inline coalg.
Extraction Inline hylo.
Extraction Inline hylo_f.
Extraction Inline hylo_f_.

Extraction Inline merge.
Extraction Inline a_leaf.
Extraction Inline a_node.
Extraction Inline m_merge.
Extraction Inline m_split.
Extraction Inline a_out.
Extraction Inline c_split.
Extraction Inline tsplit.
Set Extraction Flag 2047.
Extraction "extraction/test.ml" msort.


Require Import Verdi.Verdi.
Require Import StructTact.Fin.

Require Import OrderedType.

Module Type NameType.
  Parameter name : Type.
  Parameter name_eq_dec : forall x y : name, {x = y} + {x <> y}.
  Parameter nodes : list name.
  Parameter all_names_nodes : forall x, In x nodes.
  Parameter no_dup_nodes : NoDup nodes.
End NameType.

Module Type FinNameType (Import N : NatValue) <: NameType.
  Definition name := fin n.
  Definition name_eq_dec := fin_eq_dec n.
  Parameter nodes : list (fin n).
  Parameter all_names_nodes : forall x, In x nodes.
  Parameter no_dup_nodes : NoDup nodes.
End FinNameType.

Module FinName (Import N : NatValue) <: FinNameType N.
  Definition name := fin n.
  Definition name_eq_dec := fin_eq_dec n.
  Definition nodes := all_fin n.
  Definition all_names_nodes := all_fin_all n.
  Definition no_dup_nodes := all_fin_NoDup n.
End FinName.

Module Type NameOrderedTypeCompat (Import NT : NameType) <: OrderedType.
  Definition t := name.
  Definition eq := @eq name.
  Parameter lt : name -> name -> Prop.
  Definition eq_refl := @eq_refl name.
  Definition eq_sym := @eq_sym name.
  Definition eq_trans := @eq_trans name.
  Parameter lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Parameter lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Parameter compare : forall x y : t, Compare lt eq x y.
  Definition eq_dec := name_eq_dec.
End NameOrderedTypeCompat.

Module FinNameOrderedTypeCompat (N : NatValue) (FN : FinNameType N) <: NameOrderedTypeCompat FN := fin_OT_compat N.

Require Import MSetInterface.

Module Type NameOrderedType (Import NT : NameType) <: OrderedType.
  Definition t := name.
  Definition eq := @eq name.
  Definition eq_equiv := @eq_equivalence name.
  Parameter lt : name -> name -> Prop.
  Parameter lt_strorder : StrictOrder lt.
  Parameter lt_compat : Proper (eq==>eq==>iff) lt.
  Parameter compare : forall x y : name, comparison.
  Parameter compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Definition eq_dec := name_eq_dec.
End NameOrderedType.

Module FinNameOrderedType (N : NatValue) (FN : FinNameType N) <: NameOrderedType FN := fin_OT N.

Module Type AdjacentNameType (Import NT : NameType).
  Parameter adjacent_to : relation name.
  Parameter adjacent_to_dec : forall x y : name, {adjacent_to x y} + {~ adjacent_to x y}.
  Parameter adjacent_to_symmetric : Symmetric adjacent_to.
  Parameter adjacent_to_irreflexive : Irreflexive adjacent_to.
End AdjacentNameType.

Module Type RootNameType (Import NT : NameType).
  Parameter root : name -> Prop.
  Parameter root_dec : forall n, {root n} + {~ root n}.
  Parameter root_unique : forall n n', root n -> root n' -> n = n'.
End RootNameType.

Module FinCompleteAdjacentNameType (Import N : NatValue) (FN : FinNameType N) <: AdjacentNameType FN.
  Inductive fin_complete : fin n -> fin n -> Prop :=
  | fin_complete_neq : forall x y, x <> y -> fin_complete x y.

  Definition adjacent_to : relation (fin n) := fin_complete.

  Definition adjacent_to_dec : forall x y, {adjacent_to x y} + { ~ adjacent_to x y}.
    intros x y.
    case (fin_eq_dec n x y); intro H_eq.
    - rewrite H_eq.
      right.
      intros H_r.
      inversion H_r.
      auto.
    - left.
      apply fin_complete_neq.
      auto.
  Defined.

  Lemma adjacent_to_symmetric : Symmetric adjacent_to.
  Proof.
    unfold Symmetric.
    intros x y H_r.
    inversion H_r; subst.
    apply fin_complete_neq.
    intro H_eq.
    rewrite H_eq in H.
    auto.
  Qed.

  Lemma adjacent_to_irreflexive : Irreflexive adjacent_to.
  Proof.
    unfold Irreflexive; unfold Reflexive; unfold complement.
    intros x H_x.
    inversion H_x.
    auto.
  Qed.
End FinCompleteAdjacentNameType.

Module FinRootNameType (Import N : NatValue) (FN : FinNameType N) <: RootNameType FN.
  Definition root (x : fin n) := fin_to_nat x = 0.

  Definition root_dec (x : fin n) := Nat.eq_dec (fin_to_nat x) 0.

  Lemma root_unique : forall x y, root x -> root y -> x = y.
  Proof.
    intros x y.
    unfold root.
    intros H_x H_y.
    case (fin_compare n x y); intro cmp; case cmp; intro H_cmp.
    - inversion H_cmp; auto.
    - inversion H_cmp.
      unfold fin_lt in H.
      rewrite H_x in H.
      rewrite H_y in H.
      contradict H.
      auto with arith.
    - inversion H_cmp.
      unfold fin_lt in H.
      rewrite H_x in H.
      rewrite H_y in H.
      contradict H.
      auto with arith.
  Qed.
End FinRootNameType.


Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import ddT.
Require Import gen_tacs.
Require Import gen_seq.
Require Import List_lemmasT.
Require Import existsT.
Require Import univ_gen_ext.
Require Import dd_fc.

Declare Scope My_scope.
Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Global Parameter V : Set.

Parameter eq_dec_propvar : forall x y : V, {x = y}+{x <> y}.

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(* In this file we define two calculi based on multisets for the propositonal intuitionistic modal logic
   iGL. The first one, called GL4ip, is the main calculus for iGL. The second one, named PSGL4ip,
   is essentially the calculus GL4ip with further restrictions on the application of the
   rules. In other words, the calculus PSGL4ip is a proof-search oriented version of GL4ip. *)

(* Definitions Language *)

(* First, let us define the propositional formulae we use here. *)

Inductive MPropF (W : Set) : Type :=
 | Var : W -> MPropF W
 | Bot : MPropF W
 | And : MPropF W -> MPropF W -> MPropF W
 | Or : MPropF W -> MPropF W -> MPropF W
 | Imp : MPropF W -> MPropF W -> MPropF W
 | Box : MPropF W -> MPropF W
.

Notation "# P" := (Var P) (at level 1) : My_scope.
Notation "A → B" := (Imp A B) (at level 16, right associativity) : My_scope.
Notation "A ∨ B" := (Or A B) (at level 16, right associativity) : My_scope.
Notation "A ∧ B" := (And A B) (at level 16, right associativity) : My_scope.
Notation "⊥" := Bot (at level 0)  : My_scope.

Lemma eq_dec_form : forall x y : MPropF V, {x = y}+{x <> y}.
Proof.
induction x.
- intros. destruct y.
  * pose (eq_dec_propvar v w). destruct s. left ; subst ; reflexivity.
    right. intro. inversion H. apply n. symmetry in H1. assumption.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * left. reflexivity.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n.
    assumption.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n.
    assumption.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n.
    assumption.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx y). destruct s. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption.
Qed.

Fixpoint weight_form (A : MPropF V) : nat :=
match A with
 | # P => 1
 | Bot _ => 1
 | And B C => 2 + (weight_form B) + (weight_form C)
 | Or B C => 1 + (weight_form B) + (weight_form C)
 | Imp B C => 1 + (weight_form B) + (weight_form C)
 | Box B => 1 + (weight_form B)
end.

(* Now, we can prove that some properties of formulae hold. *)

Definition is_atomicT (A : MPropF V) : Type :=
                  (existsT2 (P : V), A = # P) + (A = Bot V).

Definition is_boxedT (A : MPropF V) : Type :=
                  exists (B : MPropF V), A = Box B.

Definition is_boxedT2 (A : MPropF V) : Type :=
                  existsT2 (B : MPropF V), A = Box B.

Definition is_primeT (A : MPropF V) : Type :=
                  is_atomicT A + is_boxedT A.

(* We can define some types of lists formulae. For example, we can define
   lists of formulae which contain only propositional variables, or
   boxed formulae, or a combination of both. These are useful to define
   the rules. *)

Definition is_Atomic (Γ : list (MPropF V)) : Prop :=
    forall (A : MPropF V), (In A Γ) -> ((exists (P : V), A = # P) \/ (A = Bot V)).

Definition is_Boxed_list (Γ : list (MPropF V)) : Prop :=
    forall (A : MPropF V), (In A Γ) -> (exists (B : MPropF V), A = Box B).

Definition is_Prime (Γ : list (MPropF V)) : Prop :=
    forall (A : MPropF V), (In A Γ) ->
    (exists (B : MPropF V), A = Box B) \/ (exists (P : V), A = # P) \/ (A = Bot V).

(* With these properties we can define restrictions of univ_gen_ext on
   formulae. *)

Definition atom_gen_ext := univ_gen_ext (fun x => (is_atomicT x)).

Definition nobox_gen_ext := univ_gen_ext (fun x => (is_boxedT x) -> False).

Definition prim_gen_ext := univ_gen_ext (fun x => (is_primeT x)).

(* Some lemmas about gen_ext. *)

Lemma nobox_gen_ext_injective : forall (l0 l1 l : list (MPropF V)), (is_Boxed_list l0) -> (is_Boxed_list l1) ->
                                (nobox_gen_ext l0 l) -> (nobox_gen_ext l1 l) -> l1 = l0.
Proof.
intros l0 l1 l Hl0 Hl1 gen. generalize dependent l1.
induction gen.
- intros. inversion X. reflexivity.
- intros. inversion X.
  * subst. assert (l0 = l). apply IHgen. intro. intros. apply Hl0. apply in_cons. assumption.
    intro. intros. apply Hl1. apply in_cons. assumption. assumption. rewrite H. reflexivity.
  * subst. exfalso. apply H1. apply Hl0. apply in_eq.
- intros. apply IHgen. intro. intros. apply Hl0. assumption.
  intro. intros. apply Hl1. assumption. inversion X.
  subst. exfalso. apply p. apply Hl1. apply in_eq. subst. assumption.
Qed.

(* The next definitions help to define the combination of a list of boxed
   formulae and the unboxing of all the formulae in that list. *)

Definition unBox_formula (A : MPropF V) : MPropF V :=
  match A with
              | # P => # P
              | Bot _ => Bot _
              | And A B => And A B
              | Or A B => Or A B
              | Imp A B => Imp A B
              | Box A => A
              end
.

Fixpoint XBoxed_list (Γ : list (MPropF V)) : list (MPropF V):=
  match Γ with
  | [ ] => [ ]
  | h :: t => (unBox_formula h :: h :: XBoxed_list t)
  end
.

Fixpoint top_boxes (l : list (MPropF V)) : list (MPropF V) :=
match l with
  | nil => nil
  | h :: t => match h with
                | Box A => (Box A) :: top_boxes t
                | _ => top_boxes t
              end
end.

(* Now that we have defined these, we can prove some properties about them. *)

Lemma XBox_app_distrib :
  forall (l1 l2: list (MPropF V)), XBoxed_list (l1 ++ l2) = (XBoxed_list l1) ++ (XBoxed_list l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l with (l:=l2). simpl. reflexivity.
- intro l2. simpl. rewrite IHl1. reflexivity.
Qed.

Lemma subl_of_boxl_is_boxl :
  forall (l1 l2: list (MPropF V)), (incl l1 l2) -> (is_Boxed_list l2) -> (is_Boxed_list l1).
Proof.
intros. unfold is_Boxed_list. intros. apply H in H1. apply H0 in H1.
destruct H1. exists x. assumption.
Qed.

Lemma tl_of_boxl_is_boxl :
  forall (h : MPropF V) (t l : list (MPropF V)) (H: l = h :: t),
         (is_Boxed_list l) -> (is_Boxed_list t).
Proof.
intros. unfold is_Boxed_list. intros. assert (Hyp: In A l).
rewrite H. simpl. right. apply H1. apply H0 in Hyp. destruct Hyp.
exists x. assumption.
Qed.

Lemma list_preserv_XBoxed_list : forall (l : list (MPropF V)), incl l (XBoxed_list l).
Proof.
induction l.
- simpl. unfold incl. intros. inversion H.
- simpl. unfold incl. intros. inversion H.
  * subst. apply in_cons. apply in_eq.
  * apply in_cons. apply in_cons. apply IHl. assumption.
Qed.

Lemma is_box_is_in_boxed_list : forall l (A : MPropF V), In A l -> is_Boxed_list l -> (exists B, Box B = A).
Proof.
induction l.
- intros. inversion H.
- intros. inversion H.
  + subst. unfold is_Boxed_list in H0. pose (H0 A).
    apply e in H. destruct H. exists x. symmetry. assumption.
  + apply IHl. assumption. unfold is_Boxed_list. intros. unfold is_Boxed_list in H0.
    pose (H0 A0). apply e. apply in_cons. assumption.
Qed.

Lemma top_boxes_distr_app : forall (l1 l2 : list (MPropF V)),
      top_boxes (l1 ++ l2) = (top_boxes l1) ++ (top_boxes l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct a ; try apply IHl1.
  simpl. rewrite IHl1. reflexivity.
Qed.

Lemma box_in_top_boxes : forall l1 l2 A, existsT2 l3 l4, top_boxes (l1 ++ Box A :: l2) = l3 ++ Box A :: l4.
Proof.
intros. exists (top_boxes l1). exists (top_boxes l2). rewrite top_boxes_distr_app. auto.
Qed.

Lemma is_Boxed_list_top_boxes : forall l, is_Boxed_list (top_boxes l).
Proof.
intros. induction l.
- simpl. intro. intros. inversion H.
- intro. destruct a.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. destruct H.
    * exists a. auto.
    * apply IHl. assumption.
Qed.

Lemma nobox_gen_ext_top_boxes : forall l, nobox_gen_ext (top_boxes l) l.
Proof.
induction l.
- simpl. apply univ_gen_ext_refl.
- destruct a.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_cons. assumption.
Qed.

(* Finally, we can define the rules which constitute our calculi. We gather
   them in cacluli in a definition appearing later.

   We start by giving the rules common to both calculi. *)

Inductive IdPRule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | IdPRule_I : forall (P : V) (Γ0 Γ1 : list (MPropF V)),
          IdPRule [] (pair (Γ0 ++ # P :: Γ1) (# P))
.

Inductive IdRule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | IdRule_I : forall A Γ0 Γ1,
          IdRule [] (pair (Γ0 ++ A :: Γ1) A)
.

Inductive BotLRule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | BotLRule_I : forall Γ0 Γ1 A,
          BotLRule [] (pair (Γ0 ++ (Bot V) :: Γ1) A)
.

Inductive AndRRule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | AndRRule_I : forall A B Γ,
          AndRRule [(pair Γ A) ; (pair Γ B)]
                    (pair Γ (And A B))
.

Inductive AndLRule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | AndLRule_I : forall A B C Γ0 Γ1,
          AndLRule [(pair (Γ0 ++ A :: B :: Γ1) C)]
                    (pair (Γ0 ++ (And A B) :: Γ1) C)
.

Inductive OrR1Rule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | OrR1Rule_I : forall A B Γ,
          OrR1Rule [(pair Γ A)]
                    (pair Γ (Or A B))
.

Inductive OrR2Rule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | OrR2Rule_I : forall A B Γ,
          OrR2Rule [(pair Γ B)]
                    (pair Γ (Or A B))
.

Inductive OrLRule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | OrLRule_I : forall A B C Γ0 Γ1,
          OrLRule [(pair (Γ0 ++ A :: Γ1) C) ; (pair (Γ0 ++ B :: Γ1) C)]
                    (pair (Γ0 ++ (Or A B) :: Γ1) C)
.

Inductive ImpRRule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | ImpRRule_I : forall A B Γ0 Γ1,
          ImpRRule [(pair (Γ0 ++ A :: Γ1) B)]
                    (pair (Γ0 ++ Γ1) (Imp A B))
.

Inductive AtomImpL1Rule  : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | AtomImpL1Rule_I : forall P A C Γ0 Γ1 Γ2,
          AtomImpL1Rule [(pair (Γ0 ++ # P :: Γ1 ++ A :: Γ2) C)]
                    (pair (Γ0 ++ # P :: Γ1 ++ (Imp (# P) A) :: Γ2) C)
.

Inductive AtomImpL2Rule  : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | AtomImpL2Rule_I : forall P A C Γ0 Γ1 Γ2,
          AtomImpL2Rule [(pair (Γ0 ++ A :: Γ1 ++ # P :: Γ2) C)]
                    (pair (Γ0 ++ (Imp (# P) A) :: Γ1 ++ # P :: Γ2) C)
.

Inductive AndImpLRule  : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | AndImpLRule_I : forall A B C D Γ0 Γ1,
          AndImpLRule [(pair (Γ0 ++  (Imp A (Imp B C)) :: Γ1) D)]
                    (pair (Γ0 ++  (Imp (And A B) C) :: Γ1) D)
.

Inductive OrImpLRule  : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | OrImpLRule_I : forall A B C D Γ0 Γ1 Γ2,
          OrImpLRule [(pair (Γ0 ++ (Imp A C) :: Γ1 ++ (Imp B C) :: Γ2) D)]
                    (pair (Γ0 ++ (Imp (Or A B) C) :: Γ1 ++ Γ2) D)
.

Inductive ImpImpLRule  : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | ImpImpLRule_I : forall A B C D Γ0 Γ1,
          ImpImpLRule [(pair (Γ0 ++ (Imp B C) :: Γ1) (Imp A B)) ; (pair (Γ0 ++ C :: Γ1) D)]
                    (pair (Γ0 ++ (Imp (Imp A  B) C) :: Γ1) D)
.

Inductive BoxImpLRule  : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | BoxImpLRule_I : forall A B C BΓ Γ0 Γ1,
          (is_Boxed_list BΓ) -> (* have MS of boxed formulae prem L*)
          (nobox_gen_ext BΓ (Γ0 ++ Γ1)) -> (* extend BΓ in Γ0, the L of the ccl *)
          BoxImpLRule [(pair ((XBoxed_list BΓ) ++ [Box A]) A) ; (pair (Γ0 ++ B :: Γ1) C)]
                    (pair (Γ0 ++ (Imp (Box A) B) :: Γ1) C)
.

Inductive GLRRule : rlsT (prod (list (MPropF V)) (MPropF V)) :=
  | GLRRule_I : forall A BΓ Γ,
          (is_Boxed_list BΓ) -> (* have MS of boxed formulae prem L*)
          (nobox_gen_ext BΓ Γ) -> (* extend BΓ in Γ0, the L of the ccl *)
         GLRRule [(pair ((XBoxed_list BΓ) ++ [Box A]) A)] (pair Γ (Box A))
.

(* At last we can define our calculus GLS and its proof-search version PSGLS. *)

Inductive GL4ip_rules : rlsT  (prod (list (MPropF V)) (MPropF V)) :=
  | IdP : forall ps c, IdPRule ps c -> GL4ip_rules ps c
  | BotL : forall ps c, BotLRule ps c -> GL4ip_rules ps c
  | AndR : forall ps c, AndRRule ps c -> GL4ip_rules ps c
  | AndL : forall ps c, AndLRule ps c -> GL4ip_rules ps c
  | OrR1 : forall ps c, OrR1Rule ps c -> GL4ip_rules ps c
  | OrR2 : forall ps c, OrR2Rule ps c -> GL4ip_rules ps c
  | OrL : forall ps c, OrLRule ps c -> GL4ip_rules ps c
  | ImpR : forall ps c, ImpRRule ps c -> GL4ip_rules ps c
  | AtomImpL1 : forall ps c, AtomImpL1Rule ps c -> GL4ip_rules ps c
  | AtomImpL2 : forall ps c, AtomImpL2Rule ps c -> GL4ip_rules ps c
  | AndImpL : forall ps c, AndImpLRule ps c -> GL4ip_rules ps c
  | OrImpL : forall ps c, OrImpLRule ps c -> GL4ip_rules ps c
  | ImpImpL : forall ps c, ImpImpLRule ps c -> GL4ip_rules ps c
  | BoxImpL : forall ps c, BoxImpLRule ps c -> GL4ip_rules ps c
  | GLR : forall ps c, GLRRule ps c -> GL4ip_rules ps c
.

(* To make it terminating, I need to constrain all rules not to be applied on identities of all complexity. *)

Inductive PSGL4ip_rules : rlsT  (prod (list (MPropF V)) (MPropF V)) :=
  | PSId : forall ps c, IdRule ps c -> PSGL4ip_rules ps c
  | PSBotL : forall ps c, BotLRule ps c -> PSGL4ip_rules ps c
  | PSAndR : forall ps c, (IdRule [] c -> False) ->
                                      (BotLRule [] c -> False) ->AndRRule ps c -> PSGL4ip_rules ps c
  | PSAndL : forall ps c, (IdRule [] c -> False) ->
                                     (BotLRule [] c -> False) ->AndLRule ps c -> PSGL4ip_rules ps c
  | PSOrR1 : forall ps c, (IdRule [] c -> False) ->
                                      (BotLRule [] c -> False) ->OrR1Rule ps c -> PSGL4ip_rules ps c
  | PSOrR2 : forall ps c, (IdRule [] c -> False) ->
                                      (BotLRule [] c -> False) ->OrR2Rule ps c -> PSGL4ip_rules ps c
  | PSOrL : forall ps c, (IdRule [] c -> False) ->
                                   (BotLRule [] c -> False) -> OrLRule ps c -> PSGL4ip_rules ps c
  | PSImpR : forall ps c, (IdRule [] c -> False) ->
                                     (BotLRule [] c -> False) ->ImpRRule ps c -> PSGL4ip_rules ps c
  | PSAtomImpL1 : forall ps c, (IdRule [] c -> False) ->
                                               (BotLRule [] c -> False) -> AtomImpL1Rule ps c -> PSGL4ip_rules ps c
  | PSAtomImpL2 : forall ps c, (IdRule [] c -> False) ->
                                               (BotLRule [] c -> False) ->AtomImpL2Rule ps c -> PSGL4ip_rules ps c
  | PSAndImpL : forall ps c, (IdRule [] c -> False) ->
                                           (BotLRule [] c -> False) -> AndImpLRule ps c -> PSGL4ip_rules ps c
  | PSOrImpL : forall ps c, (IdRule [] c -> False) ->
                                         (BotLRule [] c -> False) -> OrImpLRule ps c -> PSGL4ip_rules ps c
  | PSImpImpL : forall ps c, (IdRule [] c -> False) ->
                                           (BotLRule [] c -> False) -> ImpImpLRule ps c -> PSGL4ip_rules ps c
  | PSBoxImpL : forall ps c, (IdRule [] c -> False) ->
                                           (BotLRule [] c -> False) -> BoxImpLRule ps c -> PSGL4ip_rules ps c
  | PSGLR : forall ps c, (IdRule [] c -> False) ->
                                    (BotLRule [] c -> False) -> GLRRule ps c -> PSGL4ip_rules ps c
.

Definition GL4ip_prv s := derrec GL4ip_rules (fun _ => False) s.


From Coq Require Import Lists.List.
From Coq Require Import micromega.Lia.
From Coq Require Import ZArith.ZArith.

From CertiGraph Require Import graph.graph_gen.
From CertiGraph Require Import graph.graph_model.
From CertiGraph Require Import lib.List_ext.

From CertiGC Require Import model.constants.
From CertiGC Require Import model.heapgraph.graph.
From CertiGC Require Import model.util.

Local Open Scope Z.

Definition heapgraph_block (g : HeapGraph) (v : Addr) : Block := vlabel g v.

Lemma lgd_raw_fld_length_eq :
  forall (g : HeapGraph) v e v',
  Zlength (block_fields (heapgraph_block g v)) =
  Zlength (block_fields (heapgraph_block (labeledgraph_gen_dst g e v') v)).
Proof.
  reflexivity.
Qed.

Definition heapgraph_block_size (g : HeapGraph) (v : Addr) : Z := Zlength (heapgraph_block g v).(block_fields) + 1.

Lemma heapgraph_block_size__one (g : HeapGraph) (v : Addr) : 1 < heapgraph_block_size g v.
Proof.
  (unfold heapgraph_block_size).
  (pose proof (block_fields__range (heapgraph_block g v))).
  lia.
Qed.

Definition heapgraph_block_size_accum
  (g : HeapGraph) (gen : nat)
  (s : Z) (n : nat) : Z :=
  s + heapgraph_block_size g {| addr_gen := gen; addr_block := n |}.

Lemma heapgraph_block_size_accum__mono
  (g : HeapGraph) (gen : nat)
  (s : Z) (n : nat) :
  s < heapgraph_block_size_accum g gen s n.
Proof.
  (unfold heapgraph_block_size_accum).
  (pose proof (heapgraph_block_size__one g {| addr_gen := gen; addr_block := n |}) as H).
  lia.
Qed.

Lemma heapgraph_block_size_accum__comm
  (g : HeapGraph) (gen : nat)
  (s : Z) (n1 n2 : nat) :
  heapgraph_block_size_accum g gen (heapgraph_block_size_accum g gen s n1) n2 =
  heapgraph_block_size_accum g gen (heapgraph_block_size_accum g gen s n2) n1.
Proof.
  (unfold heapgraph_block_size_accum).
  lia.
Qed.

Lemma heapgraph_block_size_accum__fold_lt
  (g : HeapGraph) (gen : nat)
  (s : Z) (l : list nat)
  (Hl : l <> nil) : s < fold_left (heapgraph_block_size_accum g gen) l s.
Proof.
  (apply (fold_left_Z_mono_strict (heapgraph_block_size_accum g gen) nil l l); try assumption).
  + (apply heapgraph_block_size_accum__mono).
  + (apply heapgraph_block_size_accum__comm).
  + (apply Permutation_refl).
Qed.

Lemma heapgraph_block_size_accum__fold_le
  (g : HeapGraph) (gen : nat)
  (s : Z) (l : list nat) :
  s <= fold_left (heapgraph_block_size_accum g gen) l s.
Proof.
  (destruct l as [| n l]; try easy).
  (rewrite Z.le_lteq).
  left.
  now apply heapgraph_block_size_accum__fold_lt.
Qed.

Lemma heapgraph_block_size_accum__fold_left
  (g : HeapGraph) (gen : nat)
  (l : list nat) (z1 z2 : Z) :
  fold_left (heapgraph_block_size_accum g gen) l (z2 + z1) = fold_left (heapgraph_block_size_accum g gen) l z2 + z1.
Proof.
  (revert z1 z2; induction l as [| s l IHl]; intros z1 z2; simpl; try easy).
  (rewrite <- IHl).
  f_equal.
  (unfold heapgraph_block_size_accum).
  lia.
Qed.

Definition heapgraph_block_size_prev
  (g : HeapGraph) (gen i : nat) : Z :=
  fold_left (heapgraph_block_size_accum g gen) (nat_inc_list i) 0.

Lemma heapgraph_block_size_prev__S
  (g : HeapGraph) (gen i : nat) :
  heapgraph_block_size_prev g gen (S i) =
  heapgraph_block_size_prev g gen i + heapgraph_block_size g {| addr_gen := gen; addr_block := i |}.
Proof.
  (unfold heapgraph_block_size_prev at 1).
  now rewrite nat_inc_list_S, fold_left_app.
Qed.

Lemma heapgraph_block_size_prev__nonneg (g : HeapGraph) (gen i : nat) : 0 <= heapgraph_block_size_prev g gen i.
Proof.
  (unfold heapgraph_block_size_prev).
  (apply heapgraph_block_size_accum__fold_le).
Qed.

Lemma heapgraph_block_size_prev__mono_strict
  (g : HeapGraph) (gen i j : nat)
  (Hij : (i < j)%nat) :
  heapgraph_block_size_prev g gen i < heapgraph_block_size_prev g gen j.
Proof.
  (assert (Hij' : (j = i + (j - i))%nat) by lia).
  (rewrite Hij').
  (remember (j - i)%nat as n eqn:En ).
  subst j.
  (unfold heapgraph_block_size_prev).
  (rewrite nat_inc_list_app, fold_left_app).
  (apply heapgraph_block_size_accum__fold_lt).
  (pose proof (nat_seq_length i n) as Hin).
  (destruct (nat_seq i n); try easy).
  (simpl in Hin).
  lia.
Qed.

Lemma heapgraph_block_size_prev__mono
  (g : HeapGraph) (gen i j : nat)
  (Hij : (i <= j)%nat) :
  heapgraph_block_size_prev g gen i <= heapgraph_block_size_prev g gen j.
Proof.
  (rewrite Nat.le_lteq in Hij).
  (destruct Hij as [Hij| Hij]).
  + (rewrite Z.le_lteq).
    left.
    now apply heapgraph_block_size_prev__mono_strict.
  + subst.
    lia.
Qed.

Lemma heapgraph_block_size_prev__lt_rev
  (g : HeapGraph) (gen i j : nat)
  (Hij : heapgraph_block_size_prev g gen i < heapgraph_block_size_prev g gen j) :
  (i < j)%nat.
Proof.
  (destruct (le_lt_dec j i) as [Hij'| Hij']; try easy).
  (apply (heapgraph_block_size_prev__mono g gen) in Hij').
  lia.
Qed.

Definition heapgraph_block_offset
  (g : HeapGraph) (v : Addr) : Z :=
  heapgraph_block_size_prev g (addr_gen v) (addr_block v) + 1.

Definition heapgraph_block_is_no_scan
  (g : HeapGraph) (v : Addr) : Prop :=
  NO_SCAN_TAG <= (heapgraph_block g v).(block_tag).


Require Import Sty Tac Var.

Create HintDb free discriminated.

Inductive Free : Var -> Sty -> Prop :=
| Free_send : forall X B S, Free X S -> Free X (send B S)
| Free_recv : forall X B S, Free X S -> Free X (recv B S)
| Free_echoice : forall X S1 S2, Free X S1 \/ Free X S2 -> Free X (echoice S1 S2)
| Free_ichoice : forall X S1 S2, Free X S1 \/ Free X S2 -> Free X (ichoice S1 S2)
| Free_mu : forall X Y S, Free X S -> X <> Y -> Free X (mu Y S)
| Free_var : forall X, Free X (var X)
.
Hint Constructors Free : free.

Definition Closed (S : Sty) : Prop :=
  forall X, ~ Free X S.
Hint Unfold Closed : free.