(* This file is an instantiation of RelationAlgebra's hrel but for
sets as "A -> Prop" instead of "A -> bool". It is also possible to use
"A -> { P : Prop | P \/ ~P }" but we sometimes need the excluded
middle if we want to be able to rewrite under negations, and also in
order to prove that every relation is linearisable.

(The same thing is/was in proprel_classic but with different names) *)

(** * Propositions as a bounded distributive lattice *)

From Coq Require Import Classical_Prop.
From RelationAlgebra Require Import lattice kat.
From RelationAlgebra Require Export prop.

(** Lattice operations *)

Canonical Structure Prop_lattice_ops: lattice.ops := {|
  leq := impl;
  weq := iff;
  cup := or;
  cap := and;
  neg := not;
  bot := False;
  top := True
|}.

Instance Prop_lattice_laws: lattice.laws (BL+STR+CNV+DIV) Prop_lattice_ops.
Proof.
  constructor; [ constructor | .. ].
  all: repeat intros []; compute in *; try tauto.
  pose proof classic. intro; tauto.
Qed.

(** * rel: the main model of heterogeneous binary relations *)

Set Printing Universes.

(** We fix a type universe U and show that heterogeneous relations
between types in this universe form a kleene algebra.  *)

Universe U.
Definition hrel (n m: Type@{U}) := n -> m -> Prop.
Definition relation A := hrel A A.

(** * Relations as a (bounded, distributive) lattice *)

(** lattice operations and laws are obtained for free, by two
   successive pointwise liftings of the [Prop] lattice *)

Canonical Structure hrel_lattice_ops n m :=
  lattice.mk_ops (hrel n m) leq weq cup cap neg bot top.

(* Having BL instead of BDL requires the excluded middle but allows
   us to rewrite under negations *)
Global Instance hrel_lattice_laws n m:
  lattice.laws (BL+STR+CNV+DIV) (hrel_lattice_ops n m).
Proof.
  constructor; try apply (pw_laws _).
  all: firstorder.
Qed.

(** * Relations as a residuated Kleene allegory *)

Section RepOps.
  Implicit Types n m p : Type@{U}.

(** relational composition *)
Definition hrel_dot n m p (x: hrel n m) (y: hrel m p): hrel n p :=
  fun i j => exists2 k, x i k & y k j.

(** converse (or transpose) *)
Definition hrel_cnv n m (x: hrel n m): hrel m n :=
  fun i j => x j i.

(** left / right divisions *)
Definition hrel_ldv n m p (x: hrel n m) (y: hrel n p): hrel m p :=
  fun i j => forall k, x k i -> y k j.

Definition hrel_rdv n m p (x: hrel m n) (y: hrel p n): hrel p m :=
  fun j i => forall k, x i k -> y j k.

Section i.
  Variable n: Type@{U}.
  Variable x: hrel n n.
  (** finite iterations of a relation *)
  Fixpoint iter u := match u with O => @eq _ | S u => hrel_dot _ _ _ x (iter u) end.
  (** Kleene star (reflexive transitive closure) *)
  Definition hrel_str: hrel n n := fun i j => exists u, iter u i j.
  (** strict iteration (transitive closure) *)
  Definition hrel_itr: hrel n n := hrel_dot n n n x hrel_str.
End i.

End RepOps.

(** packing all operations into a monoid; note that the unit on [n] is
   just the equality on [n], i.e., the identity relation on [n] *)

(** We need to eta-expand @eq here. This generates the universe
constraint [U <= Coq.Init.Logic.8] (where the latter is the universe of
the type argument to [eq]). Without the eta-expansion, the definition
would yield the constraint [U = Coq.Init.Logig.8], which is too strong
and leads to universe inconsistencies later on. *)

Canonical Structure hrel_monoid_ops :=
  monoid.mk_ops Type@{U} hrel_lattice_ops hrel_dot (fun n => @eq n)
                hrel_itr hrel_str hrel_cnv hrel_ldv hrel_rdv.

(** binary relations form a residuated Kleene allegory *)
Instance hrel_monoid_laws: monoid.laws (BL+STR+CNV+DIV) hrel_monoid_ops.
Proof.
  assert (dot_leq: forall n m p : Type@{U},
   Proper (leq ==> leq ==> leq) (hrel_dot n m p)).
   intros n m p x y H x' y' H' i k [j Hij Hjk]. exists j. apply H, Hij. apply H', Hjk.
  constructor; (try now left); intros.
   apply hrel_lattice_laws.
   intros i j. firstorder.
   intros i j. firstorder congruence.
   intros i j. firstorder.
   intros i j. reflexivity.
   intros x y E i j. apply E.
   intros i j E. exists O. exact E.
   intros i k [j Hij [u Hjk]]. exists (S u). firstorder.
   assert (E: forall i, (iter n x i: hrel n n) ⋅ z ≦ z).
    induction i. simpl. firstorder now subst.
    rewrite <-H0 at 2. transitivity (x⋅((iter n x i: hrel n n)⋅z)).
     simpl. firstorder congruence. now apply dot_leq.
    intros i j [? [? ?] ?]. eapply E. repeat eexists; eauto.
   reflexivity.
   intros i k [[j Hij Hjk] Hik]. exists j; trivial. split; firstorder.
   split. intros E i j [k Hik Hkj]. apply E in Hkj. now apply Hkj.
    intros E i j Hij k Hki. apply E. firstorder.
   split. intros E i j [k Hik Hkj]. apply E in Hik. now apply Hik.
    intros E i j Hij k Hki. apply E. firstorder.
Qed.

(** * Relations as a Kleene algebra with Prop tests *)

Definition set : ob hrel_monoid_ops -> lattice.ops := fun Y => pw_ops Prop_lattice_ops Y.

(** injection of Prop predicates into relations, as sub-identities *)
Definition hrel_inj n (x: set n): hrel n n := fun i j => i=j /\ x i.

(** packing relations and Prop sets as a Kleene algebra with tests *)

Canonical Structure hrel_kat_ops :=
  kat.mk_ops hrel_monoid_ops set hrel_inj.

Lemma iter_S {n} {x : hrel_kat_ops n n} {i} :
  forall a c,
    iter n x (S i) a c -> exists b, iter n x i a b /\ x b c.
Proof.
  induction i; intros a c it.
  - exists a. compute. destruct it as [x0 H <-]; auto.
  - destruct it as [d ad dc]. apply IHi in dc. firstorder.
Qed.

Constraint U < pw.
Instance hrel_set_kat_laws: kat.laws hrel_kat_ops.
Proof.
  constructor.
  - constructor.
    1: now apply lower_laws.
    all: try solve [compute; firstorder].
    + intros n m x a b. split. intros [c <- H]; auto. intros H. exists a; firstorder; reflexivity.
    + right. intros n m x a b. split. intros [c H <-]; auto. intros H. exists b; firstorder; reflexivity.
    + intros _ n x a a_ <-. exists O. reflexivity.
    + intros _ n x a c [b ab [i bc]]. exists (S i), b; auto.
    + intros H n m x z e a c [b [i ab] bc]. revert a ab. induction i; intros a ab.
      * rewrite ab; auto.
      * apply e. destruct ab as [a' aa' a'b]. exists a'; eauto.
    + intros _; right; right.
      intros n m x z e a c [b ab [i bc]].
      revert a b c ab bc. induction i; intros a b c ab bc.
      * rewrite <-bc; auto.
      * apply e. destruct (iter_S _ _ bc) as (b' & bb' & b'c). exists b'; eauto.
  - intros A; constructor; try firstorder.
    intros _ x a; split; compute; auto. pose proof classic. tauto.
  - intros A. constructor; repeat intro; compute in *; discriminate || firstorder.
  - intros A. constructor; repeat intro; compute in *; discriminate || firstorder.
  - intros A x y a b; split.
    + intros [<- ?]; exists a; firstorder.
    + intros [c [<- ?] [<- ?]]. firstorder.
Qed.

(*
(** * Functional relations  *)

Definition drop_frel {A B: Set} (f: A -> B): hrel A B := fun x y => y = f x.

Lemma frel_comp {A B C: Set} (f: A -> B) (g: B -> C): drop_frel f ⋅ drop_frel g ≡ drop_frel (fun x => g (f x)).
Proof.
  apply antisym. intros x z [y -> ->]. reflexivity.
  simpl. intros x z ->. eexists; reflexivity.
Qed.

Instance drop_frel_weq {A B}: Proper (pwr eq ==> weq) (@drop_frel A B).
Proof. unfold drop_frel; split; intros ->; simpl. apply H. apply eq_sym, H. Qed.
*)


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf1 : natural) (z : natural) (x : natural)
  : natural := plus (mult z y) z.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*      Coq V5.8                                                            *)
(*                                                                          *)
(*                                                                          *)
(*      First-order Unification                                             *)
(*                                                                          *)
(*      Joseph Rouyer                                                       *)
(*                                                                          *)
(*      November 1992                                                       *)
(*                                                                          *)
(****************************************************************************)
(*                         nat_term_eq_quasiterm.v                          *)
(****************************************************************************)

Require Import Arith.
Require Import nat_complements.

(*---------------------------------------------*)
(*------------ Verifications on the terms:begin -------------*)
(*---------------------------------------------*)

Section nat_sequence.

Inductive list_nat : Set :=
  | nil_nat : list_nat
  | cons_nat : nat -> list_nat -> list_nat.

Fixpoint At_last (x : nat) (l : list_nat) {struct l} : list_nat :=
  match l return list_nat with
  | nil_nat =>
      (* nil_nat *) cons_nat x nil_nat
      (* cons_nat c ll *)
  | cons_nat c ll => cons_nat c (At_last x ll)
  end.

Fixpoint List_queue_nat (l : list_nat) : list_nat :=
  match l return list_nat with
  | nil_nat =>
      (* nil_nat *) nil_nat
      (* cons_nat c ll *)
  | cons_nat c tail => At_last c (List_queue_nat tail)
  end.

Fixpoint Constr_f (l : list_nat) : nat -> nat :=
  fun n : nat =>
  match l return nat with
  | nil_nat =>
      (* nil_nat *) 0
  | cons_nat m tail =>
      match n return nat with
      | O =>
          (* O *)  m
          (* (S p) *)
      | S p => Constr_f tail p
      end
  end.

(***********************************************************************)
(********************** Properties of  Constr_f ***************************)
(***********************************************************************)

Inductive OK_Constr_f (f : list_nat -> nat -> nat) : Prop :=
    OK_Constr_f_init :
      (forall x : nat, 0 = f nil_nat x :>nat) ->
      (forall (val : nat) (l : list_nat), val = f (cons_nat val l) 0 :>nat) ->
      (forall (x val : nat) (l : list_nat),
       f l x = f (cons_nat val l) (S x) :>nat) -> OK_Constr_f f.

Lemma Constr_f_OK : OK_Constr_f Constr_f.
apply OK_Constr_f_init; simpl in |- *; auto; simple induction x;
 simpl in |- *; auto.
Qed.

Inductive OK_At_last (f : nat -> list_nat -> list_nat) : Prop :=
    OK_At_last_init :
      (forall x : nat, cons_nat x nil_nat = f x nil_nat :>list_nat) ->
      (forall x y : nat,
       cons_nat y (cons_nat x nil_nat) = f x (f y nil_nat) :>list_nat) ->
      OK_At_last f.

Lemma At_last_OK : OK_At_last At_last.
apply OK_At_last_init; simpl in |- *; auto.
Qed.

Inductive OK_List_queue_nat (f : list_nat -> list_nat) : Prop :=
    OK_List_queue_nat_init :
      nil_nat = f nil_nat :>list_nat ->
      (forall (x : nat) (l : list_nat),
       At_last x (f l) = f (cons_nat x l) :>list_nat) ->
      OK_List_queue_nat f.

Lemma List_queue_nat_OK : OK_List_queue_nat List_queue_nat.
apply OK_List_queue_nat_init; simpl in |- *; auto.
Qed.

End nat_sequence.

(**********************************************************************)
(******************* Specifications of terms ******************************)
(**********************************************************************)

Section terms.

Definition fun_ : Set := nat.

Definition var : Set := nat.

Lemma var_eq_decP : forall x x0 : var, x = x0 :>var \/ x <> x0.
intros; elim (nat_eq_decP x x0); auto.
Qed.

Lemma var_eq_decS : forall x x0 : var, {x = x0 :>var} + {x <> x0}.
intros; elim (nat_eq_decS x x0); auto.
Qed.

Lemma fun_eq_decP : forall x x0 : fun_, x = x0 :>fun_ \/ x <> x0.
intros; elim (nat_eq_decP x x0); auto.
Qed.

Lemma fun_eq_decS : forall x x0 : fun_, {x = x0 :>fun_} + {x <> x0}.
intros; elim (nat_eq_decS x x0); auto.
Qed.

Inductive quasiterm : Set :=
  | V : var -> quasiterm (*variable quasiterm*)
  | C : fun_ -> quasiterm (*constant quasiterm*)
  | Root : fun_ -> quasiterm -> quasiterm (*rooting*)
  | ConsArg : quasiterm -> quasiterm -> quasiterm.
                                 (*building the pairs of quasiterms*)

(**********************************************************************)
(*********************** The arity function *****************************)
(**********************************************************************)

Hypothesis list_arity : list_nat.

Definition arity : fun_ -> nat := Constr_f (List_queue_nat list_arity).

(**********************************************************************)
(********************** Length of a quasiterm ***************************)
(**********************************************************************)

Fixpoint Length (t : quasiterm) : nat :=
  match t return nat with
  | V x => 1
  | C f => 1
  | Root f u => 1
  | ConsArg t1 t2 =>
      Length t1 + Length t2
      (*(<nat>Match (Length t1) with (Length t2) [x:nat]S end)*)
  end.

(***********************************************************************)
(********************** Predicate SIMPLE *******************************)
(****** Simple term is constant term or variable term or rooted term. *******)
(***********************************************************************)

Definition SIMPLE (t : quasiterm) : Prop :=
  match t return Prop with
  | V x => True
  | C l => True
  | Root l u => True
  | ConsArg t1 t2 => False
  end.

(***********************************************************************)
(***************** Predicates l_term and L_TERM : ***********************)
(***********************************************************************)

Inductive l_term : quasiterm -> Prop :=
  | l_term_initV : forall x : var, l_term (V x)
  | l_term_initC : forall f : fun_, 0 = arity f :>nat -> l_term (C f)
  | l_term_Root :
      forall (f : fun_) (t : quasiterm),
      l_term t -> arity f = Length t :>nat -> l_term (Root f t)
  | l_term_ConsArg :
      forall t1 t2 : quasiterm,
      l_term t1 -> l_term t2 -> SIMPLE t1 -> l_term (ConsArg t1 t2).

Fixpoint L_TERM (t : quasiterm) : Prop :=
  match t return Prop with
  | V x => True
  | C c => 0 = arity c
  | Root l t => L_TERM t /\ arity l = Length t
  | ConsArg t1 t2 => SIMPLE t1 /\ L_TERM t1 /\ L_TERM t2
  end.

(***********************************************************************)
(******************** L_TERM is equivalent to l_term : *******************)
(***********************************************************************)

Lemma L_TERM_l_term : forall t : quasiterm, L_TERM t -> l_term t.
intro; elim t; simpl in |- *; intros.
apply l_term_initV; auto.
apply l_term_initC; auto.
apply l_term_Root.
apply H; elim H0; auto.
elim H0; auto.
apply l_term_ConsArg.
apply H; elim H1; intros H2 H3; elim H3; intros; auto.
apply H0; elim H1; intros H2 H3; elim H3; intros; auto.
elim H1; auto.
Qed.

Lemma l_term_L_TERM : forall t : quasiterm, l_term t -> L_TERM t.
intros; elim H; simpl in |- *; auto.
Qed.

(***********************************************************************)
(******************** Predicate term : ***********************************)
(***********************************************************************)

Inductive term (t : quasiterm) : Prop :=
    term_init : L_TERM t -> SIMPLE t -> term t.

(***********************************************************************)
(************ Decidability of L_TERM and decidability of term : ************)
(***********************************************************************)

Lemma SIMPLE_decS : forall t : quasiterm, {SIMPLE t} + {~ SIMPLE t}.
intros; elim t; simpl in |- *; auto.
Qed.

Lemma L_TERM_decS : forall t : quasiterm, {L_TERM t} + {~ L_TERM t}.
simple induction t; simpl in |- *; auto.
intros f; elim (nat_eq_decS 0 (arity f)); intros; simpl in |- *; auto.
intros f y h0; elim (nat_eq_decS (arity f) (Length y)); intros h.
elim h; elim h0; intros; auto.
right; tauto.

right; tauto.

intros y h y0 h0; elim h; intros.
elim h0; intros.
elim (SIMPLE_decS y); intros h1.
auto.
right; tauto.
right; tauto.
right; tauto.
Qed.

Lemma term_decS : forall t : quasiterm, {term t} + {~ term t}.
intro; elim (L_TERM_decS t); intros h1; elim (SIMPLE_decS t); intros h2.
left; apply term_init; auto.
right; unfold not in |- *; intros h3; elim h2; elim h3; intros; auto.
right; unfold not in |- *; intros h3; elim h1; elim h3; intros; auto.
right; unfold not in |- *; intros h3; elim h1; elim h3; intros; auto.
Qed.

(***********************************************************************)
(******************* Properties of  Length *******************************)
(***********************************************************************)

Lemma Length_n_O : forall t : quasiterm, {x : nat | Length t = S x}.
simple induction t.
exists 0; simpl in |- *; auto.
exists 0; simpl in |- *; auto.
exists 0; simpl in |- *; auto.
intros qx Hqx qy Hqy.
elim Hqy; elim Hqx; intros x Eqx y Eqy.
exists (x + Length qy).
simpl in |- *.
rewrite Eqx; auto.
Qed.

Lemma n_SO_Length_ConsArg :
 forall t t0 : quasiterm, 1 <> Length (ConsArg t t0).
intros; elim (Length_n_O t); elim (Length_n_O t0); intros; simpl in |- *.
replace (Length t) with (S x0); replace (Length t0) with (S x).
elim x0; simpl in |- *.
discriminate.
intros; discriminate.
Qed.

Lemma SIMPLE_SO : forall t : quasiterm, SIMPLE t -> 1 = Length t :>nat.
simple induction t; simpl in |- *; intros; auto.
absurd False; auto.
Qed.

Lemma Length_SO_term :
 forall t : quasiterm, L_TERM t -> 1 = Length t :>nat -> term t.
simple induction t; intros; apply term_init; simpl in |- *; auto.
apply (n_SO_Length_ConsArg q q0); auto.
Qed.

Lemma term_L_TERM_Length :
 forall t : quasiterm, term t -> L_TERM t /\ 1 = Length t :>nat.
simple induction t.
intros; simpl in |- *; auto.
intros; simpl in |- *.
split; auto.
elim H; simpl in |- *; intros h; elim h; auto.
simpl in |- *; intros.
split; auto.
elim H0; simpl in |- *; intros h; elim h; intros; split; auto.
simpl in |- *; intros.
split.
elim H1; simpl in |- *; intros; auto.
elim H1; simpl in |- *; intros.
absurd False; auto.
Qed.

End terms.

Section eq_quasiterm.

(***********************************************************************)
(************************ Structural predicates ***************************)
(***********************************************************************)

Definition BC (t : quasiterm) : Prop :=
  match t return Prop with
  | V _ => False
  | C _ => True
  | Root _ _ => False
  | ConsArg _ t2 => False
  end.

Definition BV (t : quasiterm) : Prop :=
  match t return Prop with
  | V _ => True
  | C _ => False
  | Root _ _ => False
  | ConsArg _ t2 => False
  end.

Definition BRoot (t : quasiterm) : Prop :=
  match t return Prop with
  | V _ => False
  | C _ => False
  | Root _ _ => True
  | ConsArg _ t2 => False
  end.

Definition BConsArg (t : quasiterm) : Prop :=
  match t return Prop with
  | V _ => False
  | C _ => False
  | Root _ _ => False
  | ConsArg _ t2 => True
  end.

(***********************************************************************)
(********************** Destroyers (Destructors): *************************)
(***********************************************************************)
Definition Destr1 (t : quasiterm) :=
  match t return quasiterm with
  | V x => V x
  | C x => C x
  | Root _ p => p
  | ConsArg p _ => p
  end.

Definition Destr2 (t : quasiterm) :=
  match t return quasiterm with
  | V x => V x
  | C x => C x
  | Root _ p => p
  | ConsArg _ q => q
  end.

Definition Destrvar (X : var) (t : quasiterm) :=
  match t return var with
  | V x => x
  | C _ => X
  | Root _ _ => X
  | ConsArg _ _ => X
  end.

Definition Destrfun (F : fun_) (t : quasiterm) :=
  match t return fun_ with
  | V _ => F
  | C l => l
  | Root l _ => l
  | ConsArg p q => F
  end.

(**********************************************************************)
(******************** Equal in the Set of quasiterms : *******************)
(**********************************************************************)

Lemma proj_C : forall l1 l2 : fun_, C l1 = C l2 :>quasiterm -> l1 = l2 :>fun_.
intros; replace l1 with (Destrfun l1 (C l1)); auto.
replace l2 with (Destrfun l1 (C l2)); auto.
elim H; auto.
Qed.

Lemma proj_V : forall x1 x2 : var, V x1 = V x2 :>quasiterm -> x1 = x2 :>var.
intros; replace x1 with (Destrvar x1 (V x1)); auto.
replace x2 with (Destrvar x1 (V x2)); auto.
elim H; auto.
Qed.

Lemma proj_Root1 :
 forall (t1 t2 : quasiterm) (l1 l2 : fun_),
 Root l1 t1 = Root l2 t2 :>quasiterm -> l1 = l2 :>fun_.
intros; replace l1 with (Destrfun l1 (Root l1 t1)); auto.
replace l2 with (Destrfun l1 (Root l2 t2)); auto.
elim H; auto.
Qed.

Lemma proj_Root2 :
 forall (t1 t2 : quasiterm) (l1 l2 : fun_),
 Root l1 t1 = Root l2 t2 :>quasiterm -> t1 = t2 :>quasiterm.
intros; replace t1 with (Destr1 (Root l1 t1)); auto.
replace t2 with (Destr2 (Root l2 t2)); auto.
elim H; auto.
Qed.

Lemma proj_ConsArg1 :
 forall t1 t2 t3 t4 : quasiterm,
 ConsArg t1 t2 = ConsArg t3 t4 :>quasiterm -> t1 = t3 :>quasiterm.
intros; replace t1 with (Destr1 (ConsArg t1 t2)); auto.
replace t3 with (Destr1 (ConsArg t3 t4)); auto.
elim H; auto.
Qed.

Lemma proj_ConsArg2 :
 forall t1 t2 t3 t4 : quasiterm,
 ConsArg t1 t2 = ConsArg t3 t4 :>quasiterm -> t2 = t4 :>quasiterm.
intros; replace t2 with (Destr2 (ConsArg t1 t2)); auto.
replace t4 with (Destr2 (ConsArg t3 t4)); auto.
elim H; auto.
Qed.

(**********************************************************************)
(****************** Not equal in the Set of the quasiterms : **************)
(**********************************************************************)
Lemma C_diff_C : forall l l0 : fun_, l <> l0 -> C l <> C l0 :>quasiterm.
unfold not in |- *; intros; elim H; apply proj_C; auto.
Qed.

Lemma V_diff_V : forall x y : var, x <> y :>var -> V x <> V y :>quasiterm.
unfold not in |- *; intros; elim H; apply proj_V; auto.
Qed.

Lemma ConsArg_diff_ConsArg :
 forall t t0 t1 t2 : quasiterm,
 t <> t1 :>quasiterm \/ t0 <> t2 :>quasiterm ->
 ConsArg t t0 <> ConsArg t1 t2 :>quasiterm.
unfold not in |- *; intros; elim H; intros; elim H1.
apply proj_ConsArg1 with t0 t2; auto.
apply proj_ConsArg2 with t t1; auto.
Qed.

Lemma Root_diff_Root :
 forall (l l0 : fun_) (t t0 : quasiterm),
 l <> l0 :>fun_ \/ t <> t0 :>quasiterm -> Root l t <> Root l0 t0 :>quasiterm.
unfold not in |- *; intros; elim H; intros; elim H1.
apply proj_Root1 with t t0; auto.
apply proj_Root2 with l l0; auto.
Qed.

(**********************************************************************)
(*********** Decidability of the equality in the Set of quasiterms : *********)
(**********************************************************************)
Lemma quasiterm_eq_decS :
 forall t t0 : quasiterm, {t = t0 :>quasiterm} + {t <> t0 :>quasiterm}.
simple induction t.
simple induction t0.
(*t=(V ...)*)
intros; elim (var_eq_decS v v0); intros H.
elim H; auto.
right; apply V_diff_V; auto.
intros; right; apply (Diff quasiterm BV); simpl in |- *; auto.
intros; right; apply (Diff quasiterm BV); simpl in |- *; auto.
intros; right; apply (Diff quasiterm BV); simpl in |- *; auto.
(*t=(C ...)*)
simple induction t0.
intros; right; apply (Diff quasiterm BC); simpl in |- *; auto.
intros; elim (fun_eq_decS f f0); intros H.
elim H; auto.
right; apply C_diff_C; auto.
intros; right; apply (Diff quasiterm BC); simpl in |- *; auto.
intros; right; apply (Diff quasiterm BC); simpl in |- *; auto.
(*t=(Root...)*)
simple induction t0.
intros; right; apply (Diff quasiterm BRoot); simpl in |- *; auto.
intros; right; apply (Diff quasiterm BRoot); simpl in |- *; auto.
intros.
elim (H q0); intros y.
rewrite y; elim (fun_eq_decS f f0); intros y0.
rewrite y0; auto.
right; simplify_eq; auto.
right; simplify_eq; auto.
intros; right; simplify_eq.
(*t=(ConsArg ...)*)
simple induction t0.
intros; right; simplify_eq.
intros; right; simplify_eq.
intros; right; simplify_eq.
intros y1 H1 y2 H2.
elim (H y1); intros E1.
elim (H0 y2); intros E2.
rewrite E1; rewrite E2; auto.
right; simplify_eq; tauto.
right; simplify_eq; tauto.
Qed.

Lemma quasiterm_eq_decP :
 forall t t0 : quasiterm, t = t0 :>quasiterm \/ t <> t0.
intros; elim (quasiterm_eq_decS t t0); intros; auto.
Qed.

(**********************************************************************)
(********************* End of equality in quasiterm **********************)
(**********************************************************************)

(***********************************************************************)
(************************* End eq_quasiterm. ***************************)
(***********************************************************************)
End eq_quasiterm.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** Extraction of breadth-first numbering algorithm from Coq to Ocaml

       see http://okasaki.blogspot.com/2008/07/breadth-first-numbering-algorithm-in.html
       and https://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/jfp95queue.pdf
       and https://www.cs.cmu.edu/~rwh/theses/okasaki.pdf
       and https://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/icfp00bfn.pdf

*)

Require Import List Arith Omega Wellfounded.
Require Import list_utils wf_utils bt bft fifo.

Set Implicit Arguments.

Local Definition fifo_sum { X } { f : fifo (bt X) } (q : f) : nat := lsum (fifo_list q).

Section bfn.

  Variable (X : Type) (fX : fifo (bt X)) (fN : fifo (bt nat)).

  (* the forest (list of bt nat) is a breadth first numbering from n if
     its breadth first traversal yields [n;n+1;....;m[ for some m
   *)

  Definition is_bfn_from n l: Prop := is_seq_from n (bft_f l).

  (* Breadth First Numbering: maps a forest X to a forest nat such that
          1) the two forests are of the same shape
          2) the result is a breadth first numbering from n
     For this, the resulting forest is interpreted as a snoc list (in the spec., it is reversed as a list).
   *)

  Definition bfn_f_gen n (p : fX) : { q : fN | fifo_list p ~lt rev (fifo_list q) /\ is_bfn_from n (rev (fifo_list q)) }.
  Proof.
    induction on n p as bfn_f_gen with measure (fifo_sum p).
    refine (match fifo_void p as b return fifo_void p = b -> _ with
      | true  => fun H1 => exist _ fifo_nil _
      | false => fun H1 => _
    end eq_refl).
    { apply fifo_void_spec in H1.
      rewrite H1, fifo_nil_spec; split; simpl; auto.
      red; rewrite bft_f_fix_0; simpl; auto. }
    assert (fifo_list p <> nil) as H2.
    { red; intros H; apply fifo_void_spec in H; rewrite H in H1; discriminate. }
    refine (match fifo_deq p H2 as k return fifo_deq p H2 = k -> _ with
      | (leaf x ,p') => _
      | (node a x b, p') => _
    end eq_refl); intros H3.
    + generalize (fifo_deq_spec _ p H2); rewrite H3; intros H4.
      refine (let (q,Hq) := bfn_f_gen (S n) p' _ in exist _ (fifo_enq q (leaf n)) _).
      { unfold fifo_sum; rewrite H4; simpl; omega. }
      destruct Hq as (H5 & H6).
      rewrite H4, fifo_enq_spec.
      subst; split; auto.
      rewrite rev_app_distr; simpl; auto.
      rewrite rev_app_distr; simpl; red.
      rewrite bft_f_fix_3; simpl; rewrite <- app_nil_end; auto.
    + generalize (fifo_deq_spec _ p H2); rewrite H3; intros H4.
      refine (let (q,Hq) := bfn_f_gen (S n) (fifo_enq (fifo_enq p' a) b) _ in _).
      { unfold fifo_sum.
        rewrite fifo_enq_spec, fifo_enq_spec, app_ass; simpl.
        rewrite lsum_app, H4; simpl; omega. }
      destruct Hq as (H5 & H6).
      rewrite fifo_enq_spec, fifo_enq_spec, app_ass in H5; simpl in H5.
      assert (2 <= length (fifo_list q)) as H7.
      { apply Forall2_length in H5.
        rewrite app_length, rev_length in H5.
        simpl in H5; omega. }
      assert (fifo_list q <> nil) as H8.
      { revert H7; destruct (fifo_list q); simpl; try discriminate; intro; omega. }
      generalize (fifo_deq_spec _ _ H8).
      refine (match fifo_deq _ H8 with (u,q') => _ end); intros H9.
      assert (fifo_list q' <> nil) as H10.
      { revert H7; rewrite H9; destruct (fifo_list q'); simpl; try discriminate; intro; omega. }
      generalize (fifo_deq_spec _ _ H10).
      refine (match fifo_deq _ H10 with (v,q'') => _ end); intros H11.
      exists (fifo_enq q'' (node v n u)).
      rewrite H4, fifo_enq_spec, rev_app_distr; simpl.
      rewrite H9, H11 in H5; simpl in H5; rewrite app_ass in H5; simpl in H5.
      rewrite H9, H11 in H6; simpl in H6; rewrite app_ass in H6; simpl in H6.
      unfold is_bfn_from in H6 |- *.
      apply Forall2_2snoc_inv in H5.
      destruct H5 as (G1 & G2 & H5).
      rewrite bft_f_fix_3; simpl; split; auto.
  Defined.

  Section bfn.

    Let bfn_full (t : bt X) : { t' | t ~t t' /\ is_seq_from 0 (bft_std t') }.
    Proof.
      refine (match @bfn_f_gen 0 (fifo_enq fifo_nil t) with exist _ q Hq => _ end).
      rewrite fifo_enq_spec, fifo_nil_spec in Hq; simpl in Hq.
      destruct Hq as (H1 & H2).
      assert (fifo_list q <> nil) as H3.
      { apply Forall2_length in H1; rewrite rev_length in H1.
        destruct (fifo_list q); discriminate. }
      generalize (fifo_deq_spec _ _ H3).
      refine (match fifo_deq _ H3 with (x,q') => _ end); intros H4.
      exists x.
      rewrite <- bft_std_eq_bft.
      rewrite H4 in H1; simpl in H1.
      apply Forall2_snoc_inv with (l := nil) in H1.
      destruct H1 as (G1 & H1).
      apply Forall2_nil_inv_right in H1.
      apply f_equal with (f := @rev _) in H1.
      rewrite rev_involutive in H1; simpl in H1.
      rewrite H4, H1 in H2; simpl in H2.
      auto.
    Defined.

    Definition bfn_gen t := proj1_sig (bfn_full t).

    Fact bfn_gen_spec_1 t : t ~t bfn_gen t.
    Proof. apply (proj2_sig (bfn_full t)). Qed.

    Fact bfn_gen_spec_2 t : exists n, bft_std (bfn_gen t) = seq_an 0 n.
    Proof. apply is_seq_from_spec, (proj2_sig (bfn_full t)). Qed.

  End bfn.

End bfn.

Require Import Extraction.

Definition bfn X := bfn_gen (fifo_two_lists (bt X)) (fifo_two_lists (bt nat)).

Extraction Inline bfn_gen fifo_trivial.
Recursive Extraction bfn.

Check bfn.
Check bfn_gen_spec_1.
Check bfn_gen_spec_2.


(* Exercise 19a *)

Require Import BenB.

Variables A B C D : Prop.

(* Doubly negated double negation *)

Theorem exercise_019a : ~~(~~A -> A).
Proof.
dis_e (A \/ ~A) G H.
LEM.
neg_i (~~A -> A) first.
hyp first.
imp_i second.
hyp G.
neg_i (~~A -> A) first.
hyp first.
imp_i second.
neg_e (~A).
hyp second.
hyp H.
Qed.


Require Import Coq.Relations.Relations.
From Coq.Classes Require Import RelationClasses Morphisms.
From algebra Require Import Semigroups Monoids Groups AbelianGroups.

Section Rings.
Context {Carrier: Type}.
Context (equiv: relation Carrier).
Context {equiv_equiv: Equivalence equiv}.
Context (add: Carrier -> Carrier -> Carrier).
Context {add_proper: Proper (equiv ==> equiv ==> equiv) add}.
Context (zero: Carrier).
Context (minus: Carrier -> Carrier).
Context {minus_proper: Proper (equiv ==> equiv) minus}.
Context (mul: Carrier -> Carrier -> Carrier).
Context {mul_proper: Proper (equiv ==> equiv ==> equiv) mul}.
Context (one: Carrier).

Infix "==" := equiv (at level 60, no associativity).
Infix "<+>" := add (at level 50, left associativity).
Infix "<*>" := mul (at level 40, left associativity).

Class Ring := {
  ring_add_abelian :> AbelianGroup equiv add zero minus;
  ring_mul_monoid :> Monoid equiv mul one;
  ring_distrib_l:
    forall (a b c: Carrier),
      a <*> (b <+> c) == a <*> b <+> a <*> c;
  ring_distrib_r:
    forall (a b c: Carrier),
      (b <+> c) <*> a == b <*> a <+> c <*> a;
}.

Context {ring: Ring}.

Theorem ring_mul_0_l (a: Carrier):
  zero <*> a == zero.
Proof.
  apply (group_idemp_ident equiv add zero minus).
  setoid_rewrite <- ring_distrib_r.
  setoid_rewrite (monoid_ident_r equiv add zero).
  reflexivity.
Qed.

Theorem ring_mul_0_r (a: Carrier):
  a <*> zero == zero.
Proof.
  apply (group_idemp_ident equiv add zero minus).
  setoid_rewrite <- ring_distrib_l.
  setoid_rewrite (monoid_ident_r equiv add zero).
  reflexivity.
Qed.

Theorem ring_mul_minus_l (a b: Carrier):
  (minus a) <*> b == minus (a <*> b).
Proof.
  apply (group_inv_r_unique equiv add zero minus).
  setoid_rewrite <- ring_distrib_r.
  setoid_rewrite (group_inv_r equiv add zero minus).
  apply ring_mul_0_l.
Qed.

Theorem ring_mul_minus_r (a b: Carrier):
  a <*> (minus b) == minus (a <*> b).
Proof.
  apply (group_inv_r_unique equiv add zero minus).
  setoid_rewrite <- ring_distrib_l.
  setoid_rewrite (group_inv_r equiv add zero minus).
  apply ring_mul_0_r.
Qed.

Theorem ring_mul_minus_minus (a b: Carrier):
  (minus a) <*> (minus b) == a <*> b.
Proof.
  setoid_rewrite ring_mul_minus_l.
  setoid_rewrite ring_mul_minus_r.
  apply (group_inv_involute equiv add zero minus).
Qed.

Definition is_unit (u: Carrier) :=
  exists (uInv: Carrier), u <*> uInv == one.

Theorem ring_units_closed_mul (u0 u1: Carrier):
  is_unit u0 ->
  is_unit u1 ->
  is_unit (u0 <*> u1).
Proof.
  unfold is_unit.
  intros [u0Inv Hu0] [u1Inv Hu1].
  exists (u1Inv <*> u0Inv).
  setoid_rewrite <- (semigroup_assoc equiv mul).
  transitivity (u0 <*> (u1 <*> u1Inv) <*> u0Inv).
  { apply (semigroup_op_r equiv mul).
    apply (semigroup_assoc equiv mul). }
  setoid_rewrite Hu1.
  setoid_rewrite (monoid_ident_r equiv mul one).
  assumption.
Qed.

Theorem ring_nonunits_absorb_mul (r: Carrier):
  ~ is_unit r ->
  forall (s: Carrier), ~ is_unit (r <*> s).
Proof.
  unfold is_unit.
  intros Hnonunit s [rsInv Hcontra].
  apply Hnonunit.
  exists (s <*> rsInv).
  setoid_rewrite <- (semigroup_assoc equiv mul).
  apply Hcontra.
Qed.
End Rings.


Require Export euclidean__axioms.
Definition lemma__3__6a : forall A B C D, (euclidean__axioms.BetS A B C) -> ((euclidean__axioms.BetS A C D) -> (euclidean__axioms.BetS B C D)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
intro H0.
assert (* Cut *) (euclidean__axioms.BetS C B A) as H1.
- apply (@euclidean__axioms.axiom__betweennesssymmetry A B C H).
- assert (* Cut *) (euclidean__axioms.BetS D C A) as H2.
-- apply (@euclidean__axioms.axiom__betweennesssymmetry A C D H0).
-- assert (* Cut *) (euclidean__axioms.BetS D C B) as H3.
--- apply (@euclidean__axioms.axiom__innertransitivity D C B A H2 H1).
--- assert (* Cut *) (euclidean__axioms.BetS B C D) as H4.
---- apply (@euclidean__axioms.axiom__betweennesssymmetry D C B H3).
---- exact H4.
Qed.


(* Exercise 82 *)

Require Import BenB.

Variables A B C D : Prop.

(* Destructive dilemma *)

Theorem exercise_082 : (A -> B) /\ (C -> D) -> (~B \/ ~D) -> (~A \/ ~C).
Proof.
imp_i a1.
imp_i a2.
dis_e (~B \/ ~D) a3 a3.
hyp a2.
dis_i1.
neg_i B a4.
hyp a3.
imp_e A.
con_e1 (C -> D).
hyp a1.
hyp a4.
dis_i2.
neg_i (D) a4.
hyp a3.
imp_e C.
con_e2 (A -> B).
hyp a1.
hyp a4.
Qed.


Require Import Psatz ZArith Znumtheory Btauto.
Require Import QuantumLib.Prelim QuantumLib.VectorStates.
Require Import Examples.Utilities.

(* ============================= *)
(* =   Number theory results   = *)
(* ============================= *)

Local Open Scope Z_scope.
Local Coercion Z.of_nat : nat >-> BinNums.Z.
Tactic Notation "flia" hyp_list(Hs) := clear - Hs; intros; nia.

(*
   exteuc a b = (n, m) :
   a * n + b * m = gcd a b
*)
Fixpoint exteuc (a b : nat) :=
  match a with
  | O => (0, 1)
  | S a' => let (p, q) := exteuc (b mod (S a')) (S a') in
           (q - (b / a) * p, p)
  end.

Local Opaque Nat.modulo Nat.div Z.mul.
Lemma exteuc_correct :
  forall (t a b : nat),
    (a < t)%nat ->
    let (n, m) := exteuc a b in
    a * n + b * m = Nat.gcd a b.
Proof.
  induction t; intros. lia.
  bdestruct (a <? t)%nat. apply IHt. lia.
  assert (a = t) by lia.
  destruct a. simpl. lia.
  simpl. rename a into a'. remember (S a') as a.
  replace (Z.pos (Pos.of_succ_nat a')) with (Z.of_nat a) by lia.
  assert (b mod a < a)%nat by (apply Nat.mod_upper_bound; lia).
  assert (b mod a < t)%nat by lia.
  specialize (IHt (b mod a)%nat a H3).
  destruct (exteuc (b mod a) a) as (p, q) eqn:E.
  rewrite mod_Zmod in IHt by lia. rewrite Zmod_eq_full in IHt by lia.
  nia.
Qed.
Local Transparent Nat.modulo Nat.div Z.mul.

Local Close Scope Z_scope.
Local Open Scope nat_scope.

Lemma natmul1 :
  forall a b,
    b <> 1 ->
    ~(a * b = 1).
Proof.
  intros. intro. destruct a; destruct b; lia.
Qed.

Lemma mul_mod_1_gcd :
  forall a b p,
    a * b mod p = 1 ->
    Nat.gcd a p = 1.
Proof.
  intros. bdestruct (p =? 0).
  subst. rewrite Nat.gcd_0_r. simpl in H.
  try lia. (* versions < 8.14 *)
  try (apply mult_is_one in H as [? ?]; assumption). (* version 8.14 *)
  bdestruct (p =? 1). subst. easy.
  bdestruct (Nat.gcd a p =? 1). easy.
  destruct (Nat.gcd_divide a p). destruct H4, H3.
  rewrite H3 in H. rewrite H4 in H at 2.
  replace (x0 * Nat.gcd a p * b) with (Nat.gcd a p * (x0 * b)) in H by flia.
  replace (x * Nat.gcd a p) with (Nat.gcd a p * x) in H by flia.
  rewrite Nat.mul_mod_distr_l in H.
  rewrite Nat.mul_comm in H. apply natmul1 in H; easy.
  intro. subst. flia H4 H0.
  intro. rewrite H5 in H4. flia H4 H0.
Qed.

Lemma Nsum_delete : forall n x f,
  (x < n)%nat ->
  (big_sum (update f x 0) n + f x = big_sum f n)%nat.
Proof.
  induction n; intros. lia.
  simpl. bdestruct (x =? n). subst. rewrite update_index_eq.
  rewrite (big_sum_eq_bounded _ f). lia.
  intros. rewrite update_index_neq. easy. lia.
  assert (x < n)%nat by lia. apply IHn with (f := f) in H1. rewrite <- H1.
  rewrite update_index_neq. lia. easy.
Qed.

(* The main use of Nsum2d (and Nsum2dmask) is the "Nsum2dmask_bijection" lemma. *)
Fixpoint Nsum2d (n m : nat) (f : nat -> nat -> nat) :=
  match n with
  | O => O
  | S n' => Nsum2d n' m f + big_sum (fun i => f n' i) m
  end.

Lemma Nsum2d_eq :
  forall n m f g,
    (forall x y, x < n -> y < m -> f x y = g x y) ->
    Nsum2d n m f = Nsum2d n m g.
Proof.
  intros. induction n. easy.
  simpl. rewrite (big_sum_eq_bounded _ (fun i : nat => g n i)).
  rewrite IHn. lia.
  intros. apply H; lia.
  intros. apply H; lia.
Qed.

Lemma Nsum2d_allzero :
  forall n m f,
    (forall x y, x < n -> y < m -> f x y = 0) ->
    Nsum2d n m f = 0.
Proof.
  intros. induction n. easy.
  simpl. rewrite IHn. rewrite (big_sum_eq_bounded _ (fun _ => 0)).
  rewrite big_sum_0; auto.
  intros. apply H; lia.
  intros. apply H; lia.
Qed.

Lemma Nsum2d_scale :
  forall n m f d,
    Nsum2d n m (fun i j => d * f i j) = d * Nsum2d n m f.
Proof.
  intros. induction n. simpl. flia.
  simpl. rewrite IHn.
  rewrite Nat.mul_add_distr_l.
  rewrite Nsum_scale.
  reflexivity.
Qed.

Lemma Nsum2d_eq_d2 :
  forall n m f d,
    (forall x, big_sum (fun i => f x i) m = d) ->
    Nsum2d n m f = n * d.
Proof.
  induction n; intros. easy.
  simpl. rewrite IHn with (d := d). rewrite H. flia.
  apply H.
Qed.

Lemma Nsum2d_le :
  forall n m f g,
    (forall x y, x < n -> y < m -> f x y <= g x y) ->
    Nsum2d n m f <= Nsum2d n m g.
Proof.
  intros. induction n. easy.
  simpl.
  assert (Nsum2d n m f <= Nsum2d n m g). {
    apply IHn. intros. apply H; lia.
  }
  assert (big_sum (f n) m <= big_sum (g n) m). {
    apply Nsum_le. intros. apply H; lia.
  }
  apply Nat.add_le_mono; assumption.
Qed.

Definition Nsum2d' n m (f : nat -> nat -> nat) := big_sum (fun i => big_sum (fun j => f i j) m) n.

Lemma Nsum2d'_Nsum2d :
  forall n m f,
    Nsum2d' n m f = Nsum2d n m f.
Proof.
  intros. induction n; unfold Nsum2d' in *. easy.
  simpl. rewrite IHn. easy.
Qed.

Lemma Nsum2d_swap_order :
  forall n m f,
    Nsum2d n m f = Nsum2d m n (fun i j => f j i).
Proof.
  intros. do 2 rewrite <- Nsum2d'_Nsum2d.
  induction n; unfold Nsum2d' in *. simpl. rewrite big_sum_0; easy.
  simpl. rewrite IHn. symmetry. apply Nsum_add.
Qed.

Definition Nsum2dmask n m f (t : nat -> nat -> bool) := Nsum2d n m (fun i j => if t i j then f i j else 0).

Definition upd2d {A} f x y (a : A) := fun i j => if ((i =? x) && (j =? y)) then a else f i j.

Lemma upd2d_eq :
  forall A x y f a,
    @upd2d A f x y a x y = a.
Proof.
  intros. unfold upd2d. do 2 rewrite Nat.eqb_refl. easy.
Qed.

Lemma upd2d_neq :
  forall A x y f a i j,
    i <> x \/ j <> y ->
    @upd2d A f x y a i j = f i j.
Proof.
  intros. unfold upd2d.
  destruct H. apply Nat.eqb_neq in H. rewrite H. easy.
  apply Nat.eqb_neq in H. rewrite H, andb_false_r. easy.
Qed.

Lemma upd2d_update :
  forall A x y f a, @upd2d A f x y a x = update (f x) y a.
Proof.
  intros. unfold upd2d. rewrite Nat.eqb_refl. easy.
Qed.

Lemma Nsum2dmask_delete_d2 :
  forall m n f t y,
    y < m ->
    Nsum2dmask (S n) m f (upd2d t n y false) + (if (t n y) then f n y else 0) = Nsum2dmask (S n) m f t.
Proof.
  intros. unfold Nsum2dmask. simpl.
  rewrite Nsum2d_eq with (g := (fun i j : nat => if t i j then f i j else 0)).
  rewrite (big_sum_eq_bounded (fun i : nat => if upd2d t n y false n i then f n i else 0) (update (fun i : nat => if t n i then f n i else 0) y 0)).
  rewrite plus_assoc_reverse. rewrite Nsum_delete. easy.
  easy.
  intros. bdestruct (y =? x). subst. rewrite upd2d_eq. rewrite update_index_eq. easy.
  rewrite upd2d_neq by lia. rewrite update_index_neq by lia. easy.
  intros. rewrite upd2d_neq by lia. easy.
Qed.

Lemma Nsum2dmask_delete :
  forall n m f t x y,
    x < n -> y < m ->
    Nsum2dmask n m f (upd2d t x y false) + (if (t x y) then f x y else 0) = Nsum2dmask n m f t.
Proof.
  induction n. easy.
  intros. bdestruct (x =? n). subst. apply Nsum2dmask_delete_d2. easy.
  assert (x < n) by lia.
  unfold Nsum2dmask in *. simpl.
  assert (forall a b c, a + b + c = (a + c) + b) by (intros; lia).
  rewrite H3. rewrite IHn by easy.
  rewrite (big_sum_eq_bounded _ (fun i : nat => if t n i then f n i else 0)); auto.
  intros. rewrite upd2d_neq by lia. easy.
Qed.

Lemma Nsum2dmask_allfalse :
  forall n m f t,
    (forall x y, x < n -> y < m -> t x y = false) ->
    Nsum2dmask n m f t = 0.
Proof.
  intros. unfold Nsum2dmask. induction n. easy.
  simpl. rewrite IHn.
  rewrite (big_sum_eq_bounded _ (fun _ => 0)).
  rewrite big_sum_constant. rewrite times_n_nat. easy.
  intros. rewrite H. easy. lia. easy.
  intros. apply H. lia. easy.
Qed.

Lemma pair_neq :
  forall x y i j : nat, (x, y) <> (i, j) -> x <> i \/ y <> j.
Proof.
  intros. bdestruct (x =? i); bdestruct (y =? j); subst; try easy.
  right. easy. left. easy. left. easy.
Qed.

Lemma Nsum2dmask_bijection :
  forall n f p q g (t : nat -> nat -> bool) (map : nat -> nat * nat),
    (forall x, x < n -> let (i, j) := map x in t i j = true) ->
    (forall i j, i < p -> j < q -> t i j = true -> exists x, x < n /\ map x = (i, j)) ->
    (forall x, x < n -> let (i, j) := map x in i < p /\ j < q) ->
    (forall x, x < n -> let (i, j) := map x in f x = g i j) ->
    (forall x y, x < n -> y < n -> x <> y -> map x <> map y) ->
    big_sum f n = Nsum2dmask p q g t.
Proof.
  induction n; intros.
  - assert (forall x y, x < p -> y < q -> t x y = false). {
      intros. specialize (H0 _ _ H4 H5).
      destruct (t x y).
      destruct H0. easy. destruct H0. lia. easy.
    }
    rewrite Nsum2dmask_allfalse by easy. easy.
  - simpl. destruct (map n) as (i, j) eqn:E.
    remember (upd2d t i j false) as u.
    assert (t i j = true). {
      specialize (H n). rewrite E in H. apply H. flia.
    }
    assert (i < p /\ j < q). {
      specialize (H1 n). rewrite E in H1. apply H1. flia.
    }
    assert (f n = g i j). {
      specialize (H2 n). rewrite E in H2. apply H2. flia.
    }
    assert (forall x, x < n -> map n <> map x). {
      intros. specialize (H3 n x). apply H3; flia H7.
    }
    rewrite (IHn f p q g u map). subst. symmetry. rewrite <- Nsum2dmask_delete with (x := i) (y := j).
    rewrite H4, H6. easy. easy. easy.
    + intros. specialize (H7 _ H8). destruct (map x) eqn:E'.
      rewrite E in H7. apply pair_neq in H7. rewrite Hequ.
      rewrite upd2d_neq by flia H7.
      specialize (H x). rewrite E' in H. apply H. flia H8.
    + intros.
      assert (t i0 j0 = true). {
        rewrite Hequ in H10. destruct (t i0 j0) eqn:Et. easy.
        bdestruct (i =? i0).
        - bdestruct (j =? j0). subst. rewrite upd2d_eq in H10. easy.
          rewrite upd2d_neq in H10. rewrite H10 in Et. easy. right. flia H12.
        - rewrite upd2d_neq in H10. rewrite H10 in Et. easy. left. flia H11.
      }
      apply H0 in H11. destruct H11 as [x [? ?]].
      bdestruct (x =? n). subst. rewrite E in H12.
      apply pair_equal_spec in H12. destruct H12.
      subst. rewrite upd2d_eq in H10. easy.
      exists x. split. flia H11 H13. easy. easy. easy.
    + intros. apply H1. flia H8.
    + intros. apply H2. flia H8.
    + intros. apply H3. flia H8. flia H9. easy.
Qed.

Lemma Nsum2d_Nsum2dmask :
  forall n m f t,
    (forall x y, x < n -> y < m -> t x y = true) ->
    Nsum2d n m f = Nsum2dmask n m f t.
Proof.
  induction n; intros. easy.
  unfold Nsum2dmask in *. simpl. rewrite IHn with (t := t).
  symmetry. rewrite (big_sum_eq_bounded _ (fun i : nat => f n i)). easy.
  intros. rewrite H by lia. easy.
  intros. apply H; lia.
Qed.

Lemma Nsum_Nsum2d :
  forall n f,
    big_sum f n = Nsum2d 1 n (fun _ i => f i).
Proof.
  intros. easy.
Qed.

Definition modinv (a N : nat) := let (n, m) := exteuc a N in Z.to_nat (n mod N)%Z.

Lemma modinv_correct :
  forall a N,
    0 < N ->
    a * (modinv a N) mod N = (Nat.gcd a N) mod N.
Proof.
  intros. unfold modinv.
  assert (a < S a) by lia.
  specialize (exteuc_correct (S a) a N H0) as G.
  destruct (exteuc a N) as (n, m) eqn:E.
  assert (((a * n + N * m) mod N)%Z = Nat.gcd a N mod N).
  { rewrite G. rewrite mod_Zmod by lia. easy.
  }
  rewrite <- Zplus_mod_idemp_r in H1. replace (N * m)%Z with (m * N)%Z in H1 by lia.
  rewrite Z_mod_mult in H1. rewrite Z.add_0_r in H1.
  rewrite <- Zmult_mod_idemp_r in H1.
  replace (n mod N)%Z with (Z.of_nat (Z.to_nat (n mod N)%Z)) in H1.
  2:{ rewrite Z2Nat.id. easy.
      assert (0 < N)%Z by lia.
      specialize (Z.mod_pos_bound n N H2) as T.
      lia.
  }
  rewrite <- Nat2Z.inj_mul in H1.
  rewrite <- mod_Zmod in H1 by lia.
  apply Nat2Z.inj_iff. easy.
Qed.

Lemma modinv_upper_bound :
  forall a N,
    0 < N ->
    modinv a N < N.
Proof.
  intros. unfold modinv. destruct (exteuc a N).
  pattern N at 2. replace N with (Z.to_nat (Z.of_nat N)) by (rewrite Nat2Z.id; easy).
  assert (0 <= z mod N < N)%Z by (apply Z_mod_lt; lia).
  apply Z2Nat.inj_lt; lia.
Qed.

Lemma modinv_coprime' :
  forall p q,
    1 < p -> 0 < q ->
    Nat.gcd p q = 1 ->
    Nat.gcd (modinv q p) p = 1.
Proof.
  intros.
  assert ((q * modinv q p) mod p = 1). {
    rewrite modinv_correct, Nat.gcd_comm, H1.
    apply Nat.mod_small. easy. lia.
  }
  rewrite Nat.mul_comm in H2.
  apply mul_mod_1_gcd with (b := q). easy.
Qed.

Lemma modinv_coprime :
  forall p q,
    1 < p ->
    Nat.gcd p q = 1 ->
    Nat.gcd (modinv q p) p = 1.
Proof.
  intros.
  bdestruct (0 <? q). apply modinv_coprime'; easy.
  assert (q = 0) by lia. subst. rewrite Nat.gcd_0_r in H0. lia.
Qed.

Lemma Nsum_coprime_linear :
  forall p (f : nat -> nat) a b,
    a < p -> b < p -> 1 < p ->
    Nat.gcd a p = 1 ->
    big_sum (fun i => f ((i * a + b) mod p)%nat) p = big_sum f p.
Proof.
  intros. rewrite Nsum_Nsum2d, Nsum2d_Nsum2dmask with (t := (fun _ _ => true)).
  2: intros; easy.
  symmetry. apply Nsum2dmask_bijection with (map := fun i => (0, ((i + (p - b)) * modinv a p) mod p)).
  - intros. easy.
  - intros. assert (i = 0) by flia H3. subst.
    exists ((j * a + b) mod p).
    split. apply Nat.mod_upper_bound. flia H.
    rewrite pair_equal_spec. split. easy.
    rewrite <- Nat.mul_mod_idemp_l by flia H.
    rewrite Nat.add_mod_idemp_l by flia H.
    replace (j * a + b + (p - b)) with (j * a + p) by flia H0.
    rewrite <- Nat.add_mod_idemp_r by flia H.
    rewrite Nat.mod_same by flia H. rewrite Nat.add_0_r.
    rewrite Nat.mul_mod_idemp_l by flia H.
    replace (j * a * modinv a p) with (j * (a * modinv a p)) by flia.
    rewrite <- Nat.mul_mod_idemp_r by flia H.
    rewrite modinv_correct by flia H. rewrite H2. rewrite Nat.mod_small with (a := 1) by flia H1.
    rewrite Nat.mul_1_r.
    apply Nat.mod_small. easy.
  - intros. split. flia. apply Nat.mod_upper_bound. flia H.
  - intros.
    rewrite <- Nat.add_mod_idemp_l by flia H.
    rewrite Nat.mul_mod_idemp_l by flia H.
    replace ((x + (p - b)) * modinv a p * a) with ((x + (p - b)) * (a * modinv a p)) by flia.
    rewrite <- Nat.mul_mod_idemp_r by flia H.
    rewrite modinv_correct by flia H. rewrite H2. rewrite Nat.mod_small with (a := 1) by flia H1.
    rewrite Nat.mul_1_r. rewrite Nat.add_mod_idemp_l by flia H.
    replace (x + (p - b) + b) with (x + p) by flia H0.
    rewrite <- Nat.add_mod_idemp_r by flia H.
    rewrite Nat.mod_same by flia H. rewrite Nat.add_0_r.
    rewrite Nat.mod_small; easy.
  - intros. intro. apply pair_equal_spec in H6.
    destruct H6.
    assert (((x + (p - b)) * modinv a p * a + b) mod p = ((y + (p - b)) * modinv a p * a + b) mod p). {
      rewrite <- Nat.add_mod_idemp_l, <- Nat.mul_mod_idemp_l by flia H.
      rewrite H7.
      rewrite Nat.mul_mod_idemp_l, Nat.add_mod_idemp_l by flia H.
      easy.
    }
    replace ((x + (p - b)) * modinv a p * a) with ((x + (p - b)) * (a * modinv a p)) in H8 by flia.
    replace ((y + (p - b)) * modinv a p * a) with ((y + (p - b)) * (a * modinv a p)) in H8 by flia.
    rewrite <- Nat.add_mod_idemp_l, <- Nat.mul_mod_idemp_r, modinv_correct in H8 by flia H.
    rewrite H2, Nat.mod_small with (a := 1), Nat.mul_1_r in H8 by flia H1.
    rewrite Nat.add_mod_idemp_l in H8 by flia H.
    replace (x + (p - b) + b) with (x + p) in H8 by flia H0.
    rewrite <- Nat.add_mod_idemp_r, Nat.mod_same, Nat.add_0_r, Nat.mod_small in H8 by flia H H3.
    symmetry in H8.
    rewrite <- Nat.add_mod_idemp_l, <- Nat.mul_mod_idemp_r, modinv_correct in H8 by flia H.
    rewrite H2, Nat.mod_small with (a := 1), Nat.mul_1_r in H8 by flia H1.
    rewrite Nat.add_mod_idemp_l in H8 by flia H.
    replace (y + (p - b) + b) with (y + p) in H8 by flia H0.
    rewrite <- Nat.add_mod_idemp_r, Nat.mod_same, Nat.add_0_r, Nat.mod_small in H8 by flia H H4.
    flia H5 H8.
Qed.

(* ============================= *)
(* =   Multiplicative Order    = *)
(* ============================= *)

(* r is the order of a modulo p *)
Definition Order (a r N : nat) :=
  0 < r /\
  a^r mod N = 1 /\
  (forall r' : nat, (0 < r' /\ a^r' mod N = 1) -> r' >= r).

Lemma pow_mod :
  forall a b n : nat,
    a^b mod n = (a mod n)^b mod n.
Proof.
  intros. induction b. easy.
  bdestruct (n =? 0). subst. easy.
  simpl. rewrite Nat.mul_mod by easy. rewrite IHb. rewrite Nat.mul_mod_idemp_r by easy.
  easy.
Qed.

Lemma Order_N_lb :
  forall a r N, 0 < N ->
    Order a r N ->
    1 < N.
Proof.
  intros a r N E H.
  destruct (1 <? N)%nat eqn:S.
  - apply Nat.ltb_lt in S; easy.
  - apply Nat.ltb_ge in S. destruct H as [_ [? _]].
    replace N with 1%nat in H by lia. simpl in H. discriminate H.
Qed.

Lemma Order_a_nonzero :
  forall a r N, 0 < N ->
    Order a r N ->
    0 < a.
Proof.
  intros a r n ? H. assert (HN := H). apply Order_N_lb in HN.
  destruct (0 <? a)%nat eqn:E.
  - apply Nat.ltb_lt in E; easy.
  - apply Nat.ltb_ge in E. assert (a=0) by lia. destruct H as [? [? _]]. rewrite H1 in H2. rewrite Nat.pow_0_l in H2. rewrite Nat.mod_0_l in H2 by lia. lia. lia.
  - assumption.
Qed.

Lemma Order_a_inv_ex :
  forall a r N,
    Order a r N ->
    exists a_inv,
      (a * a_inv) mod N = 1.
Proof.
  intros. exists (a^(pred r))%nat. destruct H as [? [? _]].
  assert (a * a ^ Init.Nat.pred r = a^1 * a^(Init.Nat.pred r))%nat. rewrite Nat.pow_1_r; easy. rewrite H1.
  rewrite <- Nat.pow_add_r. rewrite Nat.succ_pred; lia.
Qed.

Lemma Order_rel_prime :
  forall a r N, 0 < N ->
    Order a r N ->
    Nat.gcd a N = 1.
Proof.
  intros. destruct (Order_a_inv_ex _ _ _ H0) as [ainv G].
  specialize (Nat.gcd_divide a N) as [[a' Ha] [N' HN]].
  remember (Nat.gcd a N) as g. bdestruct (g =? 1). easy.
  rewrite Ha, HN in G. replace (a' * g * ainv) with (a' * ainv * g) in G by lia.
  rewrite Nat.mul_mod_distr_r in G. specialize (natmul1 ((a' * ainv) mod N') g H1) as T. easy.
  apply Order_N_lb in H0. lia. assumption.
  apply Order_N_lb in H0. lia. assumption.
Qed.

Lemma Order_modinv_correct :
  forall a r N, 0 < N ->
    Order a r N ->
    (a * (modinv a N)) mod N = 1.
Proof.
  intros. specialize (Order_rel_prime _ _ _ H H0) as G.
  apply Order_N_lb in H0.
  rewrite modinv_correct by lia. rewrite G.
  rewrite Nat.mod_small; easy.
  assumption.
Qed.

Lemma inv_pow :
  forall a r N a_inv x, 0 < N ->
    Order a r N ->
    (a * a_inv) mod N = 1 ->
    (a^x * a_inv^x) mod N = 1.
Proof.
  intros. assert (HN := H0). apply Order_N_lb in HN. induction x.
  - simpl. apply Nat.mod_1_l. easy.
  - simpl. rewrite Nat.mul_assoc. rewrite (Nat.mul_shuffle0 a (a^x)%nat a_inv).
    rewrite mult_assoc_reverse with (n:=(a * a_inv)%nat). rewrite <- Nat.mul_mod_idemp_l with (a:=(a * a_inv)%nat); try lia. rewrite H1. rewrite Nat.mul_1_l. apply IHx.
  - assumption.
Qed.

Lemma Pow_minus_aux :
  forall a r N a_inv x d, 0 < N ->
    Order a r N ->
    (a * a_inv) mod N = 1 ->
    a^d mod N = (a^(x + d) * a_inv^x) mod N.
Proof.
  intros. replace (x + d)%nat with (d + x)%nat by lia. rewrite Nat.pow_add_r.
  assert (HN := H0). apply Order_N_lb in HN.
  rewrite <- Nat.mul_assoc. rewrite <- Nat.mul_mod_idemp_r; try lia. rewrite inv_pow with (r:=r); auto. rewrite Nat.mul_1_r. easy.
  assumption.
Qed.

Lemma Pow_minus :
  forall a r N a_inv x1 x2, 0 < N ->
    Order a r N ->
    x1 <= x2 ->
    (a * a_inv) mod N = 1 ->
    a^(x2-x1) mod N = (a^x2 * a_inv^x1) mod N.
Proof.
  intros. rewrite Pow_minus_aux with (r:=r) (a:=a) (x:=x1) (a_inv:=a_inv); try easy. replace (x1 + (x2 - x1))%nat with (x2 - x1 + x1)%nat by lia. rewrite Nat.sub_add; easy.
Qed.

Lemma Pow_diff :
  forall a r N x1 x2, 0 < N ->
    Order a r N ->
    0 <= x1 < r ->
    0 <= x2 < r ->
    x1 < x2 ->
    a^x1 mod N <> a^x2 mod N.
Proof.
  intros. intro.
  assert (Ha_inv := H0). apply Order_a_inv_ex in Ha_inv. destruct Ha_inv as [a_inv Ha_inv].
  assert (HN := H0). apply Order_N_lb in HN.
  assert (a^(x2-x1) mod N = 1).
  rewrite Pow_minus with (r:=r) (a_inv:=a_inv); try lia; try easy.
  rewrite <- Nat.mul_mod_idemp_l; try lia.
  rewrite <- H4. rewrite Nat.mul_mod_idemp_l; try lia.
  rewrite <- Pow_minus with (r:=r); try lia; try easy.
  rewrite Nat.sub_diag. simpl. apply Nat.mod_1_l; easy.
  destruct H0 as [_ [_ Hminimal]].
  specialize (Hminimal (x2 - x1)%nat) as Hcounter.
  assert (0 < x2 - x1 /\ a ^ (x2 - x1) mod N = 1)%nat by lia.
  apply Hcounter in H0. lia.
  assumption.
Qed.

Lemma Pow_diff_neq :
  forall a r N x1 x2, 0 < N ->
    Order a r N ->
    0 <= x1 < r ->
    0 <= x2 < r ->
    x1 <> x2 ->
    a^x1 mod N <> a^x2 mod N.
Proof.
  intros. apply not_eq in H3. destruct H3.
  - apply Pow_diff with (r:=r); easy.
  - apply not_eq_sym. apply Pow_diff with (r:=r); easy.
Qed.

Lemma Pow_pos :
  forall (a r N i : nat), 0 < N ->
    Order a r N ->
    a^i mod N > 0.
Proof.
  intros. unfold gt. destruct (Nat.lt_ge_cases 0 (a ^ i mod N)). easy.
  inversion H1.  exfalso. cut (a^r mod N = 0).
  intros. destruct H0 as (Ha & Hb & Hc). lia.
  assert (N <> 0).
  { assert (1 < N). { apply (Order_N_lb a r _); easy. } lia. }
  destruct (Nat.lt_ge_cases i r).
  - assert (r = (i + (r - i))%nat) by lia.
    rewrite H5. rewrite -> Nat.pow_add_r. rewrite Nat.mul_mod. rewrite H3. simpl.
    apply Nat.mod_0_l.
    easy. easy.
  - assert (r = (i - (i - r))%nat) by lia.
    rewrite H5. specialize (Order_a_inv_ex a r N H0) as e. destruct e.
    rewrite (Pow_minus _ r _ x _ _); try easy; try lia.
    rewrite Nat.mul_mod. rewrite H3. simpl.
    apply Nat.mod_0_l. easy. easy.
Qed.

(* from https://gist.github.com/jorpic/bf37de156f48ea438076 *)
Lemma nex_to_forall : forall k n x : nat, forall f,
 (~exists k, k < n /\ f k = x) -> k < n -> f k <> x.
Proof.
  intros k n x f H_nex H_P H_Q.
  apply H_nex; exists k; auto.
Qed.

(* from https://gist.github.com/jorpic/bf37de156f48ea438076 *)
Lemma exists_or_not :
  forall n x : nat, forall f : nat -> nat,
    (exists k, k < n /\ f k = x) \/ (~exists k, k < n /\ f k = x).
Proof.
  intros n x f.
  induction n.
  - right. intro H_ex.
    destruct H_ex as [k [Hk Hf]]. easy.
  - destruct IHn as [H_ex | H_nex].
    + destruct H_ex as [k [H_kn H_fk]].
      left; exists k; auto.
    + destruct (eq_nat_dec (f n) x) as [H_fn_eqx | H_fn_neq_x].
      * left; exists n; auto.
      * right. intro H_nex'.
        destruct H_nex' as [k [H_kn H_fk]].
        apply H_fn_neq_x.
        apply lt_n_Sm_le in H_kn.
        apply le_lt_or_eq in H_kn.
        destruct H_kn as [H_lt | H_eq].
        contradict H_fk.
          apply (nex_to_forall k n x f H_nex H_lt).
        rewrite <- H_eq; assumption.
Qed.

(* from https://gist.github.com/jorpic/bf37de156f48ea438076 *)
Theorem pigeonhole
    :  forall n : nat, forall f : nat -> nat, (forall i, i <= n -> f i < n)
    -> exists i j, i <= n /\ j < i /\ f i = f j.
Proof.
  induction n.
  - intros f Hf.
    specialize (Hf 0 (le_refl 0)). easy.
  - intros f Hf.
    destruct (exists_or_not (n+1) (f (n+1)%nat) f) as [H_ex_k | H_nex_k].
    + destruct H_ex_k as [k [Hk_le_Sn Hfk]].
      exists (n+1)%nat, k.
      split; [lia | split; [assumption | rewrite Hfk; reflexivity]].
    + set (g := fun x => if eq_nat_dec (f x) n then f (n+1)%nat else f x).
      assert (forall i : nat, i <= n -> g i < n).
      { intros. unfold g.
        destruct (eq_nat_dec (f i) n).
        - apply nex_to_forall with (k := i) in H_nex_k.
          + specialize (Hf (n+1)%nat); lia.
          + lia.
        - specialize (Hf i); lia.
      }
      destruct (IHn g H) as [x H0].
      destruct H0 as [y [H1 [H2 H3]]].
      exists x, y. split; [lia | split ; [assumption | idtac]].
      (* lemma g x = g y -> f x = f y *)
      unfold g in H3.
      destruct eq_nat_dec in H3.
      { destruct eq_nat_dec in H3.
        - rewrite e; rewrite e0. reflexivity.
        - contradict H3.
          apply not_eq_sym.
          apply nex_to_forall with (n := (n+1)%nat).
          apply H_nex_k. lia.
      }
      { destruct eq_nat_dec in H3.
        - contradict H3.
          apply nex_to_forall with (n := (n+1)%nat).
          apply H_nex_k. lia.
        - assumption.
      }
Qed.

Lemma Order_r_lt_N :
  forall a r N, 0 < N ->
    Order a r N ->
    r < N.
Proof.
  intros.
  destruct (Nat.lt_ge_cases r N). easy.
  remember (fun i => pred (a^i mod N))%nat as f.
  cut (exists i j, i <= pred r /\ j < i /\ f i = f j).
  - intros. destruct H2 as (i & j & H2 & H3 & H4).
    cut (f i <> f j). easy.
    rewrite Heqf.
    assert (forall (a b : nat), a > 0 -> b > 0 -> a <> b -> pred a <> pred b).
    { intros. lia. }
    apply H5.
    + apply (Pow_pos _ r _ _); easy.
    + apply (Pow_pos _ r _ _); easy.
    + assert (forall T (x y : T), x <> y -> y <> x) by auto.
      apply H6. apply (Pow_diff _ r _ j i); try lia. easy.
  - apply pigeonhole. intros. subst.
    assert (forall (a b : nat), a > 0 -> b > 0 -> a < b -> pred a < pred b) by (intros; lia).
    apply H3. apply (Pow_pos _ r _ _); easy. destruct H0. auto.
    cut (a^i mod N < N). lia.
    apply Nat.mod_upper_bound.
    assert (1 < N). { apply (Order_N_lb a r _); easy. } lia.
Qed.


(**
DFA (決定性有限オートマトン）を定義してみる。

文献[1]：Tukuba Coq Users' Grup 「Coqによる定理証明」
坂口さん著「反復定理で遊ぼう」

実装にあたっては、
文献[2]: https://www.ps.uni-saarland.de/~doczkal/regular/
を参考にしているが、そのパッケージは使用しない。
 *)

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

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

(**
以下のDFA M = (Q, Σ, δ, q0, F) を考える（文献[1]のp.4 例1.9）。

Q = {0, 1, 2, 3, 4, 5}    オートマトンの状態
Σ = {0, 1}                受理するアルファベット
δ(q, a) = (q + 2) mod 6 (a = 0)  状態遷移関数
δ(q, a) = (q + 3) mod 6 (a = 1)
q0 = 0                    初期状態
F = {0}                   終了状態
*)

Record dfa : Type :=
  {
    dfa_state :> finType;                          (* Q *)
    dfa_char :> finType;                           (* Σ *)
    dfa_s : dfa_state;                             (* q0 *)
    dfa_fin : pred dfa_state;                      (* F *)
    dfa_trans : dfa_state -> dfa_char -> dfa_state (* δ *)
  }.

(** オートマトンの状態 *)
Definition Q : predArgType := 'I_6.         (* {0, 1, 2, 3, 4, 5}  *)
(** オートマトンの初期状態はq0 *)
Definition q0 : Q. Proof. have : 0 < 6 by []. apply Ordinal. Defined.
Compute (nat_of_ord q0).                    (* 0 : nat *)
Definition q1 : Q. Proof. have : 1 < 6 by []. apply Ordinal. Defined.
Definition q2 : Q. Proof. have : 2 < 6 by []. apply Ordinal. Defined.
Definition q3 : Q. Proof. have : 3 < 6 by []. apply Ordinal. Defined.
Definition q4 : Q. Proof. have : 4 < 6 by []. apply Ordinal. Defined.
Definition q5 : Q. Proof. have : 5 < 6 by []. apply Ordinal. Defined.
(** nat を Qに変換する。 *)
Lemma lt0_6 : 0 < 6. Proof. by []. Qed.
Definition qn (n : nat) : Q := Ordinal (@ltn_pmod n 6 lt0_6).
Compute (nat_of_ord (qn 1)).                (* 1 : nat *)

(** アルファベット  *)
Definition Sigma : predArgType := 'I_2.     (* {0, 1} *)
Definition a0 : Sigma. Proof. have : 0 < 2 by []. apply Ordinal. Defined.
Definition a1 : Sigma. Proof. have : 1 < 2 by []. apply Ordinal. Defined.
(** nat を Sigmaに変換する。 *)
(* Qのときと、少し違うことをしているが大差はない。 *)
Lemma lt2_pmod (n : nat) : n %% 2 < 2. Proof. by apply ltn_pmod. Qed.
Definition an (n : nat) : Sigma := Ordinal (lt2_pmod n).
Compute (nat_of_ord (an 1)).                (* 1 : nat *)

(** 状態遷移関数 *)
Definition delta (q : Q) (a : Sigma) :=
  match (nat_of_ord a) with
    | 0 => qn (nat_of_ord q).+2
    | _ => qn (nat_of_ord q).+3
  end.
(* テスト  *)
Goal delta q0 a0 == q2. Proof. by []. Qed.
Goal delta q1 a0 == q3. Proof. by []. Qed.
Goal delta q1 a0 == q3. Proof. by []. Qed.

(** オートマトンの終了状態 *)
Definition Fin x := x \in [:: q0].
Compute Fin q0.                             (* true *)
Compute Fin q1.                             (* false *)

(** オートマトンの定義 *)
Definition mydfa := Build_dfa q0 Fin delta.
(* テスト *)
Goal q0 \in @dfa_fin mydfa == true. Proof. by []. Qed.
Goal @dfa_trans mydfa q0 a0 == q2. Proof. by []. Qed.

Section DFA_Acceptance.
  Variable A : dfa.

  Fixpoint dfa_accept (x : A) w : bool :=
    if w is a :: w' then
      dfa_accept (dfa_trans x a) w'
    else
      x \in @dfa_fin A.

  Lemma dfa_accept_cons (x : A) a w :
    dfa_accept x (a :: w) = dfa_accept (dfa_trans x a) w.
  Proof.
      by rewrite -simpl_predE /=.
  Qed.
End DFA_Acceptance.

Arguments dfa_s [d].
Arguments dfa_trans [d] x a.
Arguments dfa_accept [A] x w.
Arguments dfa_accept_cons [A] x a w.

Goal @dfa_accept mydfa dfa_s [::] == true.
Proof.
  by [].
Qed.

Goal @dfa_accept mydfa dfa_s [:: a0; a1; a0; a1; a0] == true.
Proof.
  by [].
Qed.

(**
 その他の 'I_6 についての補題
*)

Definition p3 : 'I_5. Proof. have : 3 < 5 by []. apply Ordinal. Defined.
Compute lift q3 p3.                         (* 'I_6 *)
Compute nat_of_ord (lift q3 p3).            (* 5 : nat *)

Goal #| 'I_6 | = 6.
Proof.
  by apply card_ord.
Qed.

Goal q0 \in enum 'I_6.
Proof.
  apply mem_enum.
Qed.

Goal size (enum 'I_6) = 6.
Proof.
  by apply size_enum_ord.
Qed.

Goal index q0 (enum 'I_6) = q0.
Proof.
  by apply index_enum_ord.
Qed.

Goal [seq val i | i <- enum 'I_6] = [:: 0; 1; 2; 3; 4; 5].
Proof.
  by rewrite val_enum_ord.
Qed.

Goal ord_enum 6 =i enum 'I_6.
Proof.
  move=> x.
  apply/idP/idP => H.
  - by apply mem_enum.
  - by apply mem_ord_enum.
Qed.

Lemma eq_6_6 : 6 = 6. by []. Qed.
Check cast_ord eq_6_6 q0 : 'I_6.            (* 型を変える。 *)
Check lshift 0 q5 : 'I_6.                   (* 型を変える。 *)

Lemma le_6_8 : 6 <= 8. by []. Qed.
Check widen_ord le_6_8 q0 : 'I_8.           (* 型を変える。 *)
Check lshift 2 q5 : 'I_8.                   (* 型を変える。 *)
Check @lshift 6 2 q5 : 'I_8.                (* 型を変える。 *)
Check @rshift 2 6 q5 : 'I_8.                (* 型を変える。 *)

(* END *)


Require Import Undecidability.Shared.Libs.PSL.Base Lia.
Require Import Arith.
(* Nats smaller than n *)

Fixpoint natsLess n : list nat :=
  match n with
    0 => []
  | S n => n :: natsLess n
  end.

Lemma natsLess_in_iff n m:
  n el natsLess m <-> n < m.
Proof.
  induction m in n|-*;cbn. lia.
  split.
  -intuition. destruct n; intuition lia. apply IHm in H0. lia.
  -intros. decide (m=n). intuition lia. right. apply IHm. lia.
Qed.

Lemma natsLess_S n :
  natsLess (S n) = map S (natsLess n)++[0].
Proof.
  induction n;cbn in *;congruence.
Qed.

(* Sum *)

Fixpoint sumn (A:list nat) :=
  match A with
    [] => 0
  | a::A => a + sumn A
  end.

Lemma sumn_app A B : sumn (A++B) = sumn A + sumn B.
Proof.
  induction A;cbn;lia.
Qed.

Global Hint Rewrite sumn_app : list.

Lemma length_concat X (A : list (list X)) :
  length (concat A) = sumn (map (@length _) A).
Proof.
  induction A;cbn. reflexivity. autorewrite with list in *. lia.
Qed.

Lemma sumn_rev A :
  sumn A = sumn (rev A).
Proof.
  enough (H:forall B, sumn A + sumn B = sumn (rev A++B)).
  {specialize (H []). cbn in H. autorewrite with list in H. cbn in H. lia. }
  induction A as [|a A];intros B. reflexivity.
  cbn in *. specialize (IHA (a::B)). autorewrite with list in *. cbn in *. lia.
Qed.

Lemma sumn_map_natsLess f n :
  sumn (map f (natsLess n)) = sumn (map (fun i => f (n - (1 + i))) (natsLess n)).
Proof.
  rewrite sumn_rev. f_equal.
  rewrite <- map_rev.
  rewrite <- map_map with (g:=f) (f:= fun i => (n - (1+i))).
  f_equal.
  induction n;intros;autorewrite with list in *. reflexivity.
  rewrite natsLess_S at 2. cbn. rewrite map_app. cbn.
  rewrite map_map. cbn in IHn.
  rewrite IHn. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma sumn_map_add X f g (l:list X) :
  sumn (map (fun x => f x + g x) l) = sumn (map f l) + sumn (map g l).
Proof.
  induction l;cbn;nia.
Qed.
Lemma sumn_map_mult_c_r X f c (l:list X) :
  sumn (map (fun x => f x *c) l) = sumn (map f l)*c.
Proof.
  induction l;cbn;nia.
Qed.
Lemma sumn_map_c X c (l:list X) :
  sumn (map (fun _ => c) l) = length l * c.
Proof.
  induction l;cbn;nia.
Qed.

Lemma sumn_le_in n xs: n el xs -> n <= sumn xs.
Proof.
  induction xs. easy. intros [ | ]. now cbn;nia.
  cbn;etransitivity. apply IHxs. easy. nia.
Qed.

Lemma sumn_concat xs: sumn (concat xs) = sumn (map sumn xs).
Proof.
  induction xs;cbn. easy. etransitivity. apply sumn_app. nia.
Qed.

Lemma sumn_repeat c n: sumn (repeat c n) = c * n.
Proof.
  induction n;cbn. all:nia.
Qed.

Definition maxl := fold_right max 0.
Lemma maxl_leq n l: n el l -> n <= maxl l.
Proof.
  induction l;cbn.
  -easy.
  -intros [->|]. all:apply Nat.max_case_strong;try intuition Lia.lia.
Qed.

Lemma maxl_leq_l c l :
  (forall n, n el l -> n <= c) -> maxl l <= c.
Proof.
  induction l;cbn. Lia.lia.
  intros H. eapply Nat.max_lub_iff;split. all:eauto.
Qed.

Lemma maxl_app l l': maxl (l++l') = max (maxl l) (maxl l').
Proof.
  induction l;cbn;Lia.lia.
Qed.

Lemma maxl_rev l: maxl (rev l) = maxl l.
Proof.
  unfold maxl. rewrite fold_left_rev_right. rewrite fold_symmetric. 2,3:now intros;Lia.lia.
  induction l;cbn;try Lia.lia.
Qed.


Ltac forall_e H t := (generalize (H t); intro).

Require Import Setoid.

Section Gaulois.
  Variable personnage: Set.
  Variables humain gaulois romain animal: personnage -> Prop.
  Variables Idefix Panoramix: personnage.

  Hypothesis Hngr: forall p:personnage, ~(gaulois p /\ romain p).
  Hypothesis Hpers: forall p:personnage, animal p \/ gaulois p \/ romain p.
  Hypothesis Hhum: forall p:personnage, humain p <-> (gaulois p \/ romain p).
  Hypothesis Hnon_humain_animal:
    forall p:personnage, ~(humain p /\ animal p).

  Hypothesis Hidef: animal Idefix.
  Hypothesis Hpano: gaulois Panoramix.
  Hypothesis Hrom: exists p:personnage, romain p.

  Theorem Exemple: exists x:personnage, humain x /\ ~gaulois x.
  Proof.
    destruct Hrom as [y Hy].
    exists y.
    split.
    - rewrite Hhum.
      right.
      assumption.
    - forall_e Hngr y.
      intro Hgy.
      apply H.
      split.
      + assumption.
      + assumption.
  Qed.

(* Dans les 5 théorèmes ci-dessous, remplacez "Admitted." par un
   script de preuve complet, que vous terminerez par "Qed."

   Barème indicatif: pour chaque théorème, 3.5 points pour un
   script qui prouve le théorème sans rien admetter; 0.5 point
   supplémentaire si la preuve est structurée de manière à
   permettre de la suivre sans interagir avec Coq (prendre exemple
   sur la preuve précédente).

   *)

  Theorem Exercice1: ~ gaulois Idefix.
  Proof.
intro.
forall_e Hnon_humain_animal Idefix.
apply H0.
split.
- rewrite Hhum.
  left;assumption.
- assumption.
  Qed.

  Theorem Exercice2:
    forall p:personnage, humain p -> ~romain p -> gaulois p.
  Proof.
intros.
rewrite Hhum in H.
destruct H.
- assumption.
- exfalso.
  apply H0 ; assumption.
  Qed.

  Theorem Exercice3:
    exists p:personnage, humain p /\ ~gaulois p.
  Proof.
destruct Hrom.
exists x.
split.
- rewrite Hhum.
  right ; assumption.
- intro.
  forall_e Hngr x.
  apply H1.
  split.
  * assumption.
  * assumption.
  Qed.

  Theorem Exercice4:
    forall p, ~animal p -> gaulois p \/ romain p.
  Proof.
intros.
forall_e Hpers p.
destruct H0.
- exfalso.
  apply H; assumption.
- assumption.
  Qed.

  Theorem Exercice5: Idefix <> Panoramix.
  Proof.
    (* Indication: on peut utiliser n'importe quel théorème,
       y compris un qui a été prouvé comme exercice *)
intro.
forall_e Hnon_humain_animal Idefix.
rewrite H in Hidef.
apply H0.
split.
- rewrite H.
  forall_e Hhum Panoramix.
  apply H1 ; left; assumption.
- rewrite H;assumption.
  Qed.

End Gaulois.


From mathcomp Require Import all_ssreflect.
Require Import Utf8.
Import EqNotations.
Set Implicit Arguments.

(* useful stuff *)

Definition vmap A B n (f: A → B) (v: A^n): B^n := finfun (f \o v).

(* Language, Term, Formula *)

Structure Language F R := {
  function_arity: F → nat;
  relation_arity: R → nat
}.

Definition Function A n := A^n → A.
Definition Relation A n := A^n → Prop.

Inductive Term {F R} (V: eqType) (L: Language F R) :=
  | variable: V → Term V L
  | function_term: ∀ (f: F), (Term V L)^(function_arity L f) → Term V L.

Definition Term_induction F R (V: eqType) (L: Language F R) (P: Term V L -> Prop):
  (∀ (s: V), P (variable V L s)) →
  (∀ (f: F) (T: Term V L ^ function_arity L f), (forall (x: 'I_(function_arity L f)), P (T x)) → P (function_term f T)) →
  ∀ T, P T.
Proof.
  intros H H0. refine (fix IHt (t: Term V L) := match t with variable v => H v | function_term f T => _ end).
  refine (H0 _ T _). intros. apply IHt.
Defined.

Inductive Formula F R (V: eqType) (L: Language F R) :=
  | equality: Term V L → Term V L → Formula V L
  | atomic_formula: ∀ (r: R), (Term V L)^(relation_arity L r) → Formula V L
  | negation: Formula V L → Formula V L
  | disjunction: Formula V L → Formula V L → Formula V L
  | conjunction: Formula V L → Formula V L → Formula V L
  | existence_quantifier: V → Formula V L → Formula V L
  | universal_quantifier: V → Formula V L → Formula V L.

Fixpoint term_has_variable F R (V: eqType) (L: Language F R) (i: V) (t: Term V L) {struct t}: bool :=
  match t with
  | variable x => (i == x)
  | function_term f t' => has (eqb true) (codom (term_has_variable i \o t'))
  end.

Fixpoint formula_has_free_variable F R V (L: Language F R) (A: Formula V L) (i: V): Prop :=
  match A with
  | equality t1 t2 => term_has_variable i t1 ∨ term_has_variable i t2
  | atomic_formula r v => has (term_has_variable i) (codom v)
  | negation f => formula_has_free_variable f i
  | disjunction f1 f2 => formula_has_free_variable f1 i ∨ formula_has_free_variable f2 i
  | conjunction f1 f2 => formula_has_free_variable f1 i ∨ formula_has_free_variable f2 i
  | existence_quantifier v f => v != i ∧ formula_has_free_variable f i
  | universal_quantifier v f => v != i ∧ formula_has_free_variable f i
  end.

Definition has_n_free_variables F R V (L: Language F R) (A: Formula V L) (n: nat) :=
  ∃ (v: V ^ n), uniq (codom v) ∧ (∀ (x: V), formula_has_free_variable A x ↔ x \in codom v).

Structure Sentence F R V (L: Language F R) := {
  sentenceFormula:> Formula V L;
  sentenceProperty: ∀ i, ¬ formula_has_free_variable sentenceFormula i
}.

(* Structure, Interpretation *)

Structure Structure {F R} (L: Language F R) := {
  domain: Type;
  function: ∀ (f: F), Function domain (function_arity L f);
  relation: ∀ (r: R), Relation domain (relation_arity L r)
}.

Fixpoint interpreted_term F R (V: eqType) (L: Language F R) (M: Structure L) (assignment: V → domain M) (T: Term V L): domain M :=
  match T with
  | variable x => assignment x
  | function_term f v => function M f (finfun (interpreted_term M assignment \o v))
  end.

Fixpoint satisfies F R (V: eqType) (L: Language F R) (M: Structure L) (A: Formula V L) (assignment: V → domain M): Prop :=
  match A with
  | equality t1 t2 => interpreted_term M assignment t1 = interpreted_term M assignment t2
  | atomic_formula r v => relation M r (vmap (interpreted_term M assignment) v)
  | negation f => ¬ satisfies M f assignment
  | disjunction f1 f2 => satisfies M f1 assignment ∨ satisfies M f2 assignment
  | conjunction f1 f2 => satisfies M f1 assignment ∧ satisfies M f2 assignment
  | existence_quantifier v f => ∃ i, satisfies M f (λ x, if v == x then i else assignment x)
  | universal_quantifier v f => ∀ i, satisfies M f (λ x, if v == x then i else assignment x)
  end.

Definition model_of_sentence F R V (L: Language F R) (M: Structure L) (A: Sentence V L) :=
  ∀ a, satisfies M A a.

Definition model F R V (L: Language F R) (M: Structure L) (A: Sentence V L → Prop) :=
  ∀ a, A a → model_of_sentence M a.

(* Embedding, Isomorphism, Automorphism *)

Structure Embedding Fm Rm Fn Rn (Lm: Language Fm Rm) (Ln: Language Fn Rn) (M: Structure Lm) (N: Structure Ln) := {
  domain_map: domain M → domain N;
  function_map: Fm → Fn;
  relation_map: Rm → Rn;
  domain_map_property: injective domain_map;
  function_arity_preserved: ∀ f, function_arity Lm f = function_arity Ln (function_map f);
  relation_arity_preserved: ∀ r, relation_arity Lm r = relation_arity Ln (relation_map r);
  embedding_function_property: ∀ f v, domain_map (function M f v) =
    function N (function_map f) (vmap domain_map (rew [λ W, (domain M ^ W)%type] (function_arity_preserved f) in v));
  embedding_relation_property: ∀ r v, relation M r v ↔
    relation N (relation_map r) (vmap domain_map (rew [λ W, (domain M ^ W)%type] (relation_arity_preserved r) in v));
}.

Structure Isomorphism Fm Rm Fn Rn (Lm: Language Fm Rm) (Ln: Language Fn Rn) (M: Structure Lm) (N: Structure Ln) := {
  isomorphism_emb: Embedding M N;
  isomorphism_emb_inv: Embedding N M;
  isomorphism_property_1: ∀ x, domain_map isomorphism_emb (domain_map isomorphism_emb_inv x) = x;
  isomorphism_property_2: ∀ x, domain_map isomorphism_emb_inv (domain_map isomorphism_emb x) = x
}.

Definition Auomorphism F R (L: Language F R) (M: Structure L) := Isomorphism M M.

(* Definable set *)

Definition replace_variables {V: eqType} M n (v: V ^ n) (m: M ^ n) (assignment: V → M): V → M.
Proof.
  intro x. remember (x \in codom v) as W. destruct W.
  + refine (m _). exists (index x (codom v)).
    assert (size (codom v) = n) by abstract(rewrite size_codom; simpl; apply card_ord).
    assert (index x (codom v) < size (codom v)) by abstract(rewrite index_mem; auto).
    abstract (rewrite H in H0; auto).
  + exact (assignment x).
Defined.

Definition definable F R (L: Language F R) (M: Structure L) n (X: domain M ^ n → Prop) :=
  ∃ (V: eqType) (A: Formula V L), has_n_free_variables A n ∧
     ∀ (a: V → domain M) (v: V ^ n), (∀ (m: domain M ^ n), X m ↔ satisfies M A (replace_variables v m a)).

(* Theory, Entailment, Satisfiable, Deductively closed *)

Definition Theory F R V (L: Language F R) (C: Structure L → Prop): Sentence V L → Prop :=
  λ (A: Sentence V L), ∀ (M: Structure L), C M → model_of_sentence M A.

Definition satisfiable_theory F R (L: Language F R) (C: Structure L → Prop) :=
  ∃ V (M: Structure L), model M (Theory C) (V:=V).

Definition entailment F R V (L: Language F R) (S: Sentence V L → Prop) (A: Sentence V L) :=
  ∀ (M: Structure L), model M S → model_of_sentence M A.

Definition deductively_closed F R V (L: Language F R) (S: Sentence V L → Prop) :=
  ∀ (A: Sentence V L), entailment S A.

Definition deductive_closure F R V (L: Language F R) (S: Sentence V L → Prop): Sentence V L → Prop :=
  λ (A: Sentence V L), entailment S A.

(* Completeness *)

Theorem negation_of_sentence_as_sentence F R V (L: Language F R) (A: Sentence V L): Sentence V L.
Proof.
  refine (Build_Sentence (negation A) _). abstract (destruct A; simpl in *; auto).
Defined.

Definition complete F R V (L: Language F R) (S: Sentence V L → Prop) :=
  ∀ (A: Sentence V L), entailment S A ∨ entailment S (negation_of_sentence_as_sentence A).

(* Elementary equivalence *)

Definition elementary_equivalence F R (L: Language F R) (M N: Structure L) :=
  ∀ V (A: Sentence V L), model_of_sentence M A ↔ model_of_sentence N A.


(* TLC in Coq
 *
 * Module: tlc.syntax.predicate
 * Purpose: Contains the syntax of predicates.
 *)

Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.
Require Import tlc.syntax.term.

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

(* Forms of logical predicates *)
Inductive predicate :=
| PEqual (x1 x2 : term) (* x1 and x2 are equal *)
| PLess (x1 x2 : term) (* x1 is less than x2 *)
| PMember (y xs : term) (* y is a member of xs *)
| PExtension (xs' xs : term). (* xs' is an extension of xs *)

(* Equality *)
Section eq.

  (* Boolean equality *)
  Definition predicate_eq p1 p2 :=
    match p1, p2 with
    | PEqual x1_1 x1_2, PEqual x2_1 x2_2 => (x1_1 == x2_1) && (x1_2 == x2_2)
    | PLess x1_1 x1_2, PLess x2_1 x2_2 => (x1_1 == x2_1) && (x1_2 == x2_2)
    | PMember y1 xs1, PMember y2 xs2 => (y1 == y2) && (xs1 == xs2)
    | PExtension xs'1 xs1, PExtension xs'2 xs2 => (xs'1 == xs'2) && (xs1 == xs2)
    | _, _ => false
    end.

  (* Boolean equality reflection *)
  Lemma predicate_eqP : Equality.axiom predicate_eq.
  Proof.
    case=>
      [x1_1 x1_2 | x1_1 x1_2 | y1 xs1 | xs'1 xs1]
      [x2_1 x2_2 | x2_1 x2_2 | y2 xs2 | xs'2 xs2]
      //=; try by constructor.
    - have [<- | neqx] := x1_1 =P x2_1; last (by right; case); simpl.
      have [<- | neqx] := x1_2 =P x2_2; last (by right; case); simpl.
      by constructor.
    - have [<- | neqx] := x1_1 =P x2_1; last (by right; case); simpl.
      have [<- | neqx] := x1_2 =P x2_2; last (by right; case); simpl.
      by constructor.
    - have [<- | neqx] := y1 =P y2; last (by right; case); simpl.
      have [<- | neqx] := xs1 =P xs2; last (by right; case); simpl.
      by constructor.
    - have [<- | neqx] := xs'1 =P xs'2; last (by right; case); simpl.
      have [<- | neqx] := xs1 =P xs2; last (by right; case); simpl.
      by constructor.
  Qed.

  (* EqType canonical structures *)
  Definition predicate_eqMixin := EqMixin predicate_eqP.
  Canonical predicate_eqType := EqType predicate predicate_eqMixin.

End eq.


(** * Bijective functions *)

(* Author: Maximilian Wuttke *)

Require Import Shared.Base.

Section Bijection.
  Variable X Y : Type.

  (*
   *      f
   *   ------>
   * X         Y
   *   <------
   *      g
   *)

  Definition left_inverse  (f : X -> Y) (g : Y -> X) := forall x : X, g (f x) = x.
  Definition right_inverse (f : X -> Y) (g : Y -> X) := forall y : Y, f (g y) = y.
  Definition inverse (f : X -> Y) (g : Y -> X) := left_inverse f g /\ right_inverse f g.

  Definition injective (f : X -> Y) :=
    forall x y, f x = f y -> x = y.

  Lemma left_inv_inj (f : X -> Y) (g : Y -> X) : left_inverse f g -> injective f.
  Proof.
    intros HInv. hnf in *. intros x1 x2 Heq.
    enough (g (f x1) = g (f x2)) as L by now rewrite !HInv in L.
    f_equal. assumption.
  Qed.

  Definition surjective (f : X -> Y) :=
    forall y, exists x, f x = y.

  Lemma right_inv_surjective f g :
    right_inverse f g -> surjective f.
  Proof. intros HInv. hnf. eauto. Qed.

  Definition bijective (f : X -> Y) :=
    injective f /\ surjective f.

  Lemma inverse_bijective f g :
    inverse f g -> bijective f.
  Proof.
    intros (HInv1&HInv2). hnf. split.
    - eapply left_inv_inj; eauto.
    - eapply right_inv_surjective; eauto.
  Qed.

End Bijection.


Require Import Coq.NArith.NArith.
Require Import Coq.micromega.Lia.

Require Import Category.Lib.
Require Import Category.Lib.MapDecide.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.

Generalizable All Variables.
Set Transparent Obligations.

(* An arrows-only meta-category defines identity arrows as those which, when
   composed to the left or right of another arrow, result in that same arrow.
   This definition requires that all such composition be present. *)

Record Metacategory := {
  arrow := N;
  pairs : M.t arrow;

  composite (f g h : arrow) := M.find (f, g) pairs = Some h;
  defined (f g : arrow) := ∃ h, composite f g h;

  composite_defined {f g h : arrow} (H : composite f g h) :
    defined f g := (h; H);

  (*a ∀ edges (X, Y) and (Y, Z), ∃ an edge (X, Z) which is equal to the
     composition of those edges. *)
  composite_correct {f g h fg gh : arrow} :
    composite f g fg ->
    composite g h gh → ∃ fgh, composite fg h fgh;

  composition_law {f g h fg gh : arrow} :
    composite f g fg ->
    composite g h gh ->
    ∀ fgh, composite fg h fgh ↔ composite f gh fgh;

  is_identity (u : arrow) :=
    (∀ f, defined f u → composite f u f) ∧
    (∀ g, defined u g → composite u g g);

  identity_law (x y f : arrow) : composite x y f ->
    ∃ u u', is_identity u → is_identity u' ->
      composite f u f ∧ composite u' f f
}.

Section Category.

Context (M : Metacategory).

Record object := {
  obj_arr : arrow M;
  obj_def : composite M obj_arr obj_arr obj_arr;
  obj_id  : is_identity M obj_arr
}.

Record morphism (dom cod : object) := {
  mor_arr : arrow M;
  mor_dom : composite M mor_arr (obj_arr dom) mor_arr;
  mor_cod : composite M (obj_arr cod) mor_arr mor_arr
}.

Arguments mor_arr {_ _} _.
Arguments mor_dom {_ _} _.
Arguments mor_cod {_ _} _.

Definition identity (x : object) : morphism x x :=
  {| mor_arr := obj_arr x
   ; mor_dom := obj_def x
   ; mor_cod := obj_def x |}.

Lemma composition_left {x y z : object}
      {f : morphism y z} {g : morphism x y} {fg : arrow M} :
  composite M (mor_arr f) (mor_arr g) fg ->
  composite M (obj_arr z) (mor_arr f) (mor_arr f) ->
  composite M (obj_arr z) fg fg.
Proof.
  intros.
  destruct z, obj_id0 as [c c0], f, g; simpl in *.
  specialize (c0 _ (composite_defined M H0)); clear H0.
  destruct (composite_correct M c0 H).
  spose (fst (composition_law M c0 H _) e) as X.
  unfold composite, arrow in *.
  rewrite X, <- H, <- e; reflexivity.
Qed.

Lemma composition_right {x y z : object}
      {f : morphism y z} {g : morphism x y} {fg : arrow M} :
  composite M (mor_arr f) (mor_arr g) fg ->
  composite M (mor_arr g) (obj_arr x) (mor_arr g) ->
  composite M fg (obj_arr x) fg.
Proof.
  intros.
  destruct x, obj_id0 as [c c0], f, g; simpl in *.
  specialize (c _ (composite_defined M H0)); clear H0.
  destruct (composite_correct M H c).
  spose (fst (composition_law M H c _) e) as X.
  unfold composite, arrow in *.
  rewrite e, <- H, <- X; reflexivity.
Qed.

Definition composition {x y z : object}
           (f : morphism y z) (g : morphism x y) : morphism x z :=
  let fg := composite_correct M (mor_dom f) (mor_cod g) in
  {| mor_arr := `1 fg
   ; mor_dom := composition_right (f:=f) (`2 fg) (mor_dom g)
   ; mor_cod := composition_left  (g:=g) (`2 fg) (mor_cod f) |}.

#[export] Program Instance morphism_preorder : PreOrder morphism := {
  PreOrder_Reflexive  := identity;
  PreOrder_Transitive := fun _ _ _ g f => composition f g
}.

#[export] Program Instance morphism_setoid (x y : object) :
  Setoid (morphism x y) := {
  equiv := fun f g => mor_arr f = mor_arr g
}.

Lemma composition_respects {x y z : object} :
  Proper (equiv ==> equiv ==> equiv) (@composition x y z).
Proof.
  proper.
  destruct x0, y0, x1, y1; simpl in *; subst.
  repeat destruct (composite_correct _ _ _); simpl in *.
  unfold composite, arrow in *.
  rewrite e in e0.
  inversion_clear e0.
  reflexivity.
Qed.

Lemma composition_identity_left {x y : object} (f : morphism x y) :
  composition (identity y) f ≈ f.
Proof.
  destruct f; simpl.
  destruct (composite_correct _ _ _); simpl in *.
  unfold composite, arrow in *.
  rewrite mor_cod0 in e.
  inversion_clear e.
  reflexivity.
Qed.

Lemma composition_identity_right {x y : object} (f : morphism x y) :
  composition f (identity x) ≈ f.
Proof.
  destruct f; simpl.
  destruct (composite_correct _ _ _); simpl in *.
  unfold composite, arrow in *.
  rewrite mor_dom0 in e.
  inversion_clear e.
  reflexivity.
Qed.

Lemma composition_associative {x y z w : object}
      (f : morphism z w) (g : morphism y z) (h : morphism x y) :
  composition f (composition g h) ≈ composition (composition f g) h.
Proof.
  destruct f, g, h; simpl.
  repeat destruct (composite_correct _ _ _); simpl in *.
  spose (fst (composition_law M e1 e x3) e2) as X1.
  unfold composite, arrow in *.
  rewrite e0 in X1.
  inversion_clear X1.
  reflexivity.
Qed.

(* Every meta-category, defined wholly in terms of the axioms of category
   theory, gives rise to a category interpreted in the context of set
   theory. *)

Program Definition Category_from_Metacategory : Category := {|
  obj     := object;
  hom     := morphism;
  homset  := fun _ _ => {| equiv := fun f g => mor_arr f = mor_arr g |};
  id      := @identity;
  compose := @composition;

  compose_respects := @composition_respects;

  id_left    := @composition_identity_left;
  id_right   := @composition_identity_right;
  comp_assoc := @composition_associative;
  comp_assoc_sym := fun x y z w f g h =>
    symmetry (@composition_associative x y z w f g h);
|}.

End Category.

Arguments mor_arr _ {_ _} _.
Arguments mor_dom _ {_ _} _.
Arguments mor_cod _ {_ _} _.

Import FMapExt.

Lemma mapsto_inv : ∀ elt f g (fg : elt) x y z m,
  M.MapsTo (f, g) fg (M.add (x, y) z m) ->
    (x = f ∧ y = g ∧ z = fg) ∨ M.MapsTo (f, g) fg m.
Proof.
  intros.
  apply add_mapsto_iffT in H.
  destruct H; simpl in *; intuition.
Defined.

Lemma find_add_inv : ∀ f g (fg : N) x y z m,
  M.find (f, g) (M.add (x, y) z m) = Some fg ->
    (x = f ∧ y = g ∧ z = fg) ∨ M.find (f, g) m = Some fg.
Proof.
  intros.
  destruct (N.eq_dec x f).
  - destruct (N.eq_dec y g).
    + destruct (N.eq_dec z fg).
      * subst; left; intuition.
      * contradiction n.
        rewrite F.add_eq_o in H.
        ** inversion_clear H.
           reflexivity.
        ** simpl; intuition.
    + rewrite F.add_neq_o in H; intuition.
  - rewrite F.add_neq_o in H; intuition.
Defined.

Ltac destruct_maps :=
  repeat match goal with
  | [ H : M.find (?X, ?Y) (M.empty _) = Some ?F |- _ ] =>
    inversion H
  | [ H : M.find (?X, ?Y) (M.add _ _ _) = Some ?F |- _ ] =>
    apply find_add_inv in H;
    (destruct H as [[? [? ?]]|]; [subst; try lia|])
  | [ |- ∃ v, M.find _ _ = Some v ] =>
    vm_compute; eexists; reflexivity

  | [ H : M.find _ _ = Some _ |- _ ] =>
    apply F.find_mapsto_iff in H
  | [ |- M.find _ _ = Some _ ] =>
    apply F.find_mapsto_iff
  | [ |- ∃ v, M.find _ _ = Some v ] =>
    apply find_mapsto_iff_ex

  | [ H : M.MapsTo _ _ (M.empty _) |- _ ] =>
    contradiction (proj1 (F.empty_mapsto_iff _ _) H)

  | [ H : M.MapsTo (?X, ?Y) ?F (M.add _ _ _) |- _ ] =>
    apply mapsto_inv in H; destruct H as [[? [? ?]]|]

  | [ H : ?X = ?Y |- context[M.MapsTo (?Y, _)] ] =>
    rewrite <- H; cbn
  | [ H : ?X = ?Y |- context[M.MapsTo (_, ?Y)] ] =>
    rewrite <- H; cbn
  | [ H : ?X = ?Y |- context[M.MapsTo _ ?Y] ] =>
    rewrite <- H; cbn

  | [ |- ∃ _, M.MapsTo (?X, ?Y) _ _ ] =>
    match goal with
      [ |- context[M.add (X, Y) ?F _ ] ] =>
      exists F
    end
  | [ |- M.MapsTo (?X, ?Y) ?F (M.add (?X, ?Y) ?F _) ] =>
    simplify_maps
  | [ |- M.MapsTo _ _ (M.add _ _ _) ] =>
    simplify_maps; right; split; [idtac|]
  end;
  try congruence.

Ltac reflect_on_maps :=
  simpl; intros;
  match goal with
  | [ |- ∃ _, M.find _ _ = _ ] => destruct_maps
  | [ |- _ ↔ _ ] => split; intros; map_decide
  | [ |- ∃ _ _, _ ] =>
    destruct_maps;
    eexists; eexists; split; intros; clear;
    first [ instantiate (1 := 0%N); vm_compute; reflexivity
          | instantiate (1 := 1%N); vm_compute; reflexivity
          | instantiate (1 := 2%N); vm_compute; reflexivity
          | instantiate (1 := 3%N); vm_compute; reflexivity
          | instantiate (1 := 4%N); vm_compute; reflexivity
          | instantiate (1 := 5%N); vm_compute; reflexivity
          | instantiate (1 := 6%N); vm_compute; reflexivity
          | instantiate (1 := 7%N); vm_compute; reflexivity
          | instantiate (1 := 8%N); vm_compute; reflexivity
          | instantiate (1 := 9%N); vm_compute; reflexivity ]
  end.

#[local] Open Scope N_scope.

Definition triangular_number (n : N) := (n * (n + 1)) / 2.

Definition composable_pairs_step (n : N) (z : M.t N) : M.t N :=
  let next := triangular_number (N.pred n) in
  let go i rest :=
      let k j r :=
          let mor := next + i in
          let dom := triangular_number (j + i) + i in
          let cod := mor + j in
          M.add (cod, dom) mor r in
      N.peano_rect _ rest k (n - i) in
  N.peano_rect _ z go n.

Definition composable_pairs : N → M.t N :=
  N.peano_rect _ (M.empty _) (λ n, composable_pairs_step (N.succ n)).

(* The number of composable pairs, for objects N, is the tetrahedral_number *)
Definition tetrahedral_number (n : N) := (n * (n + 1) * (n + 2)) / 6.

#[local] Obligation Tactic :=
  simpl; intros; vm_compute triangular_number in *; reflect_on_maps.

Program Definition Zero  : Metacategory := {| pairs := composable_pairs 0 |}.
Program Definition One   : Metacategory := {| pairs := composable_pairs 1 |}.
Program Definition Two   : Metacategory := {| pairs := composable_pairs 2 |}.
Program Definition Three : Metacategory := {| pairs := composable_pairs 3 |}.
Program Definition Four  : Metacategory := {| pairs := composable_pairs 4 |}.

Ltac elimobj X :=
  exfalso;
  unfold composite in X; simpl in X;
  clear -X;
  vm_compute triangular_number in *;
  destruct_maps; lia.

Lemma peano_rect' : ∀ P : N → Type, P 0%N → (∀ n : N, P (N.succ n)) → ∀ n : N, P n.
Proof.
  intros.
  induction n using N.peano_rect.
  - apply X.
  - apply X0.
Defined.

Ltac reflect_on_pairs X Y F D C :=
  repeat (
    destruct X using peano_rect';
    first
      [ elimobj D | elimobj C
      | repeat (
          destruct Y using peano_rect';
          first
            [ elimobj D | elimobj C
            | repeat (
                destruct F using peano_rect';
                first
                  [ elimobj D | elimobj C
                  | intuition idtac
                  | reflect_on_pairs ]) ]) ]);
  intuition.

Require Import Category.Instance.Two.

Monomorphic Lemma object_Two_rect :
  ∀ (P : object Two → Type),
  (∀ x, obj_arr Two x = 0%N → P x) ->
  (∀ x, obj_arr Two x = 2%N → P x) ->
  ∀ (x : object Two), P x.
Proof.
  intros; destruct x.
  repeat (destruct obj_arr0 using peano_rect'; elimobj obj_def0 || auto).
Defined.

Program Definition Two_2_object (x : object Two) : TwoObj.
Proof.
  induction x using object_Two_rect.
  - exact TwoX.
  - exact TwoY.
Defined.

Monomorphic Lemma morphism_Two_rect :
  ∀ {x y : object Two} (P : morphism Two x y → Type),
  (∀ f, obj_arr Two x = 0%N → obj_arr Two y = 0%N → mor_arr Two f = 0%N → P f) ->
  (∀ f, obj_arr Two x = 0%N → obj_arr Two y = 2%N → mor_arr Two f = 1%N → P f) ->
  (∀ f, obj_arr Two x = 2%N → obj_arr Two y = 2%N → mor_arr Two f = 2%N → P f) ->
  ∀ (f : morphism Two x y), P f.
Proof.
  intros; destruct x, y, f.
  reflect_on_pairs obj_arr0 obj_arr1 mor_arr0 mor_dom0 mor_cod0.
Defined.

Program Definition Two_2_morphism (x y : object Two) (f : morphism Two x y) :
  TwoHom (Two_2_object x) (Two_2_object y).
Proof.
  induction f using morphism_Two_rect;
  destruct x, y, f; simpl in *; subst; simpl.
  - exact TwoIdX.
  - exact TwoXY.
  - exact TwoIdY.
Defined.

#[local] Obligation Tactic := intros.

Program Definition Two_to_Two : Category_from_Metacategory Two ⟶ _2 := {|
  fobj := Two_2_object;
  fmap := Two_2_morphism
|}.
Next Obligation.
  proper.
  destruct x0, y0; simpl in *; subst.
  apply f_equal.
  apply f_equal2;
  apply Eqdep_dec.UIP_dec;
  decide equality;
  apply N.eq_dec.
Qed.
Next Obligation.
  simpl.
  induction x using object_Two_rect;
  destruct x;
  simpl in H; subst;
  vm_compute; reflexivity.
Qed.
Next Obligation.
  simpl in *.
  induction f using morphism_Two_rect;
  induction g using morphism_Two_rect;
  repeat match goal with
  | [ X : object _ |- _ ] => destruct X
  | [ X : morphism _ _ _ |- _ ] => destruct X
  | [ H : _ _ _ = _ |- _ ] => simpl in H
  end; subst;
  (exfalso; simpl in *; discriminate)
    || (vm_compute; reflexivity).
Qed.

#[local] Obligation Tactic :=
  program_simpl;
  try solve [ subst; unfold composite; simpl;
              subst; vm_compute; reflexivity ].

Program Definition _2_Two_object (x : TwoObj) : object Two :=
  match x with
  | TwoX => {| obj_arr := 0%N; obj_def := _; obj_id  := _ |}
  | TwoY => {| obj_arr := 2%N; obj_def := _; obj_id  := _ |}
  end.
Next Obligation.
  unfold is_identity, defined, composite.
  simpl; split; intros; destruct H; subst;
  rewrite e; destruct_maps.
  unfold triangular_number in e0.
  rewrite N.div_same in e0; lia.
Defined.
Next Obligation.
  unfold is_identity, defined, composite;
  simpl; split; intros; destruct H; subst;
  rewrite e; destruct_maps.
  unfold triangular_number in e.
  rewrite N.div_same in e; lia.
Defined.

Program Definition _2_Two_morphism (x y : TwoObj) (f : TwoHom x y) :
  morphism Two (_2_Two_object x) (_2_Two_object y) :=
  match x as x' in TwoObj
  return x = x' → morphism Two (_2_Two_object x) (_2_Two_object y) with
  | TwoX => fun _ =>
    match y as y' in TwoObj
    return y = y' → morphism Two (_2_Two_object x) (_2_Two_object y) with
    | TwoX => fun _ => {| mor_arr := 0%N; mor_dom := _; mor_cod := _ |}
    | TwoY => fun _ => {| mor_arr := 1%N; mor_dom := _; mor_cod := _ |}
    end eq_refl
  | TwoY => fun _ =>
    match y as y' in TwoObj
    return y = y' → morphism Two (_2_Two_object x) (_2_Two_object y) with
    | TwoY => fun _ => {| mor_arr := 2%N; mor_dom := _; mor_cod := _ |}
    | TwoX => fun _ => !
    end eq_refl
  end eq_refl.
Next Obligation. inversion f. Defined.

#[local] Obligation Tactic := program_simpl.

Program Definition Two_from_Two : _2 ⟶ Category_from_Metacategory Two := {|
  fobj := _2_Two_object;
  fmap := _2_Two_morphism
|}.
Next Obligation. destruct x; reflexivity. Defined.
Next Obligation.
  destruct f; simpl;
  destruct x; simpl;
  spose (TwoHom_inv _ _ g) as H; subst;
  contradiction || reflexivity.
Defined.

Require Import Category.Instance.Cat.

#[export]
Program Instance Two_iso_2 : Category_from_Metacategory Two ≅ _2 := {
  to   := Two_to_Two;
  from := Two_from_Two
}.
Next Obligation.
  unshelve eexists; intros.
  - induction x; reflexivity.
  - induction f; reflexivity.
Qed.
Next Obligation.
  unshelve eexists; intros.
  - induction x using object_Two_rect;
    destruct x; simpl in H; subst.
    + isomorphism; simpl.
      * construct; [exact 0%N|..]; auto.
      * construct; [exact 0%N|..]; auto.
      * reflexivity.
      * reflexivity.
    + isomorphism; simpl.
      * construct; [exact 2%N|..]; auto.
      * construct; [exact 2%N|..]; auto.
      * reflexivity.
      * reflexivity.
  - induction f using morphism_Two_rect;
    destruct x, y, f;
    simpl in H, H0, H1; subst;
    vm_compute; reflexivity.
Qed.

#[local] Obligation Tactic := simpl; intros.

Lemma composable_pairs_succ n :
  composable_pairs (N.succ n)
    = composable_pairs_step (N.succ n) (composable_pairs n).
Proof.
  unfold composable_pairs.
  rewrite N.peano_rect_succ; reflexivity.
Qed.

Lemma composable_pairs_step_disjoint n m :
  P.Disjoint m (composable_pairs n) ->
  P.Disjoint (composable_pairs_step (N.succ n) m) (composable_pairs n).
Proof.
  intros.
  generalize dependent m.
  induction n using N.peano_rect; intros.
  - apply P.Disjoint_alt; intros.
    inversion H1.
  - rewrite composable_pairs_succ in H.
Abort.

Lemma composable_pairs_step_find n f g fg :
  M.find (f, g) (composable_pairs_step (N.succ n) (composable_pairs n)) = Some fg
    → M.find (f, g) (composable_pairs n) = Some fg ∨
       M.find (f, g) (composable_pairs_step (N.succ n) (M.empty _)) = Some fg.
Proof.
  generalize dependent fg.
  generalize dependent g.
  generalize dependent f.
  induction n using N.peano_rect; intros.
  - right; auto.
  - rewrite composable_pairs_succ in *.
Abort.

(*
Program Definition from_composablePairs (n : N) : Metacategory := {|
  pairs := composable_pairs n
|}.
Next Obligation.
  generalize dependent gh.
  generalize dependent fg.
  generalize dependent h.
  generalize dependent g.
  generalize dependent f.
  induction n using N.peano_rect; intros.
    cbn in H; discriminate.
Next Obligation.
  generalize dependent gh.
  generalize dependent fg.
  generalize dependent h.
  generalize dependent g.
  generalize dependent f.
  induction n; cbn; intros.
    discriminate.
Next Obligation.
  generalize dependent f.
  generalize dependent y.
  generalize dependent x.
  induction n; cbn; intros; eauto.
*)