(***********************************************************************)
(** * Definition of STLC *)
(***********************************************************************)

(** This file containes all of the definitions for a locally-nameless
    representation of a Curry-Style simply-typed lambda calculus.

    This file was generated via Ott from `stlc.ott` and then edited to
    include explanation about the definitions. As a result, it is gathers
    all of the STLC definitions in one place, but the associated
    exercises are found elsewhere in the tutorial.  You'll want to refer
    back to this file as you progress through the rest of the
    material. *)

Require Import Metalib.Metatheory.

(***********************************************************************)
(** * Syntax of STLC *)
(***********************************************************************)

(** We use a locally nameless representation for the simply-typed lambda
    calculus, where bound variables are represented as natural numbers
    (de Bruijn indices) and free variables are represented as [atom]s.

    The type [atom], defined in the Metatheory library, represents names.
    Equality on names is decidable, and it is possible to generate an
    atom fresh for any given finite set of atoms ([atom_fresh]).

    Note: the type [var] is notation for [atom].  *)

Inductive typ : Set :=  (*r types *)
 | typ_base : typ
 | typ_arrow (T1:typ) (T2:typ).

Inductive exp : Set :=  (*r expressions *)
 | var_b (_:nat)
 | var_f (x:var)
 | abs (e:exp)
 | app (e1:exp) (e2:exp).

(***********************************************************************)
(** * Substitution *)
(***********************************************************************)

(** Substitution replaces a free variable with a term.  The definition
    below is simple for two reasons:
      - Because bound variables are represented using indices, there
        is no need to worry about variable capture.
      - We assume that the term being substituted in is locally
        closed.  Thus, there is no need to shift indices when
        passing under a binder.
*)

(** The [Fixpoint] keyword defines a Coq function.  As all functions in
    Coq must be total.  The annotation [{struct e}] indicates the
    termination metric---all recursive calls in this definition are made
    to arguments that are structurally smaller than [e].

    Note also that [subst_exp] uses [x == y] for decidable equality.
    This operation is defined in the Metatheory library.  *)

Fixpoint subst_exp (u:exp) (y:var) (e:exp) {struct e} : exp :=
  match e with
  | (var_b n)   => var_b n
  | (var_f x)   => (if x == y then u else (var_f x))
  | (abs e1)    => abs (subst_exp u y e1)
  | (app e1 e2) => app (subst_exp u y e1) (subst_exp u y e2)
end.

(***********************************************************************)
(** * Free variables *)
(***********************************************************************)

(** The function [fv_exp], defined below, calculates the set of free
    variables in an expression.  Because we are using a locally
    nameless representation, where bound variables are represented as
    indices, any name we see is a free variable of a term.  In
    particular, this makes the [abs] case simple.
*)

Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (var_b nat)   => {}
  | (var_f x)   => {{x}}
  | (abs e)     => fv_exp e
  | (app e1 e2) => fv_exp e1 `union` fv_exp e2
end.

(** The type [vars] represents a finite set of elements of type [atom].
    The notations for the finite set definitions (empty set `{}`,
    singleton `{{x}}` and union `\u`) is also defined in the Metatheory
    library.  *)

(***********************************************************************)
(** * Opening *)
(***********************************************************************)

(** Opening replaces an index with a term.  It corresponds to informal
    substitution for a bound variable, such as in the rule for beta
    reduction.  Note that only "dangling" indices (those that do not
    refer to any abstraction) can be opened.  Opening has no effect for
    terms that are locally closed.

    Natural numbers are just an inductive datatype with two constructors:
    [O] (as in the letter 'oh', not 'zero') and [S], defined in
    Coq.Init.Datatypes.  Coq allows literal natural numbers to be written
    using standard decimal notation, e.g., 0, 1, 2, etc.  The function
    [lt_eq_lt_dec] compares its two arguments for ordering.

    We do not assume that zero is the only unbound index in the term.
    Consequently, we must substract one when we encounter other unbound
    indices (i.e. the [inright] case).

    However, we do assume that the argument [u] is locally closed.  This
    assumption simplifies the implementation since we do not need to
    shift indices in [u] when passing under a binder. *)

Fixpoint open_exp_wrt_exp_rec (k:nat) (u:exp) (e:exp) {struct e}: exp :=
  match e with
  | (var_b n) =>
      match lt_eq_lt_dec n k with
        | inleft (left _)  => var_b n
        | inleft (right _) => u
        | inright _        => var_b (n - 1)
      end
  | (var_f x)   => var_f x
  | (abs e)     => abs (open_exp_wrt_exp_rec (S k) u e)
  | (app e1 e2) => app (open_exp_wrt_exp_rec k u e1)
                      (open_exp_wrt_exp_rec k u e2)
end.

Definition open_exp_wrt_exp e u := open_exp_wrt_exp_rec 0 u e.

(***********************************************************************)
(** * Notations *)
(***********************************************************************)

(** Many common applications of opening replace index zero with an
    expression or variable.  The following definition provides a
    convenient shorthand for such uses.  Note that the order of
    arguments is switched relative to the definition above.  For
    example, [(open e x)] can be read as "substitute the variable [x]
    for index [0] in [e]" and "open [e] with the variable [x]."
*)

Module StlcNotations.
Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0) : exp_scope.
Notation open e1 e2     := (open_exp_wrt_exp e1 e2).
Notation "e ^ x"        := (open_exp_wrt_exp e (var_f x)) : exp_scope.
End StlcNotations.
Import StlcNotations.
Open Scope exp_scope.

(***********************************************************************)
(** * Local closure *)
(***********************************************************************)

(** Recall that [exp] admits terms that contain unbound indices.  We say
    that a term is locally closed when no indices appearing in it are
    unbound.  The proposition [lc_exp e] holds when an expression [e] is
    locally closed.

    The inductive definition below formalizes local closure such that the
    resulting induction principle serves as the structural induction
    principle over (locally closed) expressions.  In particular, unlike
    induction for type [exp], there are no cases for bound variables.
    Thus, the induction principle corresponds more closely to informal
    practice than the one arising from the definition of pre-terms.  *)

Inductive lc_exp : exp -> Prop :=
 | lc_var_f : forall (x:var),
     lc_exp (var_f x)
 | lc_abs : forall (e:exp),
      (forall x , lc_exp (open e (var_f x)))  ->
     lc_exp (abs e)
 | lc_app : forall (e1 e2:exp),
     lc_exp e1 ->
     lc_exp e2 ->
     lc_exp (app e1 e2).

(***********************************************************************)
(** * Typing contexts *)
(***********************************************************************)

(** We represent typing contexts as association lists (lists of pairs of
    keys and values) whose keys are [atom]s.
*)

Definition ctx : Set := list (atom * typ).

(** For STLC, contexts bind [atom]s to [typ]s.

    Lists are defined in Coq's standard library, with the constructors
    [nil] and [cons].  The list library includes the [::] notation for
    cons as well as standard list operations such as append, map, and
    fold. The infix operation [++] is list append.

    The Metatheory library extends this reasoning by instantiating the
    AssocList library to provide support for association lists whose keys
    are [atom]s.  Everything in this library is polymorphic over the type
    of objects bound in the environment.  Look in AssocList.v for
    additional details about the functions and predicates that we mention
    below.  *)

(***********************************************************************)
(** * Typing relation *)
(***********************************************************************)

(** The definition of the typing relation is straightforward.  In
    order to ensure that the relation holds for only well-formed
    environments, we check in the [typing_var] case that the
    environment is [uniq].  The structure of typing derivations
    implicitly ensures that the relation holds only for locally closed
    expressions.

    Finally, note the use of cofinite quantification in
    the [typing_abs] case.
*)

Inductive typing : ctx -> exp -> typ -> Prop :=
 | typing_var : forall (G:ctx) (x:var) (T:typ),
     uniq G ->
     binds x T G  ->
     typing G (var_f x) T
 | typing_abs : forall (L:vars) (G:ctx) (T1:typ) (e:exp) (T2:typ),
     (forall x , x `notin` L -> typing ([(x,T1)] ++ G) (e ^ x) T2)  ->
     typing G (abs e) (typ_arrow T1 T2)
 | typing_app : forall (G:ctx) (e1 e2:exp) (T2 T1:typ),
     typing G e1 (typ_arrow T1 T2) ->
     typing G e2 T1 ->
     typing G (app e1 e2) T2 .

(***********************************************************************)
(** * Values and Small-step Evaluation *)
(***********************************************************************)

(** Finally, we define values and a call-by-name small-step evaluation
    relation. In STLC, abstractions are the only value. *)

Definition is_value (e : exp) : Prop :=
  match e with
  | abs _   => True
  | _       => False
  end.

(** For [step_beta], note that we use [open_exp_wrt_exp] instead of
    substitution --- no variable names are involved.

    Note also the hypotheses in [step] that ensure that the relation holds
    only for locally closed terms.  *)

Inductive step : exp -> exp -> Prop :=
 | step_beta : forall (e1 e2:exp),
     lc_exp (abs e1) ->
     lc_exp e2 ->
     step (app  (abs e1) e2)  (open e1 e2)
 | step_app : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (app e1 e2) (app e1' e2).

Hint Constructors typing step lc_exp.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** From verify.rwth-aachen.de/giesl/papers/ibn96-30.ps

    orig. algo from https://arxiv.org/ftp/cs/papers/9301/9301103.pdf

   type Ω = α | ω of Ω * Ω * Ω

   let rec nm e = match e with
     | α                => α
     | ω (α,y,z)        => ω (α,nm y,nm z)
     | ω (ω(a,b,c),y,z) => nm (ω (a,nm(ω(b,y,z)),nm(ω(c,y,z)))

  We simulate the following Inductive/Recursive definition

  Inductive 𝔻 : Ω -> Prop :=
    | d_nm_0 : 𝔻 α
    | d_nm_1 : forall y z, 𝔻 y -> 𝔻 z -> 𝔻 (ω α y z)
    | d_nm_2 : forall a b c y z (Db : 𝔻 (ω b y z)) (Dc : 𝔻 (ω c y z)),
\                      𝔻 (ω a (nm (ω b y z) D1) (nm (ω c y z) D2))
\                   -> 𝔻 (ω (ω a b c) y z)
  with Fixpoint nm e (De : 𝔻 e) : Ω :=
    match De with
      | d_nm_0 => α
      | d_nm_1 y z Dy Dz => ω α (nm y Dy) (nm z Dz)
      | d_nm_2 a b c y z Db Dc Da => nm (ω a (nm (ω b y z) Db) (nm (ω c y z) Dc)) Da
    end.
*)

Require Import Arith Lia Wellfounded Extraction.

Require Import measure_ind.

Tactic Notation "eq" "goal" "with" hyp(H) :=
  match goal with
    |- ?b => match type of H with ?t => replace b with t; auto end
  end.

Set Implicit Arguments.

Inductive cexpr : Set := At : cexpr | If : cexpr -> cexpr -> cexpr -> cexpr.

Notation α := At.
Notation ω := If.
Notation Ω := cexpr.

Section nm_def.

  Reserved Notation "x '~~>' y" (at level 70, no associativity).

  Inductive 𝔾 : Ω -> Ω -> Prop :=
    | in_gnm_0 :           α ~~> α

    | in_gnm_1 y ny z nz :
                         y   ~~>     ny
                  ->       z ~~>        nz
                  -> ω α y z ~~> ω α ny nz

    | in_gnm_2 : forall a b c y z nb nc na,
                             ω b y z ~~> nb
                  ->         ω c y z ~~> nc
                  ->       ω a nb nc ~~> na
                  -> ω (ω a b c) y z ~~> na
  where "x ~~> y" := (𝔾 x y).

  Ltac inv_ind := match goal with
      | H: forall x : _, ?t ~~> x -> ?y = x,
        G: ?t ~~> ?z
       |- _ => apply H in G; subst
    end.

  Local Fact 𝔾_fun e n1 n2 : e ~~> n1 -> e ~~> n2 -> n1 = n2.
  Proof.
    intros H; revert H n2.
    induction 1 as [
                   | y ny z nz H1 IH1 H2 IH2
                   | u v w y z na nb nc H1 IH1 H2 IH2 H3 IH3 ]; inversion 1; subst; auto.
    + f_equal; auto.
    + repeat inv_ind; auto.
  Qed.

  Unset Elimination Schemes.

  Inductive d_nm : Ω -> Prop :=
    | in_dnm_0 :                   d_nm α
    | in_dnm_1 : forall y z,       d_nm y
                                -> d_nm z
                                -> d_nm (ω α y z)
    | in_dnm_2 : forall a b c y z,
                                   d_nm (ω b y z)
                                -> d_nm (ω c y z)
                 -> (forall nb nc, ω b y z ~~> nb
                                -> ω c y z ~~> nc
                                -> d_nm (ω a nb nc))
                                -> d_nm (ω (ω a b c) y z).

  Notation 𝔻 := d_nm.

  Set Elimination Schemes.

  Section nm_def.

    Let nm_full : forall e, 𝔻 e -> { n | e ~~> n }.
    Proof.
      refine(fix loop e De := match e as e' return 𝔻 e' -> sig (𝔾 e') with
        | α               => fun _ =>
                         exist _ α _

        | ω α y z         => fun D =>
          let (ny,Dy) := loop y _ in
          let (nz,Dz) := loop z _ in
                         exist _ (ω α ny nz) _

        | ω (ω a b c) y z => fun D =>
          let (nb,Db) := loop (ω b y z)   _ in
          let (nc,Dc) := loop (ω c y z)   _ in
          let (na,Da) := loop (ω a nb nc) _ in
                         exist _ na _
      end De).
      2-3,5-7: inversion D; auto.
      + constructor 1.
      + constructor 2; auto.
      + constructor 3 with nb nc; auto.
    Qed.

    Definition nm e (D : 𝔻 e) := proj1_sig (@nm_full e D).

    Fact nm_spec e D : 𝔾 e (@nm e D).
    Proof. apply (proj2_sig _). Qed.

  End nm_def.

  Arguments nm e D : clear implicits.

  Fact d_nm_0 : 𝔻 α.
  Proof. constructor; auto. Qed.

  Fact d_nm_1 y z : 𝔻 y -> 𝔻 z -> 𝔻 (ω α y z).
  Proof. constructor; auto. Qed.

  Fact d_nm_2 a b c y z Db Dc : 𝔻 (ω a (nm (ω b y z) Db) (nm (ω c y z) Dc))
                             -> 𝔻 (ω (ω a b c) y z).
  Proof.
    constructor 3; auto.
    intros; eq goal with H; do 2 f_equal;
    apply 𝔾_fun with (1 := nm_spec _); trivial.
  Qed.

  Hint Resolve nm_spec.

  Section d_nm_rect.

    Variables (P : forall e, 𝔻 e -> Type)
              (HPi : forall e D1 D2, @P e D1 -> @P e D2)
              (HP0 : P d_nm_0)
              (HP1 : forall y z D1 (_ : P D1) D2 (_ : P D2), P (@d_nm_1 y z D1 D2))
              (HP2 : forall a b c y z D1 (_ : P D1) D2 (_ : P D2) D3 (_ : P D3), P (@d_nm_2 a b c y z D1 D2 D3)).

    Fixpoint d_nm_rect e (De : 𝔻 e) : @P e De.
    Proof.
      destruct e as [ | [ | a b c ] y z ].
      + apply HPi with (1 := HP0).
      + refine (HPi _ (HP1 (d_nm_rect y _)
                           (d_nm_rect z _)));
          inversion De; trivial.
      + assert (𝔻 (ω b y z)) as Db by (inversion De; trivial).
        assert (𝔻 (ω c y z)) as Dc by (inversion De; trivial).
        refine (HPi _ (HP2 (d_nm_rect (ω b y z) Db)
                           (d_nm_rect (ω c y z) Dc)
                           (d_nm_rect (ω a _ _) _))). (** dependancies here *)
        inversion De; auto.
    Qed.

  End d_nm_rect.

  Definition d_nm_ind (P : forall e, 𝔻 e -> Prop) := @d_nm_rect P.

  Fact nm_pirr e D1 D2 : nm e D1 = nm e D2.
  Proof. apply 𝔾_fun with e; auto. Qed.

  Fact nm_fix_0 : nm α d_nm_0 = α.
  Proof. apply 𝔾_fun with α; [ | constructor ]; auto. Qed.

  Fact nm_fix_1 y z D1 D2 : nm (ω α y z) (d_nm_1 D1 D2) = ω α (nm y D1) (nm z D2).
  Proof. apply 𝔾_fun with (ω α y z); [ | constructor ]; auto. Qed.

  Fact nm_fix_2 u v w y z D1 D2 D3 :
            nm (ω (ω u v w) y z) (d_nm_2 D1 D2 D3)
          = nm (ω u (nm (ω v y z) D1) (nm (ω w y z) D2)) D3.
  Proof.
    apply 𝔾_fun with (ω (ω u v w) y z); auto.
    constructor 3 with (nm _ D1) (nm _ D2); auto.
  Qed.

End nm_def.

Arguments nm e D : clear implicits.

Create HintDb nm_fix_db.
Hint Rewrite nm_fix_0 nm_fix_1 nm_fix_2 : nm_fix_db.

Ltac nm_pirr :=
  match goal with
    [ |- context f [nm ?e _] ] =>
    match goal with
      _: context[nm e ?D] |- _ => rewrite (nm_pirr _ D)
    end
  end.

Ltac nm_rewrite := autorewrite with nm_fix_db.

Tactic Notation "nm" "auto" := try nm_pirr; nm_rewrite; auto.

Check nm_spec.
Print Assumptions nm_spec.

Recursive Extraction nm.

(* Now we show the partial correctness of nm,
   independently of its termination *)

(** normal forms only have atoms as boolean condition
    ie. b in if b then _ else _ *)

Inductive normal : Ω -> Prop :=
  | in_normal_0 :             normal α
  | in_normal_1 : forall y z, normal y
                           -> normal z
                           -> normal (ω α y z).

Notation ℕ := normal.

(** nm produces normal forms *)

Theorem nm_normal e D : ℕ (nm e D).
Proof.
  induction D.
  all: nm auto; constructor; auto.
Qed.

(** equiv is the congruence generated by

   ω (ω a b c) y z ~e ω a (ω b y z) (ω c y z)

  *)

Reserved Notation "x '~Ω' y" (at level 70, no associativity).

Inductive equiv : Ω -> Ω -> Prop :=
  | in_eq_0 : forall u v w y z, ω (ω u v w) y z ~Ω ω u (ω v y z) (ω w y z)
  | in_eq_1 : forall x x' y y' z z', x ~Ω x' -> y ~Ω y' -> z ~Ω z'-> ω x y z ~Ω ω x' y' z'
  | in_eq_2 : α ~Ω α
  | in_eq_3 : forall x y z, x ~Ω y -> y ~Ω z -> x ~Ω z
where "x ~Ω y" := (equiv x y).

Hint Constructors equiv.

Fact equiv_refl e : e ~Ω e.   Proof. induction e; auto. Qed.

Hint Resolve equiv_refl.

Notation equiv_trans := in_eq_3.

(** nm preserves equivalence *)

Fact nm_equiv e D : e ~Ω nm e D.
Proof.
  induction D as [ e D1 D2
                 |
                 | y z D1 ID1 D2 ID2
                 | u v w y z D1 ID1 D2 ID2 D3 ID3 ].
  all: nm auto.
  apply equiv_trans with (2 := ID3),
        equiv_trans with (1 := in_eq_0 _ _ _ _ _); auto.
Qed.

(** Using the simulated IR definition of

            𝔻 : Ω -> Prop and nm : forall e, 𝔻 e -> Ω

    we show totality of 𝔻:

      a) we define a measure [.] : Ω -> nat by structural induction

      b) we show that nm preserves the measure, ie

           forall e (De : 𝔻 e), [nm e De] <= [e]

         by dependent induction on De : 𝔻 e

      c) we show that 𝔻 is total

           forall e, 𝔻 e

         by induction on [e] : nat
*)

Section ce_size.

  Let c x y z := x * (1+y+z).

  (* The next properties are sufficient for the measure *)

  Let c_mono x x' y y' z z' : x <= x' -> y <= y' -> z <= z' -> c x y z <= c x' y' z'.
  Proof. intros; simpl; apply mult_le_compat; lia. Qed.

  Let c_smono_1 x x' y z : x < x' -> c x y z < c x' y z.
  Proof. intro; simpl; apply mult_lt_compat_r; lia. Qed.

  Let c_inc_1 x y z : x <= c x y z.
  Proof. unfold c; rewrite <- Nat.mul_1_r at 1; apply mult_le_compat; lia. Qed.

  Let c_sinc_1 x y z : 0 < x -> 0 < y + z -> x < c x y z.
  Proof. intros ? ?; unfold c; rewrite <- Nat.mul_1_r at 1; apply mult_lt_compat_l; lia. Qed.

  Let c_sinc_2 x y z : 0 < x -> y < c x y z.
  Proof. intros ?; unfold c, lt; rewrite <- Nat.mul_1_l at 1; apply mult_le_compat; lia. Qed.

  Let c_sinc_3 x y z : 0 < x -> z < c x y z.
  Proof. intros ?; unfold c, lt; rewrite <- Nat.mul_1_l at 1; apply mult_le_compat; lia. Qed.

  Let c_special a u v y z : 0 < a -> 0 < y + z -> c a (c u y z) (c v y z) < c (c a u v) y z.
  Proof.
    unfold c; intros ? ?.
    rewrite <- mult_assoc.
    apply mult_lt_compat_l; auto.
    simpl.
    generalize (S (y + z)); intros n.
    rewrite mult_plus_distr_r; lia.
  Qed.

  Reserved Notation "'[' e ']'" (at level 0).

  (** This is the decreasing measure *)

  Fixpoint ce_size e :=
    match e with
      | α => 1
      | ω x y z => c [x] [y] [z]
    end
  where "[ e ]" := (ce_size e).

  (* Some elementary properties of the measure *)

  Local Fact ce_size_mono x x' y y' z z' :
     [x] <= [x'] -> [y] <= [y'] -> [z] <= [z'] -> [ω x y z] <= [ω x' y' z'].
  Proof. apply c_mono. Qed.

  Local Fact ce_size_smono_1 x x' y z : [x] < [x'] -> [ω x y z] < [ω x' y z].
  Proof. apply c_smono_1. Qed.

  Local Fact ce_size_ge_1 e : 1 <= [e].
  Proof.
    induction e as [ | x Hx y _  z _ ]; auto.
    apply le_trans with (1 := Hx), c_inc_1.
  Qed.

  Hint Resolve ce_size_ge_1.

  Local Fact ce_size_sub_1 x y z : [x] < [ω x y z].
  Proof. simpl; apply c_sinc_1; auto; generalize (ce_size_ge_1 y); lia. Qed.

  Local Fact ce_size_sub_2 x y z : [y] < [ω x y z].
  Proof. simpl; apply c_sinc_2; auto. Qed.

  Local Fact ce_size_sub_3 x y z : [z] < [ω x y z].
  Proof. simpl; apply c_sinc_3; auto. Qed.

  (* The special properties that makes it a suitable measure for induction *)

  Local Fact ce_size_special a u v y z : [ω a (ω u y z) (ω v y z)] < [ω (ω a u v) y z].
  Proof. simpl; apply c_special; auto; generalize (ce_size_ge_1 y); lia. Qed.

End ce_size.

(* No we finish with the termination/totality of nm *)

Section d_nm_total.

  Notation 𝔻 := d_nm.
  Notation "'[' e ']'" := (ce_size e) (at level 0).

  Hint Resolve ce_size_sub_2 ce_size_sub_3 ce_size_mono ce_size_smono_1.

  (** nm preserves the measure *)

  Local Fact nm_dec e D : [nm e D] <= [e].
  Proof.
    induction D as [ e D1 D2 | | y z D1 ID1 D2 ID2 | u v w y z D1 ID1 D2 ID2 D3 ID3 ]; nm auto.
    apply le_trans with (1 := ID3),
          le_trans with (2 := ce_size_special _ _ _ _ _); auto.
  Qed.

  Hint Resolve nm_dec.

  (** Termination/totality by induction on [e] *)

  Theorem d_nm_total e : 𝔻 e.
  Proof.
    induction on e as IHe with measure [e].
    destruct e as [ | [ | u v w ] y z ].
    + apply d_nm_0.
    + apply d_nm_1; apply IHe; simpl; lia.
    + assert (D1 : 𝔻 (ω v y z)) by auto.
      assert (D2 : 𝔻 (ω w y z)) by auto.
      apply d_nm_2 with D1 D2.
      apply IHe, le_lt_trans with (2 := ce_size_special _ _ _ _ _); auto.
  Qed.

End d_nm_total.

(** We can finish with a fully specified term defining a total function
    which computes a normal form *)

Hint Resolve nm_equiv nm_normal.

Definition nm_total e : { ne | e ~Ω ne /\ ℕ ne }.
Proof.
  exists (nm _ (d_nm_total e)); auto.
Defined.

Extraction Inline nm.

Recursive Extraction nm_total.

Print inhabited.


Inductive pos : Set :=
| S1 : pos
| S : pos -> pos.

Fixpoint plus(n m:pos) : pos :=
  match n with
    | S1 => S m
    | S l => S (plus l  m)
  end.

Infix "+" := plus.

Lemma succ_equal : forall n m : pos, (n = m) -> (S n = S m).
Proof.
  intros.
  induction n.
  rewrite <- H.
  auto.
  rewrite H.
  auto.
Qed.

Theorem plus_assoc : forall n m p, n + (m + p) = (n + m) + p.
Proof.
  intros.
  induction n.
  simpl.
  auto.
  simpl.
  apply succ_equal.
  auto.
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) (x : natural) (lf1 : natural) : natural :=
  mult (Succ y) (Succ x).


(** 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) (x : natural) (lf2 : natural) : natural :=
  mult (Succ x) (Succ y).


(** 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 (lf2 : natural) (lf1 : natural) (y : natural) (x : natural)
  : natural := mult (Succ y) x.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Crypto.Util.ZUtil.Land.
Require Import Crypto.Util.ZUtil.Hints.Core.
Local Open Scope bool_scope. Local Open Scope Z_scope.

Module Z.
  Lemma fold_right_land_m1_cps v ls
    : fold_right Z.land v ls
      = Z.land (fold_right Z.land (-1) ls) v.
  Proof.
    induction ls as [|?? IH]; cbn [fold_right].
    { now rewrite Z.land_m1'_l. }
    { rewrite <- !Z.land_assoc, IH; reflexivity. }
  Qed.

  Lemma fold_right_land_ones_id sz ls
    : Z.land (fold_right Z.land (Z.ones sz) ls) (Z.ones sz)
      = Z.land (fold_right Z.land (-1) ls) (Z.ones sz).
  Proof.
    rewrite fold_right_land_m1_cps, <- Z.land_assoc, Z.land_diag.
    reflexivity.
  Qed.
End Z.


Require Export P06.

Theorem plus_lt : forall n1 n2 m,
  n1 + n2 < m ->
  n1 < m /\ n2 < m.
Proof.
  unfold lt. intros n1 n2 m H. induction H.
  - split.
    + apply le_n_S. induction n1.
      * simpl. apply le_0_n.
      * simpl. apply le_n_S. assumption.
    + apply le_n_S. induction n1.
      * simpl. apply le_n.
      * simpl. apply le_S. assumption.
  - destruct IHle. split.
    + apply le_S. assumption.
    + apply le_S. assumption.
Qed.


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

(**
A sub category of C is a category whose objects are a subset (here we ues
subset types, i.e., sig) of objects of C and whose arrows are a subset of
arrows of C.

Here, we define a subcategory using two functions Obj_Cri : Obj C -> Prop
which defines the objects of subcategory and
Hom_Cri : ∀ (a b : Obj) -> Hom a b -> Prop
which defines the arrows of subcategory.
In other words, Obj_Cri and Hom_Cri are respectively cirteria for objects and
arrows being in the sub category. We furthermore, require that the Hom_Cri
provides that identity arrows of all objects in the subcategory are part of
the arrows of the subcategory. Additionally, For ant two composable arrow that
are in the subcategory, their composition must also be in the subcategory.
*)
Section SubCategory.
  Context (C : Category)
          (Obj_Cri : Obj → Type)
          (Hom_Cri : ∀ a b, (a --> b)%morphism → Prop).

  Arguments Hom_Cri {_ _} _.

  Context (Hom_Cri_id : ∀ a, Obj_Cri a → Hom_Cri (id a))
          (Hom_Cri_compose :
             ∀ a b c (f : (a --> b)%morphism)
               (g : (b --> c)%morphism),
               Hom_Cri f → Hom_Cri g → Hom_Cri (g ∘ f)).

  Arguments Hom_Cri_id {_} _.
  Arguments Hom_Cri_compose {_ _ _ _ _} _ _.

  Local Obligation Tactic := idtac.

  Program Definition SubCategory : Category :=
  {|
    Obj := sigT Obj_Cri;

    Hom :=
      fun a b =>
        sig (@Hom_Cri (projT1 a) (projT1 b));

    compose :=
      fun _ _ _ f g =>
        exist _ _
              (Hom_Cri_compose (proj2_sig f) (proj2_sig g));

    id :=
      fun a =>
        exist _ _ (Hom_Cri_id (projT2 a))
  |}.

  Next Obligation.
    intros.
    apply sig_proof_irrelevance; simpl; abstract auto.
  Qed.

  Next Obligation.
    symmetry.
    apply SubCategory_obligation_1.
  Qed.

  Local Hint Extern 3 => simpl : core.

  Local Obligation Tactic := basic_simpl; auto.

  Solve Obligations.

End SubCategory.

(**
A wide subcategory of C is a subcategory of C that has all the objects of C but
not necessarily all its arrows.
*)
Notation Wide_SubCategory C Hom_Cri := (SubCategory C (fun _ => True) Hom_Cri).

(**
A Full subcategory of C is a subcategory of C that for any pair of objects of
the category that it has, it has all the arrows between them. In practice, we
construct a full subcategory by only expecting an object criterion and setting
the arrow criterrion to accept all arrows.
*)
Notation Full_SubCategory C Obj_Cri :=
  (SubCategory C Obj_Cri (fun _ _ _ => True) (fun _ _ => I) (fun _ _ _ _ _ _ _ => I)).


Require Export Logic.

Definition relation (X: Type) := X->X->Prop.

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros.
  inversion H. inversion H0.
  reflexivity.
Qed.

Theorem total_relation_not_partial :
  ~ partial_function total_relation.
Proof.
  unfold not.
  unfold partial_function.
  intros.
  assert (0 = 1) as Nonsense.
  apply H with 0.
  apply tl.
  apply tl.
  inversion Nonsense.
Qed.

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.  Qed.

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  Case "le_n". apply Hnm.
  Case "le_S". apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
    apply le_S. apply le_n.
    apply H.  Qed.

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m.
  split.
  (* -> *)
  intros.
  induction H.
  apply rt_refl.
  apply rt_trans with m.
  apply IHle.
  apply rt_step.
  apply nn.

  (* <- *)
  intros.
  induction H.
  inversion H.
  apply le_S. apply le_n.
  apply le_n.
  apply le_trans with y.
  tauto. tauto.
Qed.

Inductive refl_step_closure {X:Type} (R: relation X) : relation X :=
  | rsc_refl  : forall (x : X), refl_step_closure R x x
  | rsc_step : forall (x y z : X),
                    R x y ->
                    refl_step_closure R y z ->
                    refl_step_closure R x z.

Tactic Notation "rt_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rt_step" | Case_aux c "rt_refl"
  | Case_aux c "rt_trans" ].

Tactic Notation "rsc_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rsc_refl" | Case_aux c "rsc_step" ].

Theorem rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> refl_step_closure R x y.
Proof.
  intros.
  apply rsc_step with y.
  apply H.
  apply rsc_refl.
Qed.

Theorem rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      refl_step_closure R x y  ->
      refl_step_closure R y z ->
      refl_step_closure R x z.
Proof.
  intros.
  induction H.
  apply H0.
  apply rsc_step with y.
  apply H.
  apply IHrefl_step_closure.
  apply H0.
Qed.

Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> refl_step_closure R x y.
Proof.
  intros.
  split.
  (* -> *)
  intros.
  induction H.
  apply rsc_step with y.
  apply H.

  apply rsc_refl.
  apply rsc_refl.

  apply rsc_trans with y.
  auto. auto.

  (* <- *)
  intros.
  induction H.
  apply rt_refl.
  apply rt_trans with y.
  apply rt_step. apply H.
  apply IHrefl_step_closure.
Qed.


(****************** One-step Reduction **************)

Inductive s1: Spec -> Tape -> State -> Tape -> State -> Prop :=

(* RIGHT move *)

 | s1R: forall T:Spec, forall p q:State,
        forall l r:HTape,
        (tr T p (read (pair l r))) = (Some (q, R)) ->
        (s1 T (pair l r) p
              (pair (Cons (hd r) l) (tl r)) q)

(* LEFT move *)

 | s1L: forall T:Spec, forall p q:State,
        forall l r:HTape,
        (tr T p (read (pair l r))) = (Some (q, L)) ->
        (s1 T (pair l r) p
              (pair (tl l) (Cons (hd l) r)) q)

(* WRITE move *)

 | s1W: forall T:Spec, forall p q:State,
        forall l r:HTape, forall a:Sym,
        (tr T p (read (pair l r))) = (Some (q, (W a))) ->
        (s1 T (pair l r) p
              (pair l (Cons a (tl r))) q).

(****************** Finite Reduction *********************)

Inductive sf: Spec -> Tape -> State -> Tape -> State -> Prop :=

(* HALT move *)

   sf0: forall T:Spec, forall q:State, forall t:Tape,
        (sf T t q t q)

(* inductive moves *)

 | sfI: forall T:Spec, forall p q i:State, forall s t u:Tape,
        (s1 T s p u i) -> (sf T u i t q) ->
        (sf T s p t q).

(****************** Infinite Reduction *********************)

CoInductive si: Spec -> Tape -> State -> Prop :=

(* coinductive moves *)

 | siC: forall T:Spec, forall p q:State, forall s t:Tape,
        (s1 T s p t q) -> (si T t q) ->
        (si T s p).


Require Import Arith.

Fixpoint sum_odd(n:nat) : nat :=
  match n with
    | 0 => 0
    | S m => 1 + m + m + sum_odd m
  end.

Goal forall n, sum_odd n = n * n.
Proof.
  intros.
  induction n.
  simpl.
  ring.
  simpl.
  rewrite <- (eq_S (n + n + sum_odd n) (n + n * S n)).
  ring.
  rewrite IHn.
  ring.
Qed.


(* assumption *)
Theorem p_implies_p : forall P : Prop,
  P -> P.
Proof.
  intros P P_holds.
  assumption.
Qed.

(* apply *)
Theorem modus_ponens : forall (P Q : Prop),
  (P -> Q) -> P -> Q.
Proof.
  intros P Q P_implies_Q P_holds.
  apply P_implies_Q in P_holds.
  assumption.
Qed.


Require Import XR_Rmax.
Require Import XR_Rle_dec.
Require Import XR_Rle_antisym.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Rmax_right : forall x y, x <= y -> Rmax x y = y.
Proof.
  intros x y h.
  unfold Rmax.
  destruct (Rle_dec x y) as [ hl | hr ].
  { reflexivity. }
  {
    apply Rle_antisym.
    { exact h. }
    {
      left.
      apply Rnot_le_lt.
      exact hr.
    }
  }
Qed.


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

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                                 Zmult.v                                  *)
(****************************************************************************)
Require Export Lci.
Require Export misc.
Require Export Arith.
Require Export Nat_complements.
Require Export groups.
Require Export rings.
Require Export Zbase.
Require Export Z_succ_pred.
Require Export Zadd.

(* Multiplication on Z, (Z, +, *, 0, 1) is a unitary commutative ring *)

(*Recursive Definition multZ : Z -> Z -> Z :=
        OZ      y  => OZ
 | (pos O)      y  => y
 | (pos (S n1)) y  => (addZ (multZ (pos n1) y) y)
 | (neg O)      y  => (oppZ y)
 | (neg (S n1)) y  => (addZ (multZ (neg n1) y) (oppZ y)).
*)

Fixpoint multpos (x2 : Z) (n : nat) {struct n} : Z :=
  match n with
  | O => x2
  | S n0 => addZ (multpos x2 n0) x2
  end.

Fixpoint multneg (x2 : Z) (n : nat) {struct n} : Z :=
  match n with
  | O => oppZ x2
  | S n0 => addZ (multneg x2 n0) (oppZ x2)
  end.

Definition multZ (x1 x2 : Z) :=
  match x1 with
  | OZ => OZ
  | pos n => multpos x2 n
  | neg n => multneg x2 n
  end.

Lemma multZ_eq1 : forall n : Z, multZ OZ n = OZ.
Proof.
 auto.
Qed.

Lemma multZ_eq2 : forall n : Z, multZ (pos 0) n = n.
Proof.
 auto.
Qed.

Lemma multZ_eq3 :
 forall (n1 : nat) (n : Z), multZ (pos (S n1)) n = addZ (multZ (pos n1) n) n.
Proof.
 auto.
Qed.

Lemma multZ_eq4 : forall n : Z, multZ (neg 0) n = oppZ n.
Proof.
 auto.
Qed.

Lemma multZ_eq5 :
 forall (n1 : nat) (n : Z),
 multZ (neg (S n1)) n = addZ (multZ (neg n1) n) (oppZ n).
Proof.
 auto.
Qed.

(*******************)
Lemma tech_mult_posZ :
 forall (x : nat) (y : Z), multZ (pos (S x)) y = addZ (multZ (pos x) y) y.

Proof multZ_eq3.

(*******************)
Lemma tech_mult_negZ :
 forall (x : nat) (y : Z),
 multZ (neg (S x)) y = addZ (multZ (neg x) y) (oppZ y).

Proof multZ_eq5.

(*****************)
Lemma mult_succZ_l : forall x y : Z, multZ (succZ x) y = addZ (multZ x y) y.

intros; elim x.
(* OZ *)
simpl in |- *; reflexivity.
(* pos n *)
intros; simpl in |- *; reflexivity.
(* neg n *)
intros; elim n.
(* neg O *)
simpl in |- *; symmetry  in |- *.
elim (addZ_opposite y I); intros. elim H0; intros; elim H2; intros; exact H4.
(* neg (S n0) *)
intros; unfold succZ in |- *; rewrite (tech_mult_negZ n0 y).
elim (addZ_associativity (multZ (neg n0) y) (oppZ y) y).
elim (addZ_opposite y I); intros. elim H1; intros; elim H3; intros. rewrite H5.
symmetry  in |- *; exact (add_OZ (multZ (neg n0) y)).
Qed.

(*****************)
Lemma mult_predZ_l :
 forall x y : Z, multZ (predZ x) y = addZ (multZ x y) (oppZ y).

Proof.
intros; elim x.
(* OZ *)
simpl in |- *; reflexivity.
(* pos n *)
intros; elim n.
(* pos O *)
simpl in |- *; symmetry  in |- *.
elim (addZ_opposite y I); intros. elim H0; intros; elim H2; intros; exact H3.
(* pos (S n0) *)
intros; unfold predZ in |- *; rewrite (tech_mult_posZ n0 y).
elim (addZ_associativity (multZ (pos n0) y) y (oppZ y)).
elim (addZ_opposite y I); intros. elim H1; intros; elim H3; intros; rewrite H4.
rewrite (add_OZ (multZ (pos n0) y)); reflexivity.
(* neg n *)
intros; reflexivity.
Qed.

(*****************)
Lemma mult_succZ_r : forall x y : Z, multZ x (succZ y) = addZ (multZ x y) x.

intros; elim x.
(* OZ *)
reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
symmetry  in |- *; exact (add_IZ_succZ y).
(* pos (S y0) *)
intros y0 H; do 2 rewrite (tech_mult_posZ y0).
rewrite H; elim (addZ_commutativity (pos y0) (multZ (pos y0) y)).
elim (addZ_associativity (pos y0) (multZ (pos y0) y) (succZ y)).
elim (addZ_commutativity (addZ (multZ (pos y0) y) (succZ y)) (pos y0)).
rewrite (succ_addZ_r (multZ (pos y0) y) y).
rewrite (succ_addZ_l (addZ (multZ (pos y0) y) y) (pos y0)).
elim (succ_addZ_r (addZ (multZ (pos y0) y) y) (pos y0)).
reflexivity.
(* neg n *)
simple induction n.
(* neg O *)
simpl in |- *; rewrite (add_mIZ_predZ (oppZ y)); exact (opp_succZ y).
(* neg (S y0) *)
intros y0 H; do 2 rewrite (tech_mult_negZ y0).
elim H; elim (addZ_commutativity (oppZ y) (multZ (neg y0) y)).
elim (addZ_associativity (oppZ y) (multZ (neg y0) y) (neg (S y0))).
elim (addZ_commutativity (addZ (multZ (neg y0) y) (neg (S y0))) (oppZ y)).
rewrite (opp_succZ y).
rewrite (pred_addZ_r (multZ (neg y0) (succZ y)) (oppZ y)).
rewrite H; elim (pred_addZ_l (addZ (multZ (neg y0) y) (neg y0)) (oppZ y)).
elim (pred_addZ_r (multZ (neg y0) y) (neg y0)); unfold predZ in |- *;
 reflexivity.
Qed.

(*****************)
Lemma mult_predZ_r :
 forall x y : Z, multZ x (predZ y) = addZ (multZ x y) (oppZ x).

intros; elim x.
(* OZ *)
reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
simpl in |- *; symmetry  in |- *; exact (add_mIZ_predZ y).
(* pos (S n0) *)
intros n0 H; unfold oppZ in |- *; do 2 rewrite (tech_mult_posZ n0).
rewrite (pred_addZ_r (multZ (pos n0) (predZ y)) y).
elim (pred_addZ_l (multZ (pos n0) (predZ y)) y).
elim (addZ_commutativity y (multZ (pos n0) y)).
elim (addZ_associativity y (multZ (pos n0) y) (neg (S n0))).
elim (addZ_commutativity (addZ (multZ (pos n0) y) (neg (S n0))) y).
rewrite H; elim (pred_addZ_r (multZ (pos n0) y) (oppZ (pos n0))).
reflexivity.
(* neg n *)
simple induction n.
(* neg O *)
simpl in |- *.
replace (pos 0) with IZ; auto.
rewrite (add_IZ_succZ (oppZ y)).
exact (opp_predZ y).
(* neg (S n0) *)
intros n0 H; do 2 rewrite (tech_mult_negZ n0).
rewrite H; rewrite (opp_predZ y).
elim (addZ_commutativity (oppZ (neg n0)) (multZ (neg n0) y)).
elim (addZ_associativity (oppZ (neg n0)) (multZ (neg n0) y) (succZ (oppZ y))).
elim
 (addZ_commutativity (addZ (multZ (neg n0) y) (succZ (oppZ y)))
    (oppZ (neg n0))).
rewrite (succ_addZ_r (multZ (neg n0) y) (oppZ y)).
rewrite (succ_addZ_l (addZ (multZ (neg n0) y) (oppZ y)) (oppZ (neg n0))).
elim (succ_addZ_r (addZ (multZ (neg n0) y) (oppZ y)) (oppZ (neg n0))).
reflexivity.
Qed.

(************)
Lemma mult_OZ : forall x : Z, multZ x OZ = OZ.

simple destruct x.
(* OZ *)
reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
reflexivity.
(* pos (S y) *)
intros y H; rewrite (tech_mult_posZ y OZ); rewrite H; reflexivity.
(* neg n *)
simple induction n.
(* neg O *)
reflexivity.
(* neg (S y) *)
intros y H; rewrite (tech_mult_negZ y OZ); rewrite H; reflexivity.
Qed.

(************)
Lemma mult_IZ : forall x : Z, multZ x IZ = x.

simple destruct x.
(* OZ *)
reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
reflexivity.
(* pos (S y) *)
intros y H; rewrite (tech_mult_posZ y IZ); rewrite H.
rewrite (add_IZ_succZ (pos y)); reflexivity.
(* neg n *)
simple induction n.
(* neg O *)
reflexivity.
(* neg (S y) *)
intros y H; rewrite (tech_mult_negZ y IZ); rewrite H; unfold IZ in |- *;
 unfold oppZ in |- *.
rewrite (add_mIZ_predZ (neg y)); reflexivity.
Qed.

(*************)
Lemma mult_mIZ : forall x : Z, multZ x (neg 0) = oppZ x.

simple destruct x.
(* OZ *)
reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
reflexivity.
(* pos (S y) *)
intros y H; rewrite (tech_mult_posZ y (neg 0)); rewrite H.
rewrite (add_mIZ_predZ (oppZ (pos y))); reflexivity.
(* neg n *)
simple induction n.
(* neg O *)
reflexivity.
(* neg (S y) *)
intros y H; rewrite (tech_mult_negZ y (neg 0)); rewrite H.
elim
 (opp_add Z IdZ addZ OZ oppZ Z_group addZ_commutativity (neg y) (neg 0) I I).
rewrite (add_mIZ_predZ (neg y)); reflexivity.
Qed.

(**************************)
Theorem multZ_commutativity : commutativity Z multZ.

unfold commutativity in |- *; intros; elim x.
(* OZ *)
rewrite (mult_OZ y); unfold multZ in |- *; reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
simpl in |- *; symmetry  in |- *; exact (mult_IZ y).
(* pos (S y0) *)
intros y0 H; rewrite (tech_mult_posZ y0 y); rewrite H.
elim (mult_succZ_r y (pos y0)); unfold succZ in |- *; reflexivity.
(* neg n *)
intros; elim n.
(* neg O *)
simpl in |- *; symmetry  in |- *; exact (mult_mIZ y).
(* neg (S y0) *)
intros y0 H; rewrite (tech_mult_negZ y0 y); rewrite H.
elim (mult_predZ_r y (neg y0)); unfold predZ in |- *; reflexivity.
Qed.

(********************)
Theorem multZ_neutral : neutral Z IdZ multZ IZ.

unfold neutral in |- *.
split. exact I.
intros.
split.
(* -> *)
elim (multZ_commutativity IZ x); reflexivity.
(* <- *)
reflexivity.
Qed.

(******************************)
Theorem mult_add_distributivity : distributivity Z addZ multZ.

unfold distributivity in |- *; intros; case x.
(* OZ *)
split; reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
split.
rewrite addZ_eq2; rewrite multZ_eq2.
rewrite (mult_succZ_l y z); exact (addZ_commutativity (multZ y z) z).
reflexivity.
(* pos (S y0) *)
intros y0 H.
elim H; intros; split.
rewrite addZ_eq3; rewrite multZ_eq3.
rewrite mult_succZ_l; rewrite H0.
elim (addZ_associativity (multZ (pos y0) z) (multZ y z) z).
elim (addZ_commutativity z (multZ y z)).
apply addZ_associativity.
do 3 rewrite multZ_eq3.
rewrite H1.
apply (add_add Z addZ addZ_commutativity addZ_associativity).
(* neg n *)
simple induction n.
(* neg O *)
split.
rewrite addZ_eq4; rewrite multZ_eq4; rewrite (mult_predZ_l y z).
exact (addZ_commutativity (multZ y z) (oppZ z)).
rewrite multZ_eq4.
apply (opp_add Z IdZ addZ OZ oppZ Z_group addZ_commutativity y z I I).
(* neg (S y0) *)
intros y0 H.
split.
(* -> *)
rewrite (tech_add_neg_predZ y0 y); rewrite (mult_predZ_l (addZ (neg y0) y) z).
elim H; intros. rewrite H0.
elim (addZ_associativity (multZ (neg y0) z) (multZ y z) (oppZ z)).
elim (addZ_commutativity (oppZ z) (multZ y z)).
rewrite (addZ_associativity (multZ (neg y0) z) (oppZ z) (multZ y z)).
elim (tech_mult_negZ y0 z); reflexivity.
(* <- *)
rewrite (tech_mult_negZ y0 (addZ y z)); rewrite (tech_mult_negZ y0 y).
rewrite (tech_mult_negZ y0 z); elim H; intros; rewrite H1.
elim
 (add_add Z addZ addZ_commutativity addZ_associativity
    (multZ (neg y0) y) (multZ (neg y0) z) (oppZ y)
    (oppZ z)).
elim (opp_add Z IdZ addZ OZ oppZ Z_group addZ_commutativity y z I I).
reflexivity.
Qed.

(****************)
Lemma mult_oppZ_r : forall x y : Z, multZ x (oppZ y) = oppZ (multZ x y).

intros; case x.
(* OZ *)
reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
reflexivity.
(* pos (S y0) *)
intros y0 H; do 2 rewrite (tech_mult_posZ y0).
rewrite
 (opp_add Z IdZ addZ OZ oppZ Z_group addZ_commutativity
    (multZ (pos y0) y) y I I).
elim H; reflexivity.
(* neg n *)
intros; elim n.
(* neg O *)
reflexivity.
(* neg (S y0) *)
intros y0 H; do 2 rewrite (tech_mult_negZ y0).
rewrite
 (opp_add Z IdZ addZ OZ oppZ Z_group addZ_commutativity
    (multZ (neg y0) y) (oppZ y) I I).
elim H; reflexivity.
Qed.

(****************)
Lemma mult_oppZ_l : forall x y : Z, multZ (oppZ x) y = oppZ (multZ x y).

simple destruct y.
(* OZ *)
rewrite (mult_OZ (oppZ x)); rewrite (mult_OZ x); reflexivity.
(* pos n *)
intros; elim (multZ_commutativity (pos n) (oppZ x)).
elim (multZ_commutativity (pos n) x); elim n.
(* pos O *)
reflexivity.
(* pos (S y0) *)
intros y0 H; do 2 rewrite (tech_mult_posZ y0).
rewrite H; symmetry  in |- *.
exact
 (opp_add Z IdZ addZ OZ oppZ Z_group addZ_commutativity
    (multZ (pos y0) x) x I I).
(* neg n *)
intros; elim (multZ_commutativity (neg n) (oppZ x)).
elim (multZ_commutativity (neg n) x); elim n.
(* neg O *)
reflexivity.
(* neg (S y0) *)
intros y0 H; do 2 rewrite (tech_mult_negZ y0).
rewrite H; symmetry  in |- *.
exact
 (opp_add Z IdZ addZ OZ oppZ Z_group addZ_commutativity
    (multZ (neg y0) x) (oppZ x) I I).
Qed.

(********************)
Lemma tech_multZ_negO : forall x : Z, multZ (neg 0) x = oppZ x.

Proof multZ_eq4.

(***********************)
Lemma tech_mult_pos_posZ :
 forall n m : nat, multZ (pos n) (pos m) = pos (n * m + (n + m)).

intros; elim n.
(* O *)
reflexivity.
(* S y *)
intros y H; rewrite (tech_mult_posZ y (pos m)); rewrite H.
rewrite (tech_add_pos_posZ (y * m + (y + m)) m).
elim (technical_lemma y m); reflexivity.
Qed.

(***********************)
Lemma tech_mult_neg_negZ :
 forall n m : nat, multZ (neg n) (neg m) = pos (n * m + (n + m)).

intros; elim n.
(* O *)
reflexivity.
(* S y *)
intros y H; rewrite (tech_mult_negZ y (neg m)); rewrite H;
 unfold oppZ in |- *.
rewrite (tech_add_pos_posZ (y * m + (y + m)) m).
elim (technical_lemma y m); reflexivity.
Qed.

(***********************)
Lemma tech_mult_pos_negZ :
 forall n m : nat, multZ (pos n) (neg m) = neg (n * m + (n + m)).

intros; elim n.
(* O *)
simpl in |- *; reflexivity.
(* S y *)
intros y H; rewrite (tech_mult_posZ y (neg m)); rewrite H.
rewrite (tech_add_neg_negZ (y * m + (y + m)) m).
elim (technical_lemma y m); reflexivity.
Qed.

(***********************)
Lemma tech_mult_neg_posZ :
 forall n m : nat, multZ (neg n) (pos m) = neg (n * m + (n + m)).

intros; elim n.
(* O *)
simpl in |- *; reflexivity.
(* S y *)
intros y H; rewrite (tech_mult_negZ y (pos m)); unfold oppZ in |- *;
 rewrite H.
rewrite (tech_add_neg_negZ (y * m + (y + m)) m).
elim (technical_lemma y m); reflexivity.
Qed.

(**************************)
Theorem multZ_associativity : associativity Z multZ.

unfold associativity in |- *; intros; elim x.
(* OZ *)
reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
unfold multZ in |- *; reflexivity.
(* pos (S y0) *)
intros y0 H; do 2 rewrite (tech_mult_posZ y0).
rewrite H; elim (mult_oppZ_l y z).
elim (mult_add_distributivity (multZ (pos y0) y) y z); intros. elim H0.
reflexivity.
(* neg n *)
simple induction n.
(* neg O *)
simpl in |- *; symmetry  in |- *; exact (mult_oppZ_l y z).
(* neg (S y0) *)
intros y0 H; do 2 rewrite (tech_mult_negZ y0).
rewrite H; elim (mult_oppZ_l y z).
elim (mult_add_distributivity (multZ (neg y0) y) (oppZ y) z); intros. elim H0.
reflexivity.
Qed.

(*************)
Theorem Z_ring : is_ring Z IdZ addZ multZ OZ oppZ.

unfold is_ring in |- *.
split. exact addZ_commutativity.
split. exact Z_group.
split. unfold intern in |- *. intros. exact I.
split. exact multZ_associativity. exact mult_add_distributivity.
Qed.

(*********************************)
Theorem Z_unitary_commutative_ring :
 is_unitary_commutative_ring Z IdZ addZ multZ OZ IZ oppZ.

unfold is_unitary_commutative_ring in |- *.
split. exact Z_ring.
split. exact multZ_commutativity. exact multZ_neutral.
Qed.

(* Z is an integral domain *)
(********************)
Lemma tech_integ_posZ :
 forall (n : nat) (x : Z), multZ (pos n) x = OZ -> x = OZ.

intros n x; elim x.
(* OZ *)
reflexivity.
(* pos n0 *)
intros n0; rewrite (tech_mult_pos_posZ n n0); intros.
absurd (pos (n * n0 + (n + n0)) = OZ). discriminate. exact H.
(* neg n0 *)
intros n0; rewrite (tech_mult_pos_negZ n n0); intros.
absurd (neg (n * n0 + (n + n0)) = OZ). discriminate. exact H.
Qed.

(********************)
Lemma tech_integ_negZ :
 forall (n : nat) (x : Z), multZ (neg n) x = OZ -> x = OZ.

intros n x; elim x.
(* OZ *)
reflexivity.
(* pos n0 *)
intros n0; rewrite (tech_mult_neg_posZ n n0); intros.
absurd (neg (n * n0 + (n + n0)) = OZ). discriminate. exact H.
(* neg n0 *)
intros n0; rewrite (tech_mult_neg_negZ n n0); intros.
absurd (pos (n * n0 + (n + n0)) = OZ). discriminate. exact H.
Qed.

(*****************)
Theorem integrityZ : integrity Z multZ OZ.

unfold integrity in |- *; intros a b; elim a.
(* OZ *)
intros; left; reflexivity.
(* pos n *)
intros; right; apply (tech_integ_posZ n b); exact H.
(* neg n *)
intros; right; apply (tech_integ_negZ n b); exact H.
Qed.

(************************)
Lemma tech_mult_pos_succZ :
 forall n m : nat, posOZ (S n * S m) = multZ (pos n) (pos m).

intros; elim m.
(* O *)
elim multZ_neutral; intros; elim (H0 (pos n) I); intros.
replace (pos 0) with IZ; auto.
rewrite H1.
elim (mult_commut 1 (S n)). rewrite (mult_neutr (S n)).
unfold posOZ in |- *; reflexivity.
(* S y *)
intros y H; elim (multZ_commutativity (pos (S y)) (pos n)).
rewrite (tech_mult_posZ y (pos n));
 elim (multZ_commutativity (pos n) (pos y)).
elim H; elim (mult_n_Sm (S n) (S y)); elim (plus_n_Sm (S n * S y) n).
elim (mult_n_Sm (S n) y); elim (plus_n_Sm (S n * y) n).
unfold posOZ in |- *; rewrite (tech_add_pos_posZ (S n * y + n) n).
reflexivity.
Qed.

(************************)
Lemma tech_mult_pos_succZ2 :
 forall n m : nat, multZ (pos n) (pos m) = pos (S n * m + n).

intros; elim (tech_mult_pos_succZ n m).
simpl in |- *; elim (mult_n_Sm n m); elim (plus_assoc m (n * m) n);
 reflexivity.
Qed.

(**************)
Lemma tech_div1 :
 forall n0 n q r : nat,
 S n0 = q * S n + r -> pos n0 = addZ (multZ (pos n) (posOZ q)) (posOZ r).

intros n0 n q r; elim q.
(* O O *)
elim r.
intros; absurd (S n0 = 0). discriminate. exact H.
(* O (S y) *)
intros y H; unfold posOZ in |- *; rewrite (mult_OZ (pos n)).
simpl in |- *; intros; elim (eq_add_S n0 y H0); reflexivity.
(* (S n) O *)
elim r.
intros y H; unfold posOZ in |- *; elim (plus_n_O (S y * S n)).
rewrite (add_OZ (multZ (pos n) (pos y))); elim (tech_mult_pos_succZ n y).
elim (mult_commut (S n) (S y)); intros; elim H0; unfold posOZ in |- *;
 reflexivity.
(* (S n) (S y) *)
intros y H y0 H0; unfold posOZ in |- *; elim (plus_n_Sm (S y0 * S n) y).
intros; rewrite (eq_add_S n0 (S y0 * S n + y) H1).
rewrite (tech_mult_pos_succZ2 n y0).
rewrite (tech_add_pos_posZ (S n * y0 + n) y).
elim (plus_comm n (S n * y0)); elim (mult_commut y0 (S n)); simpl in |- *.
reflexivity.
Qed.

(**************)
Lemma tech_div2 :
 forall n0 n q : nat, S n0 = q * S n -> neg n0 = multZ (pos n) (negOZ q).

intros n0 n q; elim q.
(* O *)
simpl in |- *; intros; absurd (S n0 = 0). discriminate. exact H.
(* S y *)
intros y H; unfold negOZ in |- *. rewrite (tech_mult_pos_negZ n y); intros.
simpl in H0; rewrite (eq_add_S _ _ H0).
elim (mult_commut (S n) y); simpl in |- *; elim (plus_comm (n + y) (n * y)).
elim (plus_assoc n y (n * y)); reflexivity.
Qed.

(***************)
Lemma tech_div31 :
 forall n q : nat,
 addZ (oppZ (multZ (pos n) (pos q))) (pos n) = oppZ (multZ (pos n) (posOZ q)).

intros; elim q.
(* O *)
unfold posOZ in |- *; rewrite (mult_OZ (pos n)).
cut (IZ = pos 0); intros. elim H. rewrite (mult_IZ (pos n)).
elim (addZ_opposite (pos n) I); intros; elim H1; intros; elim H3; intros.
rewrite H5; reflexivity. reflexivity.
(* S y *)
intros y H; unfold posOZ in |- *;
 elim (multZ_commutativity (pos (S y)) (pos n)).
rewrite (tech_mult_posZ y (pos n)).
rewrite
 (opp_add Z IdZ addZ OZ oppZ Z_group addZ_commutativity
    (multZ (pos y) (pos n)) (pos n) I I).
elim
 (addZ_associativity (oppZ (multZ (pos y) (pos n))) (oppZ (pos n)) (pos n)).
elim (addZ_opposite (pos n) I); intros; elim H1; intros; elim H3; intros.
rewrite H5; rewrite (add_OZ (oppZ (multZ (pos y) (pos n)))).
elim (multZ_commutativity (pos y) (pos n)); reflexivity.
Qed.

(***************)
Lemma tech_div32 :
 forall n q r : nat, S n > r -> pos (n - r) = addZ (pos n) (oppZ (posOZ r)).

intros n q r; elim r.
(* O *)
unfold posOZ in |- *; unfold oppZ in |- *; rewrite (add_OZ (pos n));
 elim (minus_n_O n).
reflexivity.
(* S y *)
intros y H; unfold posOZ in |- *; unfold oppZ in |- *; symmetry  in |- *.
exact (tech_add_pos_neg_posZ n y (gt_S_n y n H0)).
Qed.

(**************)
Lemma tech_div3 :
 forall n0 n q r : nat,
 S n0 = q * S n + r ->
 S n > r -> neg n0 = addZ (multZ (pos n) (neg q)) (pos (n - r)).

intros.
elim (tech_opp_pos_negZ q); intros; elim H1.
rewrite (mult_oppZ_r (pos n) (pos q)); rewrite (tech_div32 n q r H0).
rewrite
 (addZ_associativity (oppZ (multZ (pos n) (pos q))) (pos n) (oppZ (posOZ r)))
 .
rewrite (tech_div31 n q).
elim
 (opp_add Z IdZ addZ OZ oppZ Z_group addZ_commutativity
    (multZ (pos n) (posOZ q)) (posOZ r) I I).
elim (tech_div1 n0 n q r H); reflexivity.
Qed.

(**************)
Lemma tech_div4 :
 forall n0 n q r : nat,
 S n0 = q * S n + r -> pos n0 = addZ (multZ (neg n) (negOZ q)) (posOZ r).

intros; cut (multZ (neg n) (negOZ q) = multZ (pos n) (posOZ q)); intros.
rewrite H0; intros; exact (tech_div1 n0 n q r H).
cut (negOZ q = oppZ (posOZ q)); intros. rewrite H0.
elim (tech_opp_pos_negZ n); intros; elim H1.
apply (mult_opp_opp Z IdZ addZ multZ OZ oppZ Z_ring (pos n) (posOZ q) I I).
elim q; reflexivity.
Qed.

(**************)
Lemma tech_div5 :
 forall n0 n q : nat, S n0 = q * S n -> neg n0 = multZ (neg n) (posOZ q).

intros; cut (posOZ q = oppZ (negOZ q)); intros. rewrite H0.
elim (tech_opp_pos_negZ n); intros; elim H1.
rewrite (mult_opp_opp Z IdZ addZ multZ OZ oppZ Z_ring (pos n) (negOZ q) I I).
exact (tech_div2 n0 n q H).
elim q; reflexivity.
Qed.

(**************)
Lemma tech_div6 :
 forall n0 n q r : nat,
 S n0 = q * S n + r ->
 S n > r -> neg n0 = addZ (multZ (neg n) (pos q)) (pos (n - r)).

intros.
elim (tech_opp_pos_negZ q); intros; elim H2.
elim (tech_opp_pos_negZ n); intros; elim H3.
rewrite (mult_opp_opp Z IdZ addZ multZ OZ oppZ Z_ring (pos n) (neg q) I I).
apply (tech_div3 n0 n q r H H0).
Qed.

(****************)
Lemma inversibleZ :
 forall x : Z, inversible Z multZ IZ x -> x = IZ \/ x = oppZ IZ.

simple destruct x.
(* OZ *)
intros; elim H; intros; elim H0; intros; elim H1.
left; reflexivity.
(* pos n *)
simple induction n.
(* pos O *)
intros; left; reflexivity.
(* pos (S y) *)
intros y H H0; elim H0; intros; elim H1; intros.
absurd (multZ (pos (S y)) x0 = IZ). elim x0.
rewrite (mult_OZ (pos (S y))). discriminate.
intros; rewrite (tech_mult_pos_posZ (S y) n0).
elim (plus_comm (S y + n0) (S y * n0)).
elim (plus_assoc (S y) n0 (S y * n0)); simpl in |- *.
apply (tech_pos_not_posZ (S (y + (n0 + (n0 + y * n0)))) 0).
discriminate.
intros; rewrite (tech_mult_pos_negZ (S y) n0).
elim (plus_comm (S y + n0) (S y * n0)).
elim (plus_assoc (S y) n0 (S y * n0)); simpl in |- *; discriminate.
exact H2.
(* neg n *)
simple induction n.
(* neg O *)
right; reflexivity.
(* neg (S y) *)
intros y H H0; elim H0; intros; elim H1; intros.
absurd (multZ (neg (S y)) x0 = IZ). elim x0.
rewrite (mult_OZ (neg (S y))). discriminate.
intros; rewrite (tech_mult_neg_posZ (S y) n0).
elim (plus_comm (S y + n0) (S y * n0)).
elim (plus_assoc (S y) n0 (S y * n0)); simpl in |- *; discriminate.
intros; rewrite (tech_mult_neg_negZ (S y) n0).
elim (plus_comm (S y + n0) (S y * n0)).
elim (plus_assoc (S y) n0 (S y * n0)); simpl in |- *.
apply (tech_pos_not_posZ (S (y + (n0 + (n0 + y * n0)))) 0).
discriminate.
exact H2.
Qed.

(************)
Lemma sgn_abs : forall x : Z, multZ x (sgnZ x) = absZ x.

simple destruct x.
(* OZ *)
reflexivity.
(* pos n *)
intros; exact (mult_IZ (pos n)).
(* neg n *)
intros; exact (mult_mIZ (neg n)).
Qed.


Require Import Coq.Init.Prelude.

(** 点ごとに等しい *)
Definition pointwise_eq {A B : Type} (f g : A -> B) : Prop := forall x, f x = g x.

Notation "f == g" := (pointwise_eq f g) (at level 70, no associativity) : type_scope.

(** 恒等射 *)
Definition id {A : Type} : A -> A := fun x => x.

(** 射の合成 *)
Definition compose {A B C : Type} (f : B -> C) (g : A -> B) : A -> C := fun x => f (g x).

Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity)
 : function_scope.

(** [f] は単射である *)
Definition mono {A B : Type} (f : A -> B) : Prop
 := forall (Z : Type) (g₁ g₂ : Z -> A), f o g₁ == f o g₂ -> g₁ == g₂.

(** [f] に対して [g] は左逆射である *)
Definition left_inv_rel {A B : Type} (f : A -> B) (g : B -> A) : Prop := g o f == id.

(** [f] は左逆射を持つ *)
Definition left_inv {A B : Type} (f : A -> B) : Prop := ex (left_inv_rel f).

(** [h] は分裂単射である *)
Definition split_mono {A B : Type} (h : A -> B) : Prop := left_inv h /\ mono h.

(** [f] は全射である *)
Definition epi {A B : Type} (f : A -> B) : Prop
 := forall (C : Type) (g₁ g₂ : B -> C), g₁ o f == g₂ o f -> g₁ == g₂.

(** [f] に対して [g] は右逆射である *)
Definition right_inv_rel {A B : Type} (f : A -> B) (g : B -> A) : Prop := f o g == id.

(** [f] は右逆射を持つ *)
Definition right_inv {A B : Type} (f : A -> B) : Prop := ex (right_inv_rel f).

(** [f] は分裂全射である *)
Definition split_epi {A B : Type} (h : A -> B) : Prop := right_inv h /\ epi h.

(** [f] は全単射／双射である *)
Definition bi {A B : Type} (f : A -> B) : Prop := mono f /\ epi f.

(** [f] と [g] は逆射の関係である *)
Definition iso_rel {A B : Type} (f : A -> B) (g : B -> A) : Prop := g o f == id /\ f o g == id.

(** [f] は同型射である *)
Definition iso {A B : Type} (f : A -> B) : Prop := ex (iso_rel f).

(** 左逆射を持つ [f] の、その左逆射／引き込みを得る *)
Definition retraction {A B : Type} (f : A -> B) (P : left_inv f) : B -> A.
Proof.
 (* destruct P as [ g P ]. *)
Admitted.

(** 右逆射を持つ [f] の、その右逆射／断面を得る *)
Definition section {A B : Type} (f : A -> B) (P : right_inv f) : B -> A.
Proof.
 (* destruct P as [ g P ]. *)
Admitted.

(** [f] が左逆射を持つならば [f] は単射である *)
Definition mono_left_inv {A B : Type} (f : A -> B) : left_inv f -> mono f.
Proof.
 intros P.
 unfold left_inv in P.
 destruct P as [ g P ].
 unfold left_inv_rel in P.
 unfold mono.
 intros Z g₁ g₂ Q.
 unfold pointwise_eq.
 intros x.
 change (id (g₁ x) = id (g₂ x)).
 unfold pointwise_eq in P.
 rewrite <- P with (g₁ x).
 rewrite <- P with (g₂ x).
 unfold compose.
 apply f_equal.
 unfold pointwise_eq in Q.
 unfold compose in Q.
 apply Q.
Defined.

(** [f] が右逆射を持つならば [f] は全射である *)
Definition epi_right_inv {A B : Type} (f : A -> B) : right_inv f -> epi f.
Proof.
 intros P.
 unfold right_inv in P.
 destruct P as [ g P ].
 unfold right_inv_rel in P.
 unfold epi.
 intros C g₁ g₂ Q.
 unfold pointwise_eq.
 intros x.
 change (g₁ (id x) = g₂ (id x)).
 unfold pointwise_eq in P.
 rewrite <- P with x.
 unfold compose.
 unfold pointwise_eq in Q.
 unfold compose in Q.
 apply Q.
Defined.

(** [f] が同型射であるのならば [f] は左逆射を持ち、右逆射を持つ *)
Definition left_right_inv_iso {A B : Type} (f : A -> B) : iso f -> left_inv f /\ right_inv f.
Proof.
 intros P.
 unfold iso in P.
 destruct P as [ g P ].
 unfold iso_rel in P.
 destruct P as [ left_P right_P ].
 split.
 -
  unfold left_inv.
  exists g.
  unfold left_inv_rel.
  apply left_P.
 -
  unfold right_inv.
  exists g.
  unfold right_inv_rel.
  apply right_P.
Defined.

(** [f] が同型射であるのならば [f] は双射である *)
Definition bi_iso {A B : Type} (f : A -> B) : iso f -> bi f.
Proof.
 intros P.
 apply left_right_inv_iso in P.
 destruct P as [ left_P right_P ].
 unfold bi.
 split.
 -
  apply mono_left_inv.
  apply left_P.
 -
  apply epi_right_inv.
  apply right_P.
Defined.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** A modular implementation of mergesort (the complexity is O(n.log n) in
   the length of the list) *)

(* Initial author: Hugo Herbelin, Oct 2009 *)

Require Import List Setoid Permutation Sorted Orders.

(** Notations and conventions *)

Local Notation "[ ]" := nil.
Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).

Open Scope bool_scope.

Local Coercion is_true : bool >-> Sortclass.

(** The main module defining [mergesort] on a given boolean
    order [<=?]. We require minimal hypotheses : this boolean
    order should only be total: [forall x y, (x<=?y) \/ (y<=?x)].
    Transitivity is not mandatory, but without it one can
    only prove [LocallySorted] and not [StronglySorted].
*)

Module Sort (Import X:Orders.TotalLeBool').

Fixpoint merge l1 l2 :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
  end
  in merge_aux l2.

(** We implement mergesort using an explicit stack of pending mergings.
    Pending merging are represented like a binary number where digits are
    either None (denoting 0) or Some list to merge (denoting 1). The n-th
    digit represents the pending list to be merged at level n, if any.
    Merging a list to a stack is like adding 1 to the binary number
    represented by the stack but the carry is propagated by merging the
    lists. In practice, when used in mergesort, the n-th digit, if non 0,
    carries a list of length 2^n. For instance, adding singleton list
    [3] to the stack Some [4]::Some [2;6]::None::Some [1;3;5;5]
    reduces to propagate the carry [3;4] (resulting of the merge of [3]
    and [4]) to the list Some [2;6]::None::Some [1;3;5;5], which reduces
    to propagating the carry [2;3;4;6] (resulting of the merge of [3;4] and
    [2;6]) to the list None::Some [1;3;5;5], which locally produces
    Some [2;3;4;6]::Some [1;3;5;5], i.e. which produces the final result
    None::None::Some [2;3;4;6]::Some [1;3;5;5].

    For instance, here is how [6;2;3;1;5] is sorted:

<<
       operation             stack                list
       iter_merge            []                   [6;2;3;1;5]
    =  append_list_to_stack  [ + [6]]             [2;3;1;5]
    -> iter_merge            [[6]]                [2;3;1;5]
    =  append_list_to_stack  [[6] + [2]]          [3;1;5]
    =  append_list_to_stack  [ + [2;6];]          [3;1;5]
    -> iter_merge            [[2;6];]             [3;1;5]
    =  append_list_to_stack  [[2;6]; + [3]]       [1;5]
    -> merge_list            [[2;6];[3]]          [1;5]
    =  append_list_to_stack  [[2;6];[3] + [1]     [5]
    =  append_list_to_stack  [[2;6] + [1;3];]     [5]
    =  append_list_to_stack  [ + [1;2;3;6];;]     [5]
    -> merge_list            [[1;2;3;6];;]        [5]
    =  append_list_to_stack  [[1;2;3;6];; + [5]]  []
    -> merge_stack           [[1;2;3;6];;[5]]
    =                                             [1;2;3;5;6]
>>
    The complexity of the algorithm is n*log n, since there are
    2^(p-1) mergings to do of length 2, 2^(p-2) of length 4, ..., 2^0
    of length 2^p for a list of length 2^p. The algorithm does not need
    explicitly cutting the list in 2 parts at each step since it the
    successive accumulation of fragments on the stack which ensures
    that lists are merged on a dichotomic basis.
*)

Fixpoint merge_list_to_stack stack l :=
  match stack with
  | [] => [Some l]
  | None :: stack' => Some l :: stack'
  | Some l' :: stack' => None :: merge_list_to_stack stack' (merge l' l)
  end.

Fixpoint merge_stack stack :=
  match stack with
  | [] => []
  | None :: stack' => merge_stack stack'
  | Some l :: stack' => merge l (merge_stack stack')
  end.

Fixpoint iter_merge stack l :=
  match l with
  | [] => merge_stack stack
  | a::l' => iter_merge (merge_list_to_stack stack [a]) l'
  end.

Definition sort := iter_merge [].

(** The proof of correctness *)

Local Notation Sorted := (LocallySorted leb) (only parsing).

Fixpoint SortedStack stack :=
  match stack with
  | [] => True
  | None :: stack' => SortedStack stack'
  | Some l :: stack' => Sorted l /\ SortedStack stack'
  end.

Local Ltac invert H := inversion H; subst; clear H.

Fixpoint flatten_stack (stack : list (option (list t))) :=
  match stack with
  | [] => []
  | None :: stack' => flatten_stack stack'
  | Some l :: stack' => l ++ flatten_stack stack'
  end.

Theorem Sorted_merge : forall l1 l2,
  Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2).
Proof.
induction l1; induction l2; intros; simpl; auto.
  destruct (a <=? a0) eqn:Heq1.
    invert H.
      simpl. constructor; trivial; rewrite Heq1; constructor.
      assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto).
      clear H0 H3 IHl1; simpl in *.
      destruct (b <=? a0); constructor; auto || rewrite Heq1; constructor.
    assert (a0 <=? a) by
      (destruct (leb_total a0 a) as [H'|H']; trivial || (rewrite Heq1 in H'; inversion H')).
    invert H0.
      constructor; trivial.
      assert (Sorted (merge (a::l1) (b::l))) by auto using IHl1.
      clear IHl2; simpl in *.
      destruct (a <=? b); constructor; auto.
Qed.

Theorem Permuted_merge : forall l1 l2, Permutation (l1++l2) (merge l1 l2).
Proof.
  induction l1; simpl merge; intro.
    assert (forall l, (fix merge_aux (l0 : list t) : list t := l0) l = l)
    as -> by (destruct l; trivial). (* Technical lemma *)
    apply Permutation_refl.
  induction l2.
    rewrite app_nil_r. apply Permutation_refl.
    destruct (a <=? a0).
      constructor; apply IHl1.
      apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2.
Qed.

Theorem Sorted_merge_list_to_stack : forall stack l,
  SortedStack stack -> Sorted l -> SortedStack (merge_list_to_stack stack l).
Proof.
  induction stack as [|[|]]; intros; simpl.
    auto.
    apply IHstack. destruct H as (_,H1). fold SortedStack in H1. auto.
      apply Sorted_merge; auto; destruct H; auto.
      auto.
Qed.

Theorem Permuted_merge_list_to_stack : forall stack l,
  Permutation (l ++ flatten_stack stack) (flatten_stack (merge_list_to_stack stack l)).
Proof.
  induction stack as [|[]]; simpl; intros.
    reflexivity.
    rewrite app_assoc.
    etransitivity.
      apply Permutation_app_tail.
      etransitivity.
        apply Permutation_app_comm.
      apply Permuted_merge.
    apply IHstack.
    reflexivity.
Qed.

Theorem Sorted_merge_stack : forall stack,
  SortedStack stack -> Sorted (merge_stack stack).
Proof.
induction stack as [|[|]]; simpl; intros.
  constructor; auto.
  apply Sorted_merge; tauto.
  auto.
Qed.

Theorem Permuted_merge_stack : forall stack,
  Permutation (flatten_stack stack) (merge_stack stack).
Proof.
induction stack as [|[]]; simpl.
  trivial.
  transitivity (l ++ merge_stack stack).
    apply Permutation_app_head; trivial.
    apply Permuted_merge.
  assumption.
Qed.

Theorem Sorted_iter_merge : forall stack l,
  SortedStack stack -> Sorted (iter_merge stack l).
Proof.
  intros stack l H; induction l in stack, H |- *; simpl.
    auto using Sorted_merge_stack.
    assert (Sorted [a]) by constructor.
    auto using Sorted_merge_list_to_stack.
Qed.

Theorem Permuted_iter_merge : forall l stack,
  Permutation (flatten_stack stack ++ l) (iter_merge stack l).
Proof.
  induction l; simpl; intros.
    rewrite app_nil_r. apply Permuted_merge_stack.
    change (a::l) with ([a]++l).
    rewrite app_assoc.
    etransitivity.
      apply Permutation_app_tail.
    etransitivity.
    apply Permutation_app_comm.
    apply Permuted_merge_list_to_stack.
    apply IHl.
Qed.

Theorem Sorted_sort : forall l, Sorted (sort l).
Proof.
intro; apply Sorted_iter_merge. constructor.
Qed.

Corollary LocallySorted_sort : forall l, Sorted.Sorted leb (sort l).
Proof. intro; eapply Sorted_LocallySorted_iff, Sorted_sort; auto. Qed.

Theorem Permuted_sort : forall l, Permutation l (sort l).
Proof.
intro; apply (Permuted_iter_merge l []).
Qed.

Corollary StronglySorted_sort : forall l,
  Transitive leb -> StronglySorted leb (sort l).
Proof. auto using Sorted_StronglySorted, LocallySorted_sort. Qed.

End Sort.

(** An example *)

Module NatOrder <: TotalLeBool.
  Definition t := nat.
  Fixpoint leb x y :=
    match x, y with
    | 0, _ => true
    | _, 0 => false
    | S x', S y' => leb x' y'
    end.
  Infix "<=?" := leb (at level 35).
  Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1.
  Proof.
    induction a1; destruct a2; simpl; auto.
  Qed.
End NatOrder.

Module Import NatSort := Sort NatOrder.

Example SimpleMergeExample := Eval compute in sort [5;3;6;1;8;6;0].


Require Import FinTypes.
(**  Proofs about DFA as a test for the finType library *)
Set Implicit Arguments.
Unset Printing Implicit Defensive.
Unset Strict Implicit.
Set Contextual Implicit.

(** * Conversion between Props and bools *)

Coercion toProp (b:bool) := if b then True else False.

Instance toProp_dec b : dec (toProp b).
Proof.
  destruct b; auto.
Qed.

Section DFA.
  (** * Definition of the alphabet, words and dfa*)
  Variable Sig: finType.
  Definition word := list Sig.

Record dfa: Type :=
  DFA {
      S:> finType;
      s: S;
      F: decPred S;
      delta_S: S -> Sig -> S
    }.

Section Reachability.
Variable  A : dfa.
(** transition function for whole words *)
Fixpoint delta_star (q: A) (w: word) :=
  match w with
  | nil => q
  | x::w' => delta_star (delta_S q x) w'
  end.

(** Definition if acceptance *)
Definition accept (w:word) := F (@delta_star s w).

Instance accept_dec w : dec (accept w).
Proof.
  auto.
Qed.

(** * Reachability
- normal reachability
- reachability with a specific word
 *)

Inductive reachable (q: A) :  A -> Prop :=
| refl: reachable q q
| step q' x: reachable (delta_S q x) q' -> reachable q q'.

Definition reachable_with q w q':= delta_star q w = q'.

Hint Constructors reachable.

Lemma reachable_with_reachable (q q': A): reachable q q' <-> exists w, reachable_with q w q'.
Proof.
  split.
  - intro R. induction R.
    + now exists nil.
    + destruct IHR as [w IHR]. exists (x::w). unfold reachable_with. cbn. congruence.
  - intros [w H]. revert q H.  induction w; intros q H.
    + now rewrite H.
    + econstructor 2. apply IHw. apply H.
Qed.

Hint Resolve reachable_with_reachable.

Lemma reachable_transitive (q:A) q' q'': reachable q q' /\ reachable q' q'' -> reachable q q''.
Proof.
  intros [R R']. induction R; eauto.
Qed.
(*
Lemma reachable_delta_star q w: reachable q (delta_star q w).
Proof.
  apply reachable_with_reachable. now exists w.
Qed.
*)
(** * Reach (set of all reachable states)
- defined using fixed-point iteration *)

(* The predicate for the fixed-point iteration *)
Definition step_reach (set: list A) (q: A) := exists q' x, q' el set /\ reachable_with q' [x] q.

Lemma step_reach_consistent: step_consistent step_reach.
Proof.
  intros B q H B' sub. destruct H as [q' [x [E R]]]. exists q', x. auto.
Qed.

Definition reach (q: A) := FCIter step_reach [q].

Lemma reach_least_fp q: least_fp_containing (FCStep step_reach) (reach q) [q].
Proof.
  apply step_consistent_least_fp. apply step_reach_consistent.
Qed.

Lemma reach_correct1 (q:A): inclp (reach q) (reachable q).
Proof.
  apply FCIter_ind.
  - intro x. cbn. now intros [[]|[]].
  - intros set q' H [q'' [x [E  H1]]]. eapply reachable_transitive; split.
    + apply (H _ E).
    + apply reachable_with_reachable. eauto.
Qed.

Lemma reach_correct2' q q': q' el reach q -> forall q'', reachable q' q'' -> q'' el reach q.
Proof.
 intros E q'' R. induction R.
  - exact E.
  - apply IHR. apply Closure_FCIter. now  exists q0, x.
Qed.

Lemma reach_correct2 q: forall q', reachable q q' -> q' el reach q.
Proof.
apply reach_correct2'. now apply preservation_FCIter.
Qed.

Lemma reach_correct q q': reachable q q' <-> q' el (reach q).
Proof.
  split.
  - apply reach_correct2.
  - apply reach_correct1.
Qed.

Global Instance reachable_dec q q': dec (reachable q q').
Proof.
  eapply dec_prop_iff.
  - symmetry. apply reach_correct.
  - auto.
Qed.

Global Instance reachable_with_something_dec q q': dec (exists w, reachable_with q w q').
Proof.
  eauto.
Qed.

Lemma reach_reachable_with q q': (exists w, reachable_with q w q') <-> q' el reach q.
Proof.
 rewrite <- reachable_with_reachable.  apply reach_correct.
Qed.

Lemma delta_star_reach w q: delta_star q w el (reach q).
Proof.
  apply reach_reachable_with. now exists w.
Qed.

Notation in_lang w := (accept w) (only parsing).

Lemma Sig_reach : (forall w, in_lang w) <-> forall (q: A), q el (reach s) -> F q.
Proof.
  split.
  - intros H q E. rewrite <- reach_reachable_with in E. destruct E as [w R].
   rewrite <- R.  apply (H w).
  - intros H w. apply (H (delta_star s w)). apply delta_star_reach.
Qed.

Global Instance Sig_dec : dec (forall w, in_lang w).
Proof.
  decide( forall q, q el reach s -> F q) as [H | H].
  - left. now apply Sig_reach.
  - right. now rewrite Sig_reach.
Qed.

Definition empty := forall w, ~ in_lang w.

Definition neg_F := DecPred (fun x => ~ (@F A  x)).

Definition complement := DFA s neg_F (@delta_S A).

End Reachability.
Notation in_lang A w := (accept A w) (only parsing).
Section Operations.
Variable  A : dfa.

Lemma complement_correct w: accept (complement A) w <-> ~ (accept A w).
Proof.
  split; auto.
Qed.

Global Instance empty_dec : dec (empty A).
Proof.
  apply (dec_trans (@Sig_dec (complement A))). now setoid_rewrite complement_correct.
Qed.

Lemma empty_reach: empty A <-> forall (q:A), q el (reach s) -> ~ (F q).
Proof.
  split.
  - intros empt q E F . rewrite <- reach_reachable_with in E. destruct E as [w R].
    specialize (empt w). apply empt. unfold accept. now rewrite R.
  - intros H w acc. specialize (H (delta_star s w)). apply H.
    + apply delta_star_reach.
    + exact acc.
Qed.

Instance exists_accept_dec: dec (exists w, accept A w).
Proof.
decide (empty A) as [H | H].
- firstorder.
- left. unfold empty in H.  rewrite empty_reach in H. rewrite DM_notAll in H.
  + destruct H as [q H]. destruct (dec_DM_impl _ _ H) as [H' acc].
     rewrite <- reach_reachable_with in H'. destruct H' as [w R]. exists w.  rewrite <- R in acc.
    apply dec_DN; auto.
  + auto.
Qed.

Instance exists_not_accept_dec : dec (exists w, ~ accept A w).
Proof.
  decide (forall w, accept A w) as [H|H].
  - right. firstorder.
  - left. rewrite Sig_reach in H. rewrite DM_notAll in H.
    + destruct H as [q H].  destruct (dec_DM_impl _ _ H) as [H' acc].
       rewrite <- reach_reachable_with in H'. destruct H' as [w R]. exists w.  now rewrite <- R in acc.
    + auto.
Qed.

Definition Epsilon_autom : dfa.
Proof.
  refine (DFA (inl tt) (DecPred (fun q: unit + unit => if q then True else False)) (fun _ _ => inr tt)).
  intros [[]|[]]; auto.
Defined.

Lemma inr_fix_epsilon w : (@delta_star Epsilon_autom (inr tt) w) = inr tt.
Proof.
  now induction w.
Qed.

Lemma Epsilon_autom_correct w: accept Epsilon_autom w <-> w = nil.
Proof.
  split.
  - cbn. destruct w.
    + reflexivity.
    + cbn. now rewrite inr_fix_epsilon.
  - intros H. subst w. cbn. exact I.
Qed.

Definition predCons (A:dfa) (q: option A + unit) := match q with
                                                        | inl None => False
                                                        | inl (Some q) => F q
                                                        | inr tt => False end.

Definition deltaCons x (A:dfa) (q: option A + unit) y  := match q with
                                     | inl None => if decision (y = x) then inl (Some s) else inr tt
                                     | inl (Some q) => inl (Some (delta_S q y))
                                     | inr tt => inr tt end.

Instance predCons_dec  (A:dfa) (q: option A + unit) : dec (predCons q).
Proof.
  destruct q.
  - destruct o; auto.
  - destruct u; auto.
Qed.

Definition cons (A: dfa) (x:Sig) :=
  DFA (inl None) (DecPred (@predCons A)) (@deltaCons x A).

Lemma inr_fix A' x w : (@delta_star (cons A' x) (inr tt) w) = inr tt.
Proof.
  now induction w.
Qed.

Lemma cons_correct  (A':dfa) x w : accept A' w <-> accept (cons A' x) (x::w).
Proof.
  cbn in *. deq x. unfold accept. generalize (@s A').  induction w; firstorder.
Qed.

Fixpoint exactW (w: word)  := match w with
                     | nil => Epsilon_autom
                     | x::w' => cons (exactW w') x end.

Lemma exactW_correct w w': accept (exactW w) w' <-> w' = w.
Proof.
  split.
    - revert w'; induction w; intros w';  destruct w'.
   + reflexivity.
   + simpl. apply Epsilon_autom_correct.
   + cbn. tauto.
   + intros H. pose proof (@cons_correct (exactW w) a w') as nc; cbn in *. deq a.
    dec.
    * subst e. rewrite <- nc in H. f_equal. now apply IHw.
    * unfold predCons in *. now rewrite (@inr_fix (exactW w) _  w') in H.
    - intros []. induction w'.
      + exact I.
      + simpl. now rewrite <- cons_correct.
Qed.

Variable A':dfa.

Section Product_automaton.
  Variable op: Prop -> Prop -> Prop.
  Variable op_dec: forall P Q, dec P -> dec Q -> dec (op P Q).

  Definition prod_delta: A (x) A' -> Sig -> A (x) A' :=
    fun P x  => match P with (q1,q2) => (delta_S q1 x, delta_S q2 x) end.
Definition prod_pred := (fun P => match P with (q1,q2) => op (@F A q1) (@F A' q2) end).

Global Instance prod_pred_dec P: dec (prod_pred P).
Proof.
  destruct P as [q1 q2]. auto.
Qed.

Definition prod_F  := DecPred prod_pred.

Definition prod := DFA (s,s) prod_F prod_delta.

Lemma prod_delta_star w q1 q2 : @delta_star prod (q1, q2) w = (delta_star q1 w, delta_star q2 w).
Proof.
  revert q1 q2. induction w; now cbn.
Qed.

Lemma prod_correct w: accept prod w <-> op (accept A w) (accept A' w).
Proof.
  cbn. now rewrite prod_delta_star.
Qed.

End Product_automaton.
Arguments prod op {op_dec}.

Definition intersect := prod and.

Lemma intersect_correct w: accept intersect w <-> accept A w /\ accept A' w.
Proof.
  apply prod_correct.
Qed.

Definition U :=  prod or.

Lemma U_correct w: accept U w <-> accept A w \/ accept A' w.
Proof.
  apply prod_correct.
Qed.

Definition diff := prod (fun P Q => P /\ ~ Q).

Lemma diff_correct w : accept diff w <-> accept A w /\ ~ accept A' w.
Proof.
  unfold diff. now rewrite prod_correct.
Qed.

Definition lang_incl := forall w, in_lang A w -> in_lang A' w.

Lemma lang_incl_iff : lang_incl <-> empty diff.
Proof.
  unfold empty. setoid_rewrite diff_correct. split.
  - firstorder.
  - intros H w H'. specialize (H w). destruct (dec_DM_and _ H).
    + tauto.
    + apply dec_DN; auto.
Qed.

End Operations.

Definition lang_equiv A A':= lang_incl A A' /\ lang_incl A' A.

Instance lang_sub_dec A A' : dec (lang_incl A A').
Proof.
  decide (empty (diff A A')) as [H|H]; unfold empty in H; setoid_rewrite diff_correct in H.
  - left. intros w acc. specialize (H w). decide (accept A' w); tauto.
  - right. firstorder.
Qed.

Instance equiv_eq_dec A A': dec (lang_equiv A A').
Proof.
  auto.
Qed.

(** * Nondeterministic finite automata (NFA)*)

Record nfa := NFA {
                  Q :> finType;
                  q0:Q;
                  Q_acc: decPred Q;
                  delta_Q: Q -> Sig -> decPred Q
                }.

Implicit Type B : nfa.
Implicit Type A: dfa.
Fixpoint delta_Q_star B q w: B -> Prop  :=
  match w with
  | nil => fun q' => q' = q
  |x::w' => fun q'' => exists q', delta_Q q x q' /\ delta_Q_star q' w' q''
  end.
Arguments delta_Q_star {B} q w q'.

Instance delta_Q_star_dec B (q q': B) w: dec (delta_Q_star q w q').
Proof.
 revert q. induction w.
  - cbn. auto.
  - intros q. cbn. auto.
Qed.

Lemma delta_Q_star_trans B w w' (q q' q'': B) : delta_Q_star q w q' /\ delta_Q_star q' w' q'' -> delta_Q_star q (w ++ w') q''.
Proof.
  intros [H H']. revert q H. induction w; intros q H.
  - cbn in *. congruence.
  - cbn in *. destruct H as [q_m [D H]]. exists q_m. split.
    + exact D.
    + now apply IHw.
Qed.

Definition n_accept B w := exists (q:B), Q_acc q /\ delta_Q_star q0 w q.

Definition toNFA A := @NFA (S A) s F (fun q x => DecPred (fun q' => delta_S q x = q')).

Lemma toNFA_delta_star_correct A q w q': q' = delta_star q w <-> @delta_Q_star (toNFA A) q w q'.
Proof.
  revert q. induction w.
  - reflexivity.
  - intro q; cbn. rewrite IHw. split.
    +eauto.
    +now intros [q'' [[] H]].
Qed.

Lemma toNFA_correct A : forall w, accept A w <-> n_accept (toNFA A) w.
Proof.
  intros w. unfold accept, n_accept. split.
  - intros H. exists (delta_star s w). now rewrite <- toNFA_delta_star_correct.
  - intros [q [acc H]]. rewrite <- toNFA_delta_star_correct in H. now subst q.
Qed.

Definition toDFA_F B := fun f: B --> bool => exists q, f q /\ Q_acc q.

Definition toDFA_delta B := fun (f: B --> bool) x => vectorise (fun q => toBool (exists q':B, f q' /\ delta_Q q' x q)).

Lemma toDFA_delta_correct B f x q : toDFA_delta f x q -> exists q':B, f q' /\ delta_Q q' x q.
Proof.
  intros H.   unfold toDFA_delta in H. rewrite apply_vectorise_inverse in H. unfold toBool in H. dec.
  - assumption.
  - contradiction H.
Qed.

Definition onestate B q:= (vectorise (fun q':B => toBool (q' = q) )).

Lemma onestate_correct B q q' : @onestate B q q' <-> q = q'.
Proof.
  unfold onestate. rewrite apply_vectorise_inverse. unfold toBool. dec; cbn.
  - subst q. tauto.
  - split; [>tauto | auto].
Qed.

Definition toDFA B := DFA (onestate q0) (DecPred (@toDFA_F B)) (@toDFA_delta B).

Lemma toDFA_delta_star_correct1 B q w q':
  delta_Q_star q w q' -> forall f: B --> bool, f q -> applyVect (@delta_star (toDFA B) f w) q'.
Proof.
  intros H f F. revert f q F H. induction w; intros f q F H; cbn in *.
   -  now subst q'.
   - destruct H as [q'' [H S]]. eapply IHw; eauto.
      unfold toDFA_delta. rewrite apply_vectorise_inverse. unfold toBool. dec.
     + exact I.
     + apply n. now exists q.
  Qed.

Lemma toDFA_delta_star_correct2 B (f: B --> bool) w q':
  applyVect (@delta_star (toDFA B) f w) q' -> exists q, f q /\ delta_Q_star q w q'.
Proof.
  revert f. induction w.
  - cbn. eauto.
  - intros f. cbn. intros H. specialize (IHw _ H). destruct IHw as [q'' [E E']].
    destruct (toDFA_delta_correct E). firstorder.
Qed.

Lemma toDFA_correct B w: n_accept B w <-> accept (toDFA B) w.
Proof.
  cbn. unfold n_accept, toDFA_F. split.
  -  intros [q [acc G]]. exists q; split.
     + apply (toDFA_delta_star_correct1 G). now apply onestate_correct.
     + exact acc.
  -  intros [q [H acc]]. exists q; split.
     + exact acc.
     + destruct (toDFA_delta_star_correct2 H) as [q' [E D]]. rewrite onestate_correct in E. now subst q'.
Qed.

(** * Concatenation of two regular languages *)

Definition concat_acc_pred B B' := fun (q: B + B') => match q with
                                             | inl q => if decision (Q_acc (@q0 B')) then Q_acc q else False
                                             | inr q => Q_acc q
                                             end.

Instance acc_dec B B' q: dec (@concat_acc_pred B B' q).
Proof.
  destruct q as [q | q].
  - cbn. dec; auto.
  - auto.
Qed.

Definition concat_acc_decPred B B':= DecPred (@concat_acc_pred B B').

Definition concat_delta B B' (q q': B + B') x:= match q with
                                          | inl q => match q' with
                                                    | inl q' => delta_Q q x q'
                                                    | inr q' => if decision (@Q_acc B q) then delta_Q q0 x q' else False
                                                    end
                                          | inr q => match q' with
                                                    | inl q' => False
                                                    | inr q' => delta_Q q x q'
                                                    end
                                          end.

Instance conact_delta_dec B B' (q: B + B') x q' : dec (concat_delta q q' x).
Proof.
  destruct q, q'.
  - auto.
  - cbn. dec; auto.
  - auto.
  - auto.
Qed.

Definition concat_delta_Q B B':= fun (q: B + B') x => DecPred (fun q' => concat_delta q q' x).

Definition concat B B' := NFA (inl (@q0 B)) (@concat_acc_decPred B B') (@concat_delta_Q B B').

Lemma concat_delta_Q_star_correct1 B B' q q' w: @delta_Q_star (concat B B') (inr q) w (inl q') <-> False.
Proof.
  split; try tauto. revert q; induction w; intro q.
  - congruence.
  - cbn. intros [[q''|q''] H]; firstorder.
Qed.

Lemma concat_delta_Q_star_correct2 B B' q q' w:  @delta_Q_star (concat B B') (inl q) w (inl q') <->   delta_Q_star q w q'.
Proof.
  split; revert q; induction w; intro q; try congruence.
  - intros [[q''|q''] [S H]].
    + exists q''. firstorder.
    + now rewrite concat_delta_Q_star_correct1 in H.
  - intro H. firstorder.
Qed.

Lemma concat_delta_Q_star_correct3 B B' q q' w:  @delta_Q_star (concat B B') (inr q) w (inr q') <->   delta_Q_star q w q'.
Proof.
  split; revert q; induction w; intro q; try congruence.
  - intros [[q''|q''] [S H]].
    + contradiction S.
    + exists q''. firstorder.
  - intro H. firstorder.
Qed.

Lemma concat_delta_Q_star_correct4 B B' q q' w:  @delta_Q_star (concat B B') (inl q) w (inr q') <->   exists w' q'', delta_Q_star q w' q'' /\ Q_acc q'' /\ exists w'', w = w' ++ w'' /\ delta_Q_star q0 w'' q' /\ (w'' = nil -> q0 <> q').
Proof.
  split; revert q; induction w; intro q; try congruence.
  -intros [[q''|q''] [S H]].
    + specialize (IHw q'' H). destruct IHw as [w' [q_m [S' [acc [w'' [E [D IHw]]]]]]]. exists (a::w'), q_m. repeat split.
      * cbn. now exists q''.
      * exact acc.
      * subst w. exists w''. tauto.
     +  exists nil, q. cbn in S. dec; repeat split; try tauto.
         exists (a::w). cbn. repeat split; try congruence.
           exists q''. split.
           *  exact S.
           *  eapply concat_delta_Q_star_correct3. exact H.
 - intros [w' [_ [_ [_ [w'' [E [D H]]]]]]]. symmetry in E. pose proof ( app_eq_nil _ _ E) as [E1 E2].  subst w'' w'.
   cbn in *. exfalso; now apply H.
 - intros [w' [q'' [H [ acc [w'' [E [D S]]]]]]]. cbn. destruct w'.
    + cbn in *. subst q'' w''. destruct D as [q'' [D H]]. exists (inr q''). split.
       * now dec.
       * now apply concat_delta_Q_star_correct3.
    +  cbn in *. inv E. destruct H as [q1 [D' H]].  exists (inl q1).  eauto 10.
Qed.

Lemma concat_correct  B B' w : n_accept (concat B B') w <-> exists w' w'', n_accept B w' /\ n_accept B' w'' /\ w = w' ++ w''.
Proof.
  split.
  - intros acc. destruct acc as [q [acc H]]. destruct q as [q |q].
    + cbn in H. rewrite concat_delta_Q_star_correct2 in H. exists w, nil. rewrite app_nil_r. cbn in acc. dec; firstorder.
    + cbn in H.  rewrite concat_delta_Q_star_correct4 in H.  firstorder.
  -  intros [w' [w'' [[q1 [acc1 D1]] [[q2 [acc2 D2]] eqn]]]]. destruct w''.
     +  rewrite app_nil_r in eqn.  subst w'. exists (inl q1). cbn. dec.
      * now rewrite concat_delta_Q_star_correct2.
      * cbn in D2. subst q2. tauto.
     + subst w. exists (inr q2). split; auto. cbn. rewrite concat_delta_Q_star_correct4.
       exists w', q1. firstorder. exists (e::w''). firstorder. congruence.
Qed.
(** * Kleene Operator *)

Definition kleene_acc_pred B := fun q => match q with
                                      | None => True
                                      | Some q => @Q_acc B q end.

Instance kleene_acc_dec B (q: option B): dec (kleene_acc_pred q).
Proof.
  unfold kleene_acc_pred. destruct q; auto.
Qed.

Definition kleene_acc_decPred B:= DecPred (@kleene_acc_pred B).

Definition kleene_delta B (q: option B) x q':= match q' with
                                                            | Some q' => match q with
                                                                        | None => delta_Q q0 x q'
                                                                        | Some q => delta_Q q x q' \/ (Q_acc q /\ delta_Q q0 x q')
                                                                        end
                                                            | _ => False end.
Instance kleene_delta_dec B (q q': option B) x : dec (kleene_delta q x q').                                                        Proof.
destruct q, q'; auto.                                                                                Qed.

Definition kleene_star B := NFA (None) (@kleene_acc_decPred B) (fun (q: option B) x => DecPred (fun q' => kleene_delta q x q')).

Lemma nil_kleene B : n_accept (kleene_star B) nil.
Proof.
  unfold n_accept.  now exists q0.
Qed.

Lemma kleene_delta_ok1 B (q q': B) w: delta_Q_star q w q' -> @delta_Q_star (kleene_star B) (Some q) w (Some q').
Proof.
  revert q. induction w; intros q H.
  - cbn in *. congruence.
  - cbn in *.  firstorder.
Qed.

Lemma kleene_delta_ok2 B q q' x w:
  Q_acc q -> @delta_Q_star (kleene_star B) None (x::w) q' -> @delta_Q_star (kleene_star B) q (x::w) q'.
Proof.
  intros acc H. cbn in *. unfold kleene_acc_pred in acc. destruct q.
  - destruct H as [q'' [D H]]. exists q''. split.
    + unfold kleene_delta. destruct q''.
      * tauto.
      * contradiction D.
    + exact H.
  - exact H.
Qed.

Lemma kleene_delta_ok_3 B w:  n_accept B w -> n_accept (kleene_star B) w.
  destruct w.
  - intros _. apply nil_kleene.
  -  intros [q [acc H]]. exists (Some q). split.
     + exact acc.
     + destruct H as [q' [H' H]]. exists (Some q'). split.
       * exact H'.
       * now apply kleene_delta_ok1.
Qed.

Lemma kleene_delta_ok_4 B x w q': @delta_Q_star B q0  (x:: w) q' -> @delta_Q_star (kleene_star B) q0 (x::w) (Some q').
Proof.
  cbn. intros [q [H S]]. exists (Some q). split.
  + exact H.
  + now apply kleene_delta_ok1.
Qed.

Lemma kleene_delta_ok_5 B a w:
  n_accept B a -> n_accept (kleene_star B) w -> n_accept (kleene_star B) (a++ w).
Proof.

    (* If there is a rest (w is not empty), then the last state is the last state after reading w, otherwise it is the last state after reading a. we need to know which one it is because we have to commit to a  final state now *)
  destruct w.
  - rewrite app_nil_r. intros H _. now apply kleene_delta_ok_3.
  -  destruct a.
     + now cbn.
     + intros [q' [acc' H]] [q [acc H1]]. exists q. split.
       * exact acc.
       * eapply delta_Q_star_trans. split.
         {
           apply kleene_delta_ok_4. exact H.
         }
         {
           now apply kleene_delta_ok2.
         }
Qed.

Lemma kleene_star_correct1 B w: (forall w', w' el w -> n_accept B w') -> n_accept (kleene_star B) (List.concat w).
Proof.
  induction w.
  - cbn. intros _. apply nil_kleene.
  - intros H.
    assert (forall w', w' el w -> n_accept B w') as ass by firstorder. specialize (IHw ass); clear ass.
    cbn. apply kleene_delta_ok_5.
    + now apply H.
    + exact IHw.
Qed.

Lemma kleene_delta_ok6  B (q:B) w (q':B) :
  @delta_Q_star (kleene_star B) (Some q) w (Some q') -> @delta_Q_star B q w q' \/ exists w' w'' q'', w = w' ++ w'' /\ Q_acc q'' /\ @delta_Q_star B q w' q'' /\ @delta_Q_star (kleene_star B) None w'' (Some q').
Proof.
  revert q. induction w; intros q H.
  - left. cbn in H. now inv H.
  - destruct H as [q_m [H D]]. destruct q_m; try contradiction H. specialize (IHw _ D). destruct H as [H |acc H].
    + destruct IHw as [IHw | [w' [w'' [q'' [E [acc IHw]]]]]].
      *  firstorder.
      *  right. exists (a::w'), w''. subst w. exists q''.  firstorder.
    + right. exists nil, (a::w), q. cbn. firstorder.
Qed.

Lemma kleene_delta_ok7 B q  w :
  @delta_Q_star (kleene_star B) q w None <-> q= None /\ w = nil.
Proof.
  split.
  - revert q. induction w; intros q H.
    + cbn in H. now subst q.
    + cbn in H. destruct H as [q' [D H]]. specialize (IHw _ H). destruct IHw as [E E']. subst q' w.
      contradiction D.
  - intros [E E']. now subst q w.
Qed.

(* w must not be empty because kleene_star B accepts nil no matter what B does. *)
Lemma kleene_delta_ok8 B x w:
  n_accept (kleene_star B) (x::w) -> n_accept B (x::w) \/ exists w' w'', w = w' ++ w'' /\ n_accept B (x::w') /\ n_accept (kleene_star B) w''.
Proof.
  intros [q  [acc [q' [H S]]]]. cbn in *. destruct q, q'.
  - pose proof (kleene_delta_ok6 S) as [H'|H']; clear S.
    + left. exists e. firstorder.
    + right. destruct H' as [w' [w'' [q [E [acc' [S S']]]]]]. exists w', w''. firstorder.
  - contradiction H.
  - rewrite kleene_delta_ok7 in S. destruct S as [S _]. discriminate S.
  - contradiction H.
Qed.

Lemma kleene_star_correct2 B w :
  n_accept (kleene_star B) w -> exists w', List.concat w' = w /\  (forall w'', w'' el w' -> n_accept B w'').
Proof.
   intros H. induction w using (@size_induction _ (@length Sig)). destruct w.
-  exists nil. firstorder.
- destruct (kleene_delta_ok8 H) as [H' | H']; clear H.
  + exists [(e::w)]. cbn. rewrite app_nil_r. split.
    * reflexivity.
    * now intros w' [[]|  []].
  + destruct H' as [w' [w'' [E [acc1 acc2]]]].
    assert (|w''| < | e::w|) as L.
    {
      subst w. cbn. rewrite app_length. omega.
    }
    specialize (H0 w'' L acc2); clear L. destruct H0 as [w1 [E' H]]. exists ((e::w')::w1). split.
    * cbn. rewrite E'. now subst w.
    * intros w2 [[]|H']; auto.
Qed.

Lemma kleene_star_correct B w:  n_accept (kleene_star B) w <-> exists w', List.concat w' = w /\  (forall w'', w'' el w' -> n_accept B w'').
Proof.
  split.
  - apply kleene_star_correct2.
  - intros [w' [[] H]]. now apply kleene_star_correct1.
Qed.

End DFA.


(*
    Exercise 1.
*)

(*a*)
Theorem taut1: (True \/ False) /\ (False \/ True).
    split. left. constructor. right. constructor.
Qed.

(*b*)
Theorem taut2: forall P: Prop, P -> ~~P.
    intros. unfold not. intro. destruct H0. assumption.
Qed.

(*c*)
Theorem taut3: forall P Q R,
    P /\ (Q \/ R) -> (P /\ Q) \/ (P /\ R).
    intros.
    destruct H. (* Split P /\ (Q \/ R) into P and Q \/ R *)
    destruct H0. (* Split Q \/ R into Q and R *)
    left. split. assumption. assumption. (* Prove the P /\ Q case *)
    right. split. assumption. assumption. (* Prove the P /\ R case *)
Qed.


Require Export XR_R.
Require Export XR_Rle.
Require Export XR_total_order_T.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rlt_le_dec : forall r1 r2, {r1 < r2} + {r2 <= r1}.
Proof.
  intros x y.
  destruct (total_order_T x y) as [ [ hxy | heq ] | hyx ].
  {
    left.
    exact hxy.
  }
  {
    subst y.
    right.
    unfold "<=".
    right.
    reflexivity.
  }
  {
    right.
    unfold "<=".
    left.
    exact hyx.
  }
Qed.