Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders.

(*
We define finite sets as the initial join semi lattice over a decidable type.

An important aspect of our interface is the possibility to make fast
implementations. Therefore it is important that various properties of the
carrier set can be used to create an implementation. Examples of
implementations are:
* Finite sets as unordered lists.
* Finite sets as AVLs (here we need order).
* Finite sets of positives as trees with boolean nodes.
The above examples already illustrate that it is very inconvenient to
fix the properties of the carrier right now. Instead we use the following
type class:
*)

Class SetType (A : Type) := set_type: Type.
Arguments set_type _ {SetType}.
(* We can't make this type transparent to typeclass resolution. *)

(*
The key idea is that an implementation can let instances of this class depend
on any specific properties it likes.

For convenience we define some notations to hide nasty details.
*)
Notation EmptySet A := (Bottom (set_type A)).
Notation "∅" := (@bottom (set_type _) _) : mc_scope.
Notation SetEquiv A := (Equiv (set_type A)).
Notation SetJoin A := (Join (set_type A)).
Notation SetMeet A := (Meet (set_type A)).
Notation SetDifference A := (Difference (set_type A)).
Notation SetSingleton A := (Singleton A (set_type A)).
Notation SetLe A := (Le (set_type A)).
Notation SetContains A := (Contains A (set_type A)).

Class FSetExtend A `{t : SetType A} :=
  fset_extend `{Join B} `{Bottom B} : (A → B) → set_type A → B.

Class FSet A `{At : SetType A} `{Ae : Equiv A} `{Ate : SetEquiv A}
   `{Aempty : EmptySet A} `{Ajoin : SetJoin A} `{Asingle : SetSingleton A}
   `{∀ a₁ a₂ : A, Decision (a₁ = a₂)} `{U : !FSetExtend A} :=
 { fset_bounded_sl :> BoundedJoinSemiLattice (set_type A)
  ; singleton_mor :> Setoid_Morphism singleton
  ; fset_extend_mor `{BoundedJoinSemiLattice B} `{!Setoid_Morphism (f : A → B)} :>
      BoundedJoinSemiLattice_Morphism (fset_extend f)
  ; fset_extend_correct `{BoundedJoinSemiLattice B}  (f : A → B) `{!Setoid_Morphism f} :
      f = fset_extend f ∘ singleton
  ; fset_extend_unique `{Equiv B} `{Join B} `{Bottom B} (f : A → B) `{!Setoid_Morphism f}
      (h : set_type A → B) `{!BoundedJoinSemiLattice_Morphism h} : f = h ∘ singleton → h = fset_extend f }.

Definition fset_map `(f : A → B) `{SetType A} `{SetType B} `{EmptySet B} `{SetJoin B} `{SetSingleton B}
  `{U : !FSetExtend A} : set_type A → set_type B := fset_extend (singleton ∘ f).

(*
Next we describe the order and set inclusion. Constructing a
JoinSemiLatticeOrder might be quite inconvenient since we have used the
algebraic definition of a lattice in FSet. However, an implementation can
freely use orders.lattices.alt_Build_JoinSemiLatticeOrder.
*)

Class FSetContainsSpec A `{At : SetType A} `{Ae : Equiv A} `{Ate : SetEquiv A}
     `{SetLe A} `{SetContains A} `{Ajoin : SetJoin A} `{Asingle : SetSingleton A} :=
  { fset_join_sl_order :> JoinSemiLatticeOrder (≤)
  ; fset_in_singleton_le : ∀ x X, x ∈ X ↔ {{ x }} ≤ X }.

(*
Unfortunately, properties as meet and the differences cannot be uniquely
defined in an algebraic way, therefore we just use set inclusion.
*)
Class FullFSet A {car Ae conAe conAle Acontains Aempty Ajoin Asingle U Adec} `{Adiff : SetDifference A} `{Ameet : SetMeet A} :=
  { full_fset_fset :> @FSet A car Ae conAe Aempty Ajoin Asingle U Adec
  ; full_fset_contains :> @FSetContainsSpec A car Ae conAe conAle Acontains Ajoin Asingle
  ; fset_in_meet : ∀ X Y x, x ∈ X ⊓ Y ↔ (x ∈ X ∧ x ∈ Y)
  ; fset_in_difference : ∀ X Y x, x ∈ X∖ Y ↔ (x ∈ X ∧ x ∉ Y) }.


Require Import FOL.
Require Import Deduction.
Require Import Tarski.
Require Import List.
Require Import Arith.PeanoNat.
From Equations Require Import Equations.
Require Import Coq.Logic.Eqdep_dec.

Definition subset_T `{funcs_signature, preds_signature} (T1 T2 : theory) := forall (phi : form), phi t∈ T1 -> phi t∈ T2.
Infix "⊑" := subset_T (at level 20).

Definition extend `{funcs_signature, preds_signature} T (phi : form) := fun psi => T psi \/ psi = phi.
Infix "⋄" := extend (at level 20).

Section Theories.

Context {Σ_funcs : funcs_signature}.
Context {Σ_preds : preds_signature}.

Context {p : peirce}.

Definition mapT (f : form -> form) (T : theory) : theory := fun phi => exists psi, T psi /\ f psi = phi.

(** Equality deciders *)

Context {eq_dec_Funcs : EqDec syms}.
Context {eq_dec_Preds : EqDec preds}.

Instance eqdec_vec X {DX : EqDec X} n : EqDec (Vector.t X n).
Proof.
  intros x y. apply Vector.eq_dec with (A_beq := fun a b => if DX a b then true else false). intros a b. now destruct (DX a b).
Qed.

Lemma eqdec_vec_in X n (v : vec X n) :
  (forall x, vec_in x v -> forall y, {x = y} + {x <> y}) -> forall v', {v = v'} + {v <> v'}.
Proof.
  intros Hv. induction v.
  - intros v'. dependent elimination v'. now left.
  - intros v'. dependent elimination v'. destruct (Hv h (vec_inB h v) h0) as [->|].
    destruct ((IHv (fun x H => Hv x (vec_inS x h0 v H))) t) as [->|]. now left.
    right. intros [=]. apply inj_pair2_eq_dec in H0. auto. intros x y. decide equality.
    right. congruence.
Qed.

Global Instance eqdec_term : EqDec term.
Proof.
  intros x. induction x.
  - destruct y. destruct (eq_dec x n) as [->|]. now left. right. congruence.
    right. congruence.
  - destruct y. right. congruence. destruct (eq_dec F f) as [->|].
    assert ({v = v0} + {v <> v0}) as [->|]. { apply eqdec_vec_in. exact X. }
    now left. right. intros [=]. apply inj_pair2_eq_dec in H0. auto. exact eq_dec.
    right. congruence.
Qed.

Global Instance eqdec_form : EqDec form.
Proof.
  intros x. induction x; destruct y; try (right; congruence).
  - now left.
  - destruct (eq_dec P P0) as [->|]. destruct (eq_dec v v0) as [->|].
    now left. right. intros [=]. apply inj_pair2_eq_dec in H0. auto. exact eq_dec.
    right. congruence.
  - destruct b, b0; try (right; congruence);
    destruct (IHx1 y1) as [->|], (IHx2 y2) as [->|]; try (now left); try (right; congruence).
  - destruct q, q0; try (right; congruence);
    destruct (IHx y) as [->|]; try (now left); try (right; congruence).
Qed.

(* Now we can define removal from formula lists *)
Definition rem := @remove form eq_dec.

(* Inductive unused_term (n : nat) : term -> Prop :=
| uft_var m : n <> m -> unused_term n ($m)
| uft_Func F v : (forall t, vec_in t v -> unused_term n t) -> unused_term n (func F v).

Inductive unused (n : nat) : form -> Prop :=
| uf_Fal : unused n fal
| uf_Pred P v : (forall t, vec_in t v -> unused_term n t) -> unused n (atom P v)
| uf_Bin op phi psi : unused n phi -> unused n psi -> unused n (bin op phi psi)
| uf_Quant op phi : unused (S n) phi -> unused n (quant op phi).

Definition closed_theory (T : theory) := forall phi, phi t∈ T -> closed phi = true.

Lemma subst_closed s phi :
  closed phi = true -> phi[s] = phi.
Proof.
Admitted. *)

Theorem WeakT A B phi :
  A ⊩ phi -> A ⊑ B -> B ⊩ phi.
Proof.
  intros H. revert B.
  induction H; intros B HB; try unshelve (solve [econstructor; intuition]); try now econstructor.
Qed.

Lemma contains_nil T :
  List.nil ⊏ T.
Proof. intuition. now exfalso. Qed.

Lemma contains_cons a A T :
  a t∈ T -> A ⊏ T -> (a :: A) ⊏ T.
Proof. intros ? ? ? []; subst; intuition. Qed.

Lemma contains_cons2 a A T :
  (a :: A) ⊏ T -> A ⊏ T.
Proof. firstorder. Qed.

Lemma contains_app A B T :
  A ⊏ T -> B ⊏ T -> (A ++ B) ⊏ T.
Proof. intros ? ? ? [] % in_app_or; intuition. Qed.

Lemma contains_extend1 phi T :
  phi t∈ (T ⋄ phi).
Proof. now right. Qed.

Lemma contains_extend2 phi psi T :
  phi t∈ T -> phi t∈ (T ⋄ psi).
Proof. intros ?. now left. Qed.

Lemma contains_extend3 A T phi :
  A ⊏ T -> A ⊏ (T ⋄ phi).
Proof.
  intros ? ? ?. left. intuition.
Qed.

Lemma subset_refl T :
  T ⊑ T.
Proof.
  firstorder.
Qed.

Lemma subset_trans T1 T2 T3 :
  T1 ⊑ T2 -> T2 ⊑ T3 -> T1 ⊑ T3.
Proof.
  firstorder.
Qed.

Lemma contains_rem A T phi :
  A ⊏ T ⋄ phi -> rem phi A ⊏ T.
Proof.
  intros H1. induction A. firstorder. cbn. destruct (eq_dec phi a) as [->|H2].
  - apply IHA. eapply contains_cons2, H1.
  - apply contains_cons. destruct (H1 a) as [| ->]; firstorder.
    apply IHA. eapply contains_cons2, H1.
Qed.

Lemma incl_rem1 A phi :
  rem phi A <<= A.
Proof.
  induction A. firstorder. cbn. destruct (eq_dec phi a) as [-> |]; firstorder.
Qed.

Lemma incl_rem2 A phi :
  A <<= phi :: rem phi A.
Proof.
  induction A. firstorder. cbn. destruct (eq_dec phi a) as [-> |]; firstorder.
Qed.

Definition shift_down := fun n => match n with 0 => $0 | S n => $n end.

Lemma map_shift_up_down_contains A T :
  (A ⊏ mapT (subst_form ↑) T) -> map (subst_form shift_down) A ⊏ T.
Proof.
  intros H1. induction A. easy. intros f H. destruct H as [<-|].
  - destruct (H1 a) as [f [H2 <-]]. now left. change (f[↑][shift_down] t∈ T).
    enough (f[↑][shift_down] = f) as -> by easy.
    rewrite subst_comp. now apply subst_id.
  - firstorder.
Qed.

Lemma map_shift_up_down_eq A T :
  A ⊏ mapT (subst_form ↑) T -> map (subst_form ↑) (map (subst_form shift_down) A) = A.
Proof.
  intros H1. induction A. reflexivity. cbn. f_equal.
  - destruct (H1 a) as [f [H2 <-]]. now left.
    enough (f[↑ >> subst_term shift_down][↑] = f[↑]) as X by now rewrite <- subst_comp in X.
    f_equal. now apply subst_id.
  - firstorder.
Qed.

(** Prv translations *)

Lemma T_II T phi psi :
  T ⋄ phi ⊩ psi -> T ⊩ (phi --> psi).
Proof.
  intros [A[H1 H2]]. exists (rem phi A). split.
  intros ? ?%in_remove. firstorder.
  apply II. eapply Weak. apply H2. apply incl_rem2.
Qed.

Lemma T_IE T phi psi :
  T ⊩ (phi --> psi) -> T ⊩ phi -> T ⊩ psi.
Proof.
  intros [A[A1 A2]] [B[B1 B2]]. exists (A++B). split.
  now apply contains_app. apply IE with phi.
  eapply Weak. apply A2. now apply incl_appl.
  eapply Weak. apply B2. now apply incl_appr.
Qed.

Lemma T_AllI T phi :
  mapT (subst_form ↑) T ⊩ phi -> T ⊩ ∀ phi.
Proof.
  intros [A[H1 H2]].
  exists (map (subst_form shift_down) A). split.
  - now apply map_shift_up_down_contains.
  - apply AllI. erewrite map_shift_up_down_eq; auto.
Qed.

Lemma T_AllE T t phi :
  (T ⊩ ∀ phi) -> T ⊩ phi[t..].
Proof.
  intros [A[H1 H2]]. exists A. split. firstorder. now apply AllE.
Qed.

Lemma T_ExI T t phi :
  T ⊩ phi[t..] -> T ⊩ ∃ phi.
Proof.
  intros [A[A1 A2]]. exists A. split. firstorder. now apply ExI with t.
Qed.

Lemma T_ExE T phi psi :
  (T ⊩ ∃ phi) -> (mapT (subst_form ↑) T) ⋄ phi ⊩ psi[↑] -> T ⊩ psi.
Proof.
  intros [A[A1 A2]] [B[B1 B2]].
  exists (A ++ map (subst_form shift_down) (rem phi B)). split.
  - apply contains_app. assumption. apply map_shift_up_down_contains.
    now apply contains_rem.
  - eapply ExE.
    + eapply Weak. apply A2. now apply incl_appl.
    + eapply Weak. apply B2. rewrite map_app. erewrite map_shift_up_down_eq with (T := T).
      eapply incl_tran with (m := phi :: rem phi B). apply incl_rem2.
      apply incl_cons. now left. apply incl_tl. now apply incl_appr.
      clear B2. induction B. firstorder. cbn. destruct (eq_dec phi a) as [-> |].
      * firstorder.
      * apply contains_cons. destruct (B1 a) as [| ->]. now left. assumption.
        apply IHB. eapply contains_cons2, B1. easy. firstorder.
Qed.

Lemma T_Exp T phi :
  T ⊩ ⊥ -> T ⊩ phi.
Proof.
  intros [A[H1 H2]]. exists A. split. firstorder. now apply Exp.
Qed.

Lemma T_Ctx T phi :
  phi t∈ T -> T ⊩ phi.
Proof.
  intros H. exists (phi::nil). split.
  intros psi H2. now assert (phi = psi) as -> by firstorder.
  apply Ctx. now left.
Qed.

Lemma T_CI T phi psi :
  T ⊩ phi -> T ⊩ psi -> T ⊩ (phi ∧ psi).
Proof.
  intros [A[A1 A2]] [B[B1 B2]]. exists (A++B). split.
  now apply contains_app. apply CI.
  eapply Weak. apply A2. now apply incl_appl.
  eapply Weak. apply B2. now apply incl_appr.
Qed.

Lemma T_CE1 T phi psi :
  T ⊩ (phi ∧ psi) -> T ⊩ phi.
Proof.
  intros [A[H1 H2]]. exists A. split. assumption. eapply CE1. apply H2.
Qed.

Lemma T_CE2 T phi psi :
  T ⊩ (phi ∧ psi) -> T ⊩ psi.
Proof.
  intros [A[H1 H2]]. exists A. split. assumption. eapply CE2. apply H2.
Qed.

Lemma T_DI1 T phi psi :
  T ⊩ phi -> T ⊩ (phi ∨ psi).
Proof.
  intros [A[H1 H2]]. exists A. split. assumption. eapply DI1. apply H2.
Qed.

Lemma T_DI2 T phi psi :
  T ⊩ psi -> T ⊩ (phi ∨ psi).
Proof.
  intros [A[H1 H2]]. exists A. split. assumption. eapply DI2. apply H2.
Qed.

Lemma T_DE T phi psi theta :
  T ⊩ (phi ∨ psi) -> T ⋄ phi ⊩ theta -> T ⋄ psi ⊩ theta -> T ⊩ theta.
Proof.
  intros [A[A1 A2]] [B[B1 B2]] [C[C1 C2]].
  exists (A ++ (rem phi B) ++ (rem psi C)). split.
  - apply contains_app. assumption. apply contains_app.
    intros ? ?%in_remove. firstorder. intros ? ?%in_remove. firstorder.
  - eapply DE. eapply Weak. apply A2. now apply incl_appl.
    + eapply Weak. apply B2. apply incl_tran with (m := phi::rem phi B).
      apply incl_rem2. apply incl_cons. now left.
      now apply incl_tl, incl_appr, incl_appl.
    + eapply Weak. apply C2. apply incl_tran with (m := psi::rem psi C).
      apply incl_rem2. apply incl_cons. now left.
      now apply incl_tl, incl_appr, incl_appr.
Qed.

Lemma T_Pc T phi psi :
  T ⊩C (((phi --> psi) --> phi) --> phi).
Proof.
  exists nil. split. firstorder. apply Pc.
Qed.

Lemma switch_imp_T T alpha phi : T ⊩ (alpha --> phi) <-> (T ⋄ alpha) ⊩ phi.
Proof.
  split.
  - intros H. eapply T_IE. 2: apply T_Ctx. eapply WeakT.
    exact H. all : firstorder.
  - apply T_II.
Qed.

End Theories.


Require Export Iron.Language.DelayedSimpleUS.Step.

(* A well typed expression is either a value or can
   take a step in the evaluation. *)
Theorem progress
 :  forall te x t
 ,  TypeX  te x t
 -> Done x \/ (exists x', Step x x').
Proof.
 intros. gen t.
 induction x using exp_iind; intros.

 - Case "XVar".
   left. auto.

 - Case "XLam".
   left. auto.

 - Case "XApp".
   inverts_type.

   assert (Done x1 \/ (exists x1', Step x1 x1')) as HX1; eauto.
   destruct HX1.

   + SCase "x1 is done.".
     destruct x1.

     * SSCase "x1 is a variable".
       left.  eapply DoneApp.
       split.
        eapply DoneVar.
        intuition. nope.

     * SSCase "x1 is an abstraction".
       right.
       assert (Done x2 \/ (exists x2', Step x2 x2')) as HX2; eauto.
       destruct HX2.

       SSSCase "beta reduction".
        exists (substXX (Bind v x2 :: ss) x1).
        eapply EsAbsApp.
        assumption.

       SSSCase "x2 steps".
        destruct H0 as [x2'].
        exists (XApp (XAbs ss v t0 x1) x2').
        eapply EsAppRight.
         inverts H. assumption.
         assumption.

     * SSCase "x1 is an application".
       left.
       eapply DoneApp.
       split.
        assumption.
        intuition. nope.

   + SCase "x1 steps".
     destruct H as [x1'].
     right.
     exists (XApp x1' x2).
     eapply EsAppLeft.
     assumption.
Qed.


Require Import Bool.

Section Dup.

  Variable A : Type.

  Hypothesis A_eq_dec : forall (x y : A), {x = y} + {x <> y}.

  Open Scope list_scope.
  Open Scope bool_scope.

  Definition A_eqb x y := if A_eq_dec x y then true else false.

  Fixpoint elem a l :=
    match l with
    | nil => false
    | x :: xs => A_eqb x a || elem a xs
    end.

  Fixpoint nodup l :=
    match l with
    | nil => true
    | x::xs => negb (elem x xs) && nodup xs
    end.

  Definition set := A -> bool.

  Definition set_mem a (s:set) := (s a = true).
  Definition set_memb a (s:set) := s a.

  Notation "a '\in' S" := (set_mem a S) (at level 70).
  Notation "a '\inb' S" := (set_memb a S) (at level 70).

  Definition empty_set : set := fun _ => false.

  Definition singleton_set (a : A) : set := A_eqb a.

  Definition union s0 s1 : set := fun x => s0 x || s1 x.
  Definition intersection s0 s1 : set := fun x => s0 x && s1 x.

  (* obviously not correct *)
  Axiom set_eq_dec : forall (s0 s1:set), {s0 = s1} + {s0 <> s1}.
  Definition set_eqb s0 s1 := if set_eq_dec s0 s1 then true else false.

  Require Import FunctionalExtensionality.

  Definition disjoint s0 s1 := set_eqb (intersection s0 s1) empty_set.

  Lemma disjoint_comm s0 s1 : disjoint s0 s1 = disjoint s1 s0.
  Admitted.

  Lemma disjoint_over_union_r s0 s1 s2 :
    disjoint s0 (union s1 s2) = true <->
    andb (disjoint s0 s1) (disjoint s0 s2) = true.
  Admitted.

  Lemma disjoint_over_union_l s0 s1 s2 :
    disjoint (union s0 s1) s2 = true <->
    andb (disjoint s0 s2) (disjoint s1 s2) = true.
  Admitted.

  Lemma eq_singleton x y : x = y <-> x \in singleton_set y.
    unfold set_mem, singleton_set, A_eqb.
    split.
    - intro; subst. case (A_eq_dec y y); tauto.
    - case (A_eq_dec y x). symmetry; tauto.
      intros ? H1; inversion H1.
  Qed.

  Fixpoint elems (l:list A) : set.
    destruct l as [|x xs].
    - apply empty_set.
    - apply union.
      apply (singleton_set x).
      apply (elems xs).
  Defined.
  Print elems.

  Lemma in_singleton_disjoint x s : x \in s <-> disjoint (singleton_set x) s = false.
  Admitted.

  Lemma elem_in_elems a l : elem a l = true <-> a \in (elems l).
  Admitted.

  Lemma bool_ext b0 b1 : (b0 = true <-> b1 = true) -> b0 = b1.
  Admitted.

  Lemma bool_ext_neg b0 b1 : (b0 = true <-> b1 = false) -> b0 = negb b1.
  Admitted.

  Lemma neg_swap b0 b1 : b0 = negb b1 -> negb b0 = b1.
  Admitted.

  (* should be obvious? *)
(*  Lemma disj_elems s  : disjoint s (elems l) = true <->
  *)

  Definition nodup' l : {y | y = nodup l}.
    destruct l as [|x xs].
    - simpl. eexists; reflexivity.
    - simpl.
      rewrite (bool_ext _ _ (elem_in_elems _ _)).
      rewrite (bool_ext_neg _ _ (in_singleton_disjoint _ _)).
      rewrite negb_involutive.
      generalize (singleton_set x) xs;  fix nodup'' 2.
      destruct xs0 as [|x' xs'].
      + simpl. eexists; reflexivity.
      + simpl. rewrite (bool_ext _ _ (disjoint_over_union_r _ _ _)).
        rewrite <- andb_assoc.
        rewrite (bool_ext _ _ (elem_in_elems _ _)).
        rewrite (bool_ext_neg _ _ (in_singleton_disjoint _ _)).
        rewrite negb_involutive.
        rewrite (andb_assoc (disjoint s (elems xs'))).
        rewrite <- (bool_ext _ _ (disjoint_over_union_l _ _ _)).
        edestruct nodup'' as [r R].
        rewrite <- R.
        rewrite disjoint_comm.
        rewrite <- (neg_swap _ _ (bool_ext_neg _ _ (in_singleton_disjoint _ _))).
        fold (set_memb x' s).
        eexists; reflexivity.
  Defined.

End Dup.

Extraction nodup'.


Require Export Map.

Definition comp_set  {T1 T2 T3 : finType} (G : {set T2 * T3}) (F : {set T1 * T2}) :=
    [set u | [ exists b, ((u.1, b) ∈ F) && ((b,u.2) ∈ G) ]].

Lemma comp_setP  {T1 T2 T3 : finType} (G : {set T2 * T3}) (F : {set T1 * T2}) u :
    reflect ( exists b, ((u.1, b) ∈ F) /\ ((b,u.2) ∈ G)) (u ∈ comp_set G F).
Proof.
    apply (iffP idP); rewrite in_set.
    +   move /existsP => [b /andP Hb]; exists b => //.
    +   move => [b Hb]; apply /existsP; exists b; apply /andP => //.
Qed.

Lemma compfH {T1 T2 T3 : finType} {A : {set T1}} {B : {set T2}} {C : {set T3}}
    (g : B → C) (f : A → B) : let gf := comp_set (graph g) (graph f) in
    func_mixinp A C gf.
Proof.
    move => gf u /comp_setP; case => b; case => //.
    induction f as [f_ Hf_], g as [g_ Hg_] => /=.
    move : (func_mixin_elim Hf_) => Hf.
    move : (func_mixin_elim Hg_) => Hg.
    move /Hf => /= [Ha Hb].
    move /Hg => /= [_ Hc].
    done.
Qed.

Definition compf {T1 T2 T3 : finType} {A : {set T1}} {B : {set T2}} {C : {set T3}}
    (g : B → C) (f : A → B) : A → C :=
    mkFunc (comp_set (graph g) (graph f)) (func_mixin_intro (compfH g f)).

Lemma compH {T1 T2 T3 : finType} {A : {set T1}} {B : {set T2}} {C : {set T3}}
    (g : B ⟶ C) (f : A ⟶ B) :
    map_mixinp A C (compf g f).
Proof.
    induction f as [Γf Hf_], g as [Γg Hg_].
    induction Γf as [Gf HGf_], Γg as [Gg HGg_].
    move : (map_mixin_elim Hf_) => Hf.
    move : (map_mixin_elim Hg_) => Hg.
    move : (func_mixin_elim HGf_) => HGf.
    move : (func_mixin_elim HGg_) => HGg.
    move => a /=.
    move /Hf => [b [Hb unib]].
    have : (a,b) ∈ graph (mkFunc Gf HGf_).
        apply /imageP; rewrite Hb; apply /set1P => //.
    move /HGf; case => _ /=.
    move /Hg => [c [Hc unic]].
    have : (b,c) ∈ graph (mkFunc Gg HGg_).
        apply /imageP; rewrite Hc; apply /set1P => //.
    move /HGg => /= [bB cC].
    exists c; split.
    +   apply extension; apply /subsetP => c'.
        +   move /imageP => /=.
            move /comp_setP => /= [b' [Hb' Hc']].
            have bb : b' = b.
                apply /set1P; rewrite -Hb; apply /imageP => //=.
            subst b'.
            have cc : c' = c.
                apply /set1P; rewrite -Hc. apply /imageP => //.
            subst c'.
            apply /set1P => //.
        +   move /set1P ->.
            apply /imageP => /=.
            apply /comp_setP; exists b => /=; split.
            -   suff : b ∈ image (mkFunc Gf HGf_) a.
                    apply /imageP => //.
                rewrite Hb; apply /set1P => //.
            -   suff : c ∈ image (mkFunc Gg HGg_) b.
                    apply /imageP => //.
                rewrite Hc; apply /set1P => //.
    +   move => c' H.
        have : c' ∈ image (compf (mkFunc Gg HGg_) (mkFunc Gf HGf_)) a.
            rewrite H; apply /set1P => //.
        move /imageP.
        move/ comp_setP => [b' [/imageP abF /imageP abG]].
        have bb : b' = b.
            apply /set1P; rewrite -Hb => //.
        subst b'.
        symmetry; apply /set1P; rewrite -Hc => //.
Qed.

Definition comp   {T1 T2 T3 : finType} {A : {set T1}} {B : {set T2}} {C : {set T3}}
    (g : B ⟶ C) (f : A ⟶ B) := mkMap (compf g f) (map_mixin_intro (compH g f)).

Notation "g ○ f" := (comp g f) (at level 30).

Lemma image_comp {T1 T2 T3 : finType} {A : {set T1}} {B : {set T2}} {C : {set T3}}
    (g : B ⟶ C) (f : A ⟶ B) :
    forall a, a ∈ A -> image (g ○ f) a = Image g (image f a).
Proof.
    move => a ha.
    apply extension; apply /subsetP => c.
    +   move /imageP /comp_setP => /= [b [Hab Hbc]].
        apply /ImageP. exists b; split; apply /imageP => //.
    +   move /ImageP => [b [Hab Hbc]].
        apply /imageP; apply /comp_setP; exists b; split; apply /imageP => //.
Qed.

Section comp.
Variable (T1 T2 T3 T4: finType).
Variable (A : {set T1}) (B : {set T2}) (C : {set T3}) (D : {set T4}).
Variable (f : A ⟶ B) (g : B ⟶ C) (i : C ⟶ D).

Theorem inj_comp :
    inj f -> inj g -> inj (g ○ f).
Proof.
    move => Hf Hg a a' Ha Ha' H.

    remember (g ○ f) as h.
    rewrite /comp /compf in Heqh.

    induction h as [Γh Hh_].
    move : (map_mixin_elim Hh_) => Hh.
    move : (Hh a Ha) => [c0 [ha unia]].
    move : (Hh a' Ha') => [c0' [ha' unia']].
    move : H => /=; rewrite ha ha' => cc'.
    have cc : c0' = c0.
        apply /set1P; rewrite cc'; apply /set1P => //.
    subst c0' => {cc'}.
    inversion Heqh => {Heqh}.

    have: c0 ∈ image Γh a.
        rewrite ha; apply /set1P => //.
    have : c0 ∈ image Γh a'.
        rewrite ha'; apply /set1P => //.
    rewrite H0.
    move /imageP /comp_setP => /= [b0' [fa' gb0']].
    move /imageP /comp_setP => /= [b0 [fa gb]].

    move : (Hf a a' Ha Ha').
    apply.
    induction f as [Γ axiom_]=> /=.
    move : (map_mixin_elim axiom_) => axiom.
    move : Ha'; move /axiom => [b' [fb' unib']].
    move : Ha;  move /axiom => [b [fb unib]].
    rewrite fb fb'.
    suff : b = b'.
        move -> => //.

    induction Γ as [G HG_].
    move : (func_mixin_elim HG_) => HG.
    have : (a,b) ∈ graph (mkFunc G HG_).
        apply /imageP; rewrite fb; apply /set1P => //.
    have : (a',b') ∈ graph (mkFunc G HG_).
        apply /imageP; rewrite fb'; apply /set1P => //.
    move /HG => /= [Ha' Hb'].
    move /HG => /= [Ha Hb].
    apply Hg => //.

    induction g as [Γ0 axiom0_].
    move : (map_mixin_elim axiom0_) => axiom0.
    move : Hb; move /axiom0  => [c [Hc unic]].
    move : Hb'; move /axiom0 => [c' [Hc' unic']].
    rewrite Hc Hc'.
    suff : c = c'.
        move -> => //.

    have : b0 ∈  image (mkFunc G HG_) a.
        apply /imageP => //.
    rewrite fb; move /set1P => bb; subst b0.
    inversion gb.
    move : gb; move /imageP; rewrite Hc; move /set1P <-.

    have : b0' ∈  image (mkFunc G HG_) a'.
        apply /imageP => //.
    rewrite fb'; move /set1P => bb; subst b0'.
    move : gb0'; move /imageP; rewrite Hc' ; move /set1P <-.

    done.
Qed.

Theorem surj_comp :
    surj f -> surj g -> surj (g ○ f).
Proof.
    rewrite /surj => Hf Hg.
    rewrite /comp /compf => /=.
    apply extension; apply /subsetP => c.
    +   move /rangeP; case => a /=.
        move /comp_setP => /= [b [Hab Hbc]].
        rewrite -Hg; apply /rangeP; exists b => //.
    +   move => Hc.
        apply /rangeP => /=.
        rewrite -Hg in Hc; move : Hc.
        move /rangeP => [b Hbc_].
        inversion Hbc_ as [Hbc]; move : Hbc_.
        induction g as [Γ axiom_].
        induction Γ as [G axiom0_] => /=.
        move : (func_mixin_elim axiom0_) => axiom0.
        move /axiom0 => /= [Hb _].
        rewrite -Hf in Hb; move : Hb.
        move /rangeP => [a Hab].
        exists a; apply /comp_setP; exists b => //.
Qed.

Theorem bij_comp :
    bij f -> bij g -> bij (g ○ f).
Proof.
    move => [Hfs Hfi] [Hgs Hgi]; split.
    +   apply surj_comp => //.
    +   apply inj_comp => //.
Qed.

Theorem comp_assoc :
    i ○ (g ○ f) = (i ○ g) ○ f.
Proof.
    apply map_extension.
    apply extension; apply /subsetP => //= u; induction u as [a d];
    move /comp_setP => /= [x [l r]]; apply /comp_setP.
    +   move /comp_setP : l =>  /= [b [Hf Hg]].
        exists b; split => //.
        apply /comp_setP; exists x; split => //.
    +   move /comp_setP : r => /= [c [Hg Hi]].
        exists c; split => //=.
        apply /comp_setP; exists x; split => //.
Qed.

End comp.

Section Id.

Context {T : finType} (A : {set T}).

Definition id_set := [set u in setX A A| u.1 == u.2 ].

Theorem id_setP u:
    reflect (u ∈ setX A A /\ u.1 = u.2) (u ∈ id_set).
Proof.
    move : u => [a b]; apply (iffP idP); rewrite in_set => /=.
    +   move /andP => [Ha /eqP ab] => //.
    +   move => [/andP [aA _] Hab]; subst b.
        rewrite in_set; apply /andP; split => //=.
        apply /setXP => //.
Qed.

Definition id_func_mixin :
    func_mixinp A A (id_set).
Proof.
    move => [a1 a2]; rewrite in_set; move /andP => /= [/setXP [H1 H2] _] => //.
Qed.

Definition id_func := mkFunc (id_set) (func_mixin_intro( id_func_mixin)).

Theorem id_map_mixin : map_mixinp A A id_func.
Proof.
    move => a Ha; exists a; rewrite image_graph => //=.
    split.
    +   apply extension; apply /subsetP => x; rewrite in_set.
        +   move /id_setP => /= [_ Hax]; subst x.
            apply /set1P => //.
        +   move /set1P ->; rewrite in_set; apply /andP; split => //.
            apply /setXP => //.
    +   move => a' H.
        apply /set1P; rewrite -H !in_set //=.
        apply /andP; split => //.
        apply /andP => //.
Qed.

Definition id := mkMap id_func (map_mixin_intro id_map_mixin).

End Id.

Section IdComp.
Context {T T' : finType} {A : {set T}} {B : {set T'}}.
Variable (f : A ⟶ B).

Theorem comp_idl :
    f ○ (id A) = f.
Proof.
    apply map_extension; apply extension; apply /subsetP => u /=; induction u as [a b].
    +   move /comp_setP => /= [x [/id_setP /= [_ ax] H]]; subst x => //.
    +   induction f as [Γ axiom_].
        induction Γ as [G axiom0_].
        move : (map_mixin_elim axiom_) => axiom.
        move : (func_mixin_elim axiom0_) => axiom0.
        move => /= H.
        move : (axiom0 _ H) => [aA _].
        apply /comp_setP => /=.
        exists a; split => //.
        apply /id_setP; split => //.
        apply /setXP => //.
Qed.

Theorem comp_idr :
    (id B) ○ f = f.
Proof.
    apply map_extension; apply extension; apply /subsetP => u /=; induction u as [a b].
    +   move /comp_setP => /=.
        move => [x [H /id_setP /= [_ xb]]].
        subst x => //.
    +   induction f as [Γ axiom_].
        induction Γ as [G axiom0_].
        move : (map_mixin_elim axiom_) => axiom.
        move : (func_mixin_elim axiom0_) => axiom0.
        move => H.
        move : (axiom0 _ H) => /= [_ bB].
        apply /comp_setP => /=.
        exists b; split => //.
        apply /id_setP; split => //.
        apply /setXP => //.
Qed.

End IdComp.

Section Inv.

Context {T T' : finType} {A : {set T}} {B : {set T'}} (f : A ⟶ B).
Hypotheses Hbi : bij f.

Theorem inv_map_mixin :
    map_mixinp B A (inv f).
Proof.
    move : Hbi => [surjf injf].
    move /bij_inv : Hbi => [H' Hf'] => //.
    apply /map_mixin_elim => //.
Qed.

Definition Inv  :=
    mkMap (inv f) (map_mixin_intro inv_map_mixin).

Theorem compKl :
    Inv ○ f = id A.
Proof.
    move : Hbi; rewrite /bij /inj /surj; move => [Hs Hi].
    move /bij_inv : Hbi => [axiom' [ Hs' Hi']].
    apply map_extension; apply extension; apply /subsetP => u /=; induction u as [a a'].
    +   induction f as [Γ axiom_].
        move : (map_mixin_elim axiom_) => axiom.
        move /comp_setP => /= [b [Hf /inv_setP /= Hf']].
        move : (in_graph _ _ Hf) => /= [Ha Hb].
        move : (in_graph _ _ Hf') => /= [Ha' _].
        move : (axiom _ Ha) => [b0 [ima unia]].
        move : (axiom _ Ha') => [b0' [ima' unia']].
        move /imageP : Hf; rewrite ima; move /set1P => bb; subst b0.
        move /imageP : Hf'; rewrite ima'; move /set1P => bb; subst b0'.
        suff : a = a'.
            move ->; apply /id_setP; split => //.
            apply /setXP => //.
        apply Hi => //=.
        rewrite ima ima' => //.
    +   move /id_setP => /= [/setXP [Ha _] aa]; subst a'.
        rewrite -Hs' in Ha.
        move /rangeP : Ha => /= [b /inv_setP /= Hab].
        apply /comp_setP => /=.
        exists b; split => //.
        apply /inv_setP => //.
Qed.

Theorem compkr :
    f ○ Inv = id B.
Proof.
    move : Hbi; rewrite /bij /inj /surj; move => [Hs Hi].
    move /bij_inv : Hbi => [axiom'_ [ Hs' Hi']].
    move : (map_mixin_elim axiom'_) => axiom'.
    apply map_extension; apply extension; apply /subsetP => u /=; induction u as [b b'].
    +   induction f as [Γ axiom_].
        move : (map_mixin_elim axiom_) => axiom.
        move /comp_setP => /= [a [/inv_setP /= Hf Hf']].
        move : (in_graph _ _ Hf) => /= [Ha Hb].
        move : (in_graph _ _ Hf') => /= [_ Hb'].
        move : (axiom' _ Hb) => /= [a0 [imb unib]].
        move : (axiom' _ Hb') => /= [a0' [imb' unib']].
        move /imageP : Hf; rewrite -in_inv imb; move /set1P => aa; subst a0.
        move /imageP : Hf' ; rewrite -in_inv imb'; move /set1P => aa; subst a0'.
        suff : b = b'.
            move ->; apply /id_setP; split => //.
            apply /setXP => //.
        apply Hi' => //=.
        rewrite imb imb' => //.
    +   move /id_setP => /= [/setXP [Hb _] bb]; subst b'.
        rewrite -Hs in Hb.
        move /rangeP : Hb => /= [a  Hab].
        apply /comp_setP => /=.
        exists a; split => //.
        apply /inv_setP => //.
Qed.

End Inv.

Section restrict.
Context {T T' : finType} {A A' : {set T}} {B : {set T'}} (f : A ⟶ B).
Hypotheses AA : A' ⊂ A.

Definition restrict_set (G : {set T * T'})  :=
    [set u in G  | u.1 ∈ A'].

Theorem restrict_func_axiom  (G : {set T * T'}) :
    G ⊂ setX A B -> func_mixinp A' B (restrict_set G).
Proof.
    move => GAB [a b].
    rewrite in_set.
    move /andP => /= [uG Ha].
    move /subsetP : GAB => H.
    move /H /setXP : uG => [_ Hb] => //.
Qed.

Definition restrict_func (G : {set T * T'})(H : G ⊂ setX A B) :=
    mkFunc (restrict_set G) (func_mixin_intro (restrict_func_axiom G H)).

Theorem graph_sub :
    graph f ⊂ setX A B.
Proof.
    apply /subsetP => u; induction u as [a b].
    move /in_graph => [Ha Hb].
    apply /setXP => //.
Qed.

Theorem restrict_map_axiom :
    map_mixinp A' B (restrict_func (graph f) graph_sub).
Proof.
    move : graph_sub.
    induction f as [Γ axiom_].
    move : (map_mixin_elim axiom_) => axiom graph_sub.
    move => a Ha'.
    have Ha : a ∈ A.
        move /subsetP : AA => HA.
        apply HA => //.
    move : (axiom a Ha) => [b [ima unia]].
    exists b => /=.
    split.
    +   apply extension; apply /subsetP => b'.
        +   move /imageP => /=.
            rewrite in_set.
            move /andP => /= [/imageP Hab _].
            rewrite -ima => //.
        +   move /set1P ->.
            apply /imageP => /=.
            rewrite in_set; apply /andP; split => //.
            apply /imageP.
            rewrite ima; apply /set1P => //.
    +   move => b' H.
        apply /set1P; rewrite -H; apply /imageP => /=.
        rewrite in_set => /=.
        apply /andP; split => //.
        suff : b ∈ image Γ a.
            move /imageP => //.
        rewrite ima; apply /set1P => //.
Qed.

Definition restrict :=
        mkMap (restrict_func (graph f) graph_sub) (map_mixin_intro restrict_map_axiom).

End restrict.