From Coq Require Export Bool.
Require Export Omega.
Require Export List.
Export ListNotations.
(* for set_union *)
From Coq Require Export Lists.ListSet.
(* for composition *)
Require Export Basics.
Require Export Setoid.
Require Export Morphisms.
Require Export Relation_Definitions.

Require Export SmolkaUtilities.

Require Export Utilities.
Require Export TheoryDef.
Require Export TermsUtilities.

(** * Definitions *)

(** ** Substitutions as association lists *)

Definition subL := list (var * term).

(** *** The identity substitution *)

Definition id_sub: subL := [].

(** ** Applying a substitution *)

(** ...to a variable *)

Fixpoint apply_sub_var (sigma: subL) (v: var) : term :=
  match sigma with
  | [] => V v
  | (v1, t1):: rest => if decision (v1= v) then t1
                       else apply_sub_var rest v
  end.

(** ...to a term *)

Fixpoint apply_sub (sigma: subL) (t : term) : term :=
  match t with
  | T0 => t
  | T1 => t
  | V v  => apply_sub_var sigma v
  | A t1 t2 => (apply_sub sigma t1) +' (apply_sub sigma t2)
  | M t1 t2 => (apply_sub sigma t1) *' (apply_sub sigma t2)
  end.

Notation "s @ t" := (apply_sub s t) (at level 50).
Notation "s @' v" := (apply_sub_var s v) (at level 50).

(** *** Relational version of apply_sub *)

Inductive Apply_sub: subL -> term -> term -> Prop :=
| S0 : forall (sigma: subL),
    Apply_sub sigma T0 T0
| S1 : forall (sigma: subL),
    Apply_sub sigma T1 T1
| Snil : forall (t: term),
    Apply_sub [] t t
| SVhead : forall (x: var) (u: term) (rest: subL),
    Apply_sub ((x,u)::rest) (V x) u
| SVtail : forall (x y: var) (irrel u: term) (rest: subL),
    x <> y ->
    Apply_sub rest (V x) u ->
    Apply_sub ((y,irrel) :: rest) (V x) u
| SA : forall (sigma: subL) (t1 t2 u1 u2: term),
    Apply_sub sigma t1 u1 ->
    Apply_sub sigma t2 u2 ->
    Apply_sub sigma (A t1 t2) (A u1 u2)
| SM : forall (sigma: subL) (t1 t2 u1 u2: term),
    Apply_sub sigma t1 u1 ->
    Apply_sub sigma t2 u2 ->
    Apply_sub sigma (M t1 t2) (M u1 u2).

Hint Constructors Apply_sub.

(** ** Domain and range of a sub *)

Fixpoint domain_sub (sigma: subL) : (list var) :=
  match sigma with
  | [] => []
  | (x, _) :: rest => x :: (domain_sub rest)
  end.

Fixpoint range_sub (sigma: subL) : (list term) :=
  match sigma with
  | [] => []
  | (_, t) :: rest => t :: (range_sub rest)
  end.

Definition in_dom (v: var) (s: subL) : Prop :=
  In v (map fst s).

(*  Bool version *)

(* Fixpoint inb_dom (v: var) (s: subL) : bool := *)
(*   match s with *)
(*   | [] => false *)
(*   | (v1, _)::s1 => if Nat.eqb v v1 then true *)
(*                    else inb_dom v s1 *)
(*   end. *)

(** *** Every variable of t is in the domain of sigma? *)

Fixpoint sub_maps_all_vars (sigma: subL) (t: term) : bool :=
  match t with
  | T0 => true
  | T1 => true
  | (V x) => inb x (vars_term t)
  | A t1 t2 =>  (sub_maps_all_vars sigma t1)
                  && (sub_maps_all_vars sigma t2)
  | M t1 t2 =>  (sub_maps_all_vars sigma t1)
                  && (sub_maps_all_vars sigma t2)
  end.

(** **  Updating a sub *)

(** This is easier to reason about than the version which _replaces_ the old binding *)

Definition update_subL (sigma: subL) (x: var) (u: term) : subL :=
  (x, u) :: sigma.

(** ** Composition *)

Definition compose (second_sub first_sub: subL) : subL :=
  map (fun p => (fst p, second_sub @ snd p)) first_sub.

(** ** Ground Substitutions *)

(** *** Every term in the range of sigma is ground? *)

Fixpoint ground_sub (sigma : subL) : bool :=
  match sigma with
  | [] => true
  | (_, t) :: rest =>
    (ground_term t) && (ground_sub rest)
  end.

(** *** Applying sigma results in a ground term? *)

Definition grounding (sigma : subL) (t : term) :=
  ground_term (sigma @ t).

(* Definition grounding_OLD (sigma : subL) (t : term) := *)
(*   (ground_sub sigma) *)
(*     && (sub_maps_all_vars sigma t). *)

(** * Ordering on Substitutions *)

(** Two choices in the definitions:
- whether the condition holds for all variables or not
- whether the mediating substitution is the same as the larger one
 *)

Definition sub_leq_all_vars sigma gamma : Prop :=
  exists (tau: subL), forall (x: var),
      (tau @ (sigma @ (V x)))
      == (gamma @ (V x)).

Definition sub_leq_localvars sigma gamma (l: list var) : Prop :=
  exists (tau: subL), forall (x: var),
      In x l ->
      (tau @ (sigma @ (V x)))
      == (gamma @ (V x)).

(** *** These strong versions are appropriate for idempotent subs:
    the witness for sigma <= gamma is gamma itself.*)

Definition sub_leq_strong_all_vars sigma gamma : Prop :=
  forall (x: var),
    ( gamma @ ( @ sigma (V x)))
    == ( gamma @ (V x)).

Definition sub_leq_strong_local_vars sigma gamma (l: list var) : Prop :=
  forall (x: var),
    In x l ->
    ( gamma @ ( @ sigma (V x)))
    == ( gamma @ (V x)).

(** * 0/1 substitutions *)

Fixpoint is_01sub (sigma: subL) : bool :=
  match sigma with
  | [] => true
  | (x, t):: rest => ((Nat.eqb x 0) && (is_01sub rest))
                     || ( (Nat.eqb x 1) && (is_01sub rest))
  end.

(** ** All the 0/1 subs appropriate to a term *)

Fixpoint all_01subs_list (vars : list var) : list subL :=
  match vars with
  | [] => [id_sub]
  | x :: xs => let subs := all_01subs_list xs in
               (map (fun s => update_subL s x T0) subs)
                 ++
                 (map (fun s => update_subL s x T1) subs)
  end.

Inductive All01 : (list var) -> subL ->  Prop :=
| All01_nil : All01 [] id_sub
| All01_cons0 : forall (x: var) (vars: list var) (sigma: subL),
    All01 vars sigma ->
    All01 (x::vars) ((x, T0) :: sigma)
| All01_cons1 : forall (x: var) (vars: list var) (sigma: subL),
    All01 vars sigma ->
    All01 (x::vars) ((x, T1) :: sigma).

Definition all_01subs (t: term) : list subL :=
  all_01subs_list (vars_term t).

(** * Unifiers, MGUs, and All That *)

(** @@ TODO: rephrase these in terms of sub_leq *)

Definition solves   (sigma: subL) (t: term) :=
  sigma @ t == T0.

Definition solvable (t: term) : Prop :=
  exists (sigma: subL), solves sigma t.

(** *** The most general notion *)

Definition mguX  (sigma: subL) (t: term): Prop :=
  (solves sigma t) /\
  forall (gamma: subL),
    (solves gamma t) ->
    exists (gamma': subL),
    forall (x: var), (In x (vars_term t) ->
                      ( gamma' @ ( sigma @ (V x)))
                      == ( gamma @ (V x))).

(** *** A strengthening: the mediating sub is the given less-general one *)

Definition mgu_strongX  (sigma: subL) (t: term): Prop :=
  (solves sigma t) /\
  forall (gamma: subL),
    (solves gamma t) ->
    forall (x: var), (In x (vars_term t) ->
                      ( gamma @ ( sigma @ (V x)))
                      == ( gamma @ (V x))).

(** *** A different strengthening: the condition apples to all variables *)

Definition mgu_all  (sigma: subL) (t: term): Prop :=
  (solves sigma t) /\
  forall (gamma: subL),
    (solves gamma t) ->
    exists (gamma': subL),
    forall (x: var),
      ( gamma' @ ( sigma @ (V x)))
      == ( gamma @ (V x)).

(** *** Both strengthenings *)

Definition mgu_strong_all  (sigma: subL) (t: term): Prop :=
  (solves sigma t) /\
  forall (gamma: subL),
    (solves gamma t) ->
    forall (x: var),
      ( gamma @ ( sigma @ (V x)))
      == ( gamma @ (V x)).

Definition mgu (sigma: subL) (t: term): Prop :=
  mgu_strong_all sigma t.

(** Baader and Nipkow use "reproductive" for our strong mgu property *)

Definition reproductive_solution := mgu.

(* *********************************************** *)
(* *********************************************** *)

(** * Reasoning About Substitutions *)

(** ** Decidability for subs *)
Instance varterm_eq_dec :
  eq_dec (var * term).
Proof.
  unfold dec.
  decide equality.
  apply term_eq_dec.
  apply var_eq_dec.
Qed.
Hint Resolve varterm_eq_dec.

Instance sub__eq_dec :
  eq_dec subL.
Proof.
  unfold dec.
  unfold subL.
  decide equality.
  apply varterm_eq_dec.
Qed.

(** *** Duh *)

Lemma apply_sub_id t : ( id_sub @ t) == t.
Proof.
  unfold apply_sub.
  induction t; auto.
Qed.
Hint Resolve apply_sub_id.

(** **  How subs apply to vars *)

(** *** At the head *)

(** Maybe more useful than the corresponding result about apply_sub
itself (eg after we have done simpl in a proof) *)

Lemma apply_sub_var_head x t rest :
  ((x,t) :: rest) @' x = t.
Proof.
  simpl. now decide (x=x).
Qed.

(** *** In the tail  *)

Lemma apply_sub_var_tail x y t rest :
  x <> y ->
  ((x,t) :: rest) @' y =

  rest @' y.
Proof.
  simpl.
  now decide (x=y).
Qed.

Lemma not_domain_no_change (sigma: subL) (v : var) :
  ~ v el (domain_sub sigma) ->
  sigma @ (V v) = (V v).
Proof.
  intros H.
  induction sigma as [| (x, t) rest].
  - easy.
  - decide (x=v).
    + firstorder.
    + assert (A1:= apply_sub_var_tail x v t rest n).
      unfold apply_sub.
      rewrite A1.
      apply IHrest.
      firstorder.
Qed.

(** *** Updated sub on the new variable *)

Lemma apply_updated_sub_on (sigma: subL) (x: var) (u: term) :
  (update_subL sigma x u) @  (V x) = u.
Proof.
  intros.
  induction sigma as [| (v, t) rest].
  - simpl. now decide (x=x).
  - simpl.
    decide (v=x).
    +
      now apply eq_if_eq_dec.
    +
      assert (a:= apply_sub_var_tail v x t (update_subL rest x u) n).
      now apply eq_if_eq_dec.
Qed.

(** *** Updates do nothing new off of the updated variable *)

Lemma apply_updated_sub_off_var (sigma: subL) (x y: var) (u: term) :
  x <> y ->
  (update_subL sigma x u) @  (V y) = sigma @ (V y).
Proof.
  intros Hneq.
  simpl.
  induction sigma as [| (v, t) rest].
  - simpl.
    now decide (x=y).
  - simpl.
    decide (v=x).
    now apply neq_if_eq_dec.
    now apply neq_if_eq_dec.
Qed.

(** *** Updates do nothing new if updated variable missing *)

Lemma apply_updated_sub_off (sigma: subL) (x: var) (u t: term) :
  ~ x el (vars_term t) ->
  (update_subL sigma x u) @ t = sigma @ t .
Proof.
  intros Hnotel.
  induction t as [ | | y | t1 IH1 t2 IH2  | t1 IH1 t2 IH2 ]; simpl; auto.
  - simpl in Hnotel.
    rewrite DM_or in Hnotel.
    destruct Hnotel.
    apply (apply_updated_sub_off_var).
    firstorder.
  - assert (a:= not_vars_term_A_L t1 t2 x Hnotel).
    assert (b:= not_vars_term_A_R t1 t2 x Hnotel).
    rewrite IH1. rewrite IH2. auto. easy. easy.
  - assert (a:= not_vars_term_M_L t1 t2 x Hnotel).
    assert (b:= not_vars_term_M_R t1 t2 x Hnotel).
    rewrite IH1. rewrite IH2. auto. easy. easy.
Qed.

(** ** Substitutions are homomorphisms *)

Lemma apply_sub_T0_hom sigma :
  sigma @ T0 == T0.
Proof. auto.
Qed.

Lemma apply_sub_T1_hom sigma :
  sigma @ T1 == T1.
Proof. auto.
Qed.

Lemma apply_sub_A_hom sigma s1 s2 :
  sigma @ (s1 +' s2) ==   (sigma @ s1) +' (sigma @ s2).
Proof.
  auto.
Qed.
Hint Resolve apply_sub_A_hom.

Lemma apply_sub_M_hom sigma s1 s2 :
  sigma @ (s1 *' s2) ==   (sigma @ s1) *' (sigma @ s2).
Proof.
  auto.
Qed.
Hint Resolve apply_sub_M_hom.

(** ** Applying a sub preserves eqv *)

Lemma apply_sub_compat : forall (sigma: subL) (t t' : term),
    t == t' -> (sigma @ t) == (sigma  @ t').
Proof.
  intros sigma t t' H.
  induction H; subst;  simpl; auto.
  (* inversion H; subst;  simpl; auto. *)
  eapply eqv_trans with (sigma @ y); auto.
Qed.

Add Parametric Morphism : apply_sub with
      signature eq ==> eqv ==> eqv as apply_sub_mor.
  exact apply_sub_compat.
Qed.

(** ** Solvability respects eqv *)

(** A consequence of compatibility of apply_sub *)

Lemma solves_compat : forall (sigma: subL) (t t': term),
    t == t' ->
    solves sigma t ->
    solves sigma t'.
Proof.
  unfold solves.
  intros sigma t t' Heqv Hsolves.
  now rewrite Heqv in Hsolves.
Qed.

(*
Lemma compose_action (second_sub first_sub: subL) (t: term) :
  (compose second_sub first_sub) @ t =
   second_sub @ (first_sub @ t).
Proof.
  induction t as [ | | x | t1 t2 | t1 t2]; simpl; auto.
  - unfold compose.
  @@ stop

(** If two subs agree on vars then they agree everywhere *)

Lemma vars_determine (sigma1 sigma2 : subL) :
  (forall (x: var), (sigma1 @ (V x) = sigma1 @ (V x)) ) ->
  (forall (t: term), (sigma1 @ t = sigma1 @ t)).
Proof.
  @@ stop

 *)
Lemma leq_on_terms (tau sigma : subL) :
  (forall x : var, tau @ (sigma @ V x) == tau @ V x) ->
  (forall t: term, tau @ (sigma @ t) == tau @ t).
Proof.
  intros H.
  induction t as [ | | x | t1 t2 | t1 t2]; simpl; auto.
  rewrite (H x); now  simpl.
Qed.

(** ** Applying a sub to a ground term has no effect *)

Lemma sub_Ground  (sigma: subL) (t: term) :
  Ground_term t -> ( sigma @ t) = t.
Proof.
  intros H.
  induction H; simpl; auto.
  - now rewrite IHGround_term1; rewrite IHGround_term2.
  - now rewrite IHGround_term1; rewrite IHGround_term2.
Qed.

Lemma sub_ground_term (sigma: subL) (t: term) :
  (ground_term t) = true -> ( sigma @ t) = t.
Proof.
  intros H.
  assert (a:= ground_is_Ground t H).
  apply (sub_Ground sigma t a).
Qed.

(** Equivalence between apply_sub and Apply_sub *)

(* @@ ?? All of a sudden [2019 Jan 18] I need to repeat this, from
Utilities, on type "var" not recognized as a type alias for nat ?????
 *)

Lemma dec_if_var (U: Type) (x y: var)  (u v: U) :
  x<>y ->
  (if decision (x=y) then u else v) = v.
Proof.
  exact (neq_if_eq_dec x y u v).
Qed.
Arguments dec_if_var {U} x y u v.

Lemma Apply_sub_var_apply (sigma: subL) : forall  x t,
    Apply_sub sigma (V x) t ->   apply_sub_var sigma x = t.
Proof.
  induction sigma.
  - intros x t H.
    now inversion H; subst.
  - intros x t H.
    inversion H; subst; simpl.
    + now decide (x=x).
    + assert (a:= IHsigma x t H5).
      assert (b: y<>x).  now apply neq_comm.
      rewrite (dec_if_var y x irrel (apply_sub_var sigma x)).
      -- now apply IHsigma.
      -- congruence.
Qed.

(* Lemma Apply_sub_var_apply (sigma: subL) : forall  x t, *)
(*     Apply_sub sigma (V x) t ->   apply_sub_var sigma x = t. *)
(* Proof. *)
(*   induction sigma. *)
(*   - intros x t H. *)
(*     now inversion H; subst. *)
(*   - intros x t H. *)
(*     inversion H; subst; simpl. *)
(*     + now decide (x=x). *)
(*     + rewrite dec_if. *)
(*       -- now apply IHsigma. *)
(*       -- congruence. *)
(* Qed. *)

Lemma Apply_sub_apply sigma s t:
  Apply_sub sigma s t ->    sigma @ s = t.
Proof.
  revert sigma t.
  induction s.
  (* T0 *)
  - intros sigma t H.
    inversion H; simpl; auto.
  (* T1 *)
  - intros sigma t H.
    inversion H; simpl; auto.
  (* Var *)
  - intros sigma t H.
    now apply Apply_sub_var_apply.
  (* Sum *)
  - intros sigma t H.
    simpl.
    inversion H; subst.
    rewrite (IHs1 [] s1). now rewrite (IHs2 [] s2).
    apply Snil.
    assert (a := IHs1 sigma u1 H3).
    assert (b := IHs2 sigma u2 H5).
    rewrite a. now rewrite b.
  (* Product *)
  - intros sigma t H.
    simpl.
    inversion H; subst.
    rewrite (IHs1 [] s1). now rewrite (IHs2 [] s2).
    apply Snil.
    assert (a := IHs1 sigma u1 H3).
    assert (b := IHs2 sigma u2 H5).
    rewrite a. now rewrite b.
Qed.

Lemma beq_nat_false_tst (n m: nat) :
  n <> m -> (n =? m) = false.
Proof.
  apply beq_nat_false_iff.
Qed.

Hint Resolve beq_nat_false_tst.

Lemma apply_sub_Apply_var : forall v sigma,
    Apply_sub sigma (V v) (apply_sub_var sigma v).
Proof.
  intros v.
  induction sigma as [| (v1, t1) rest].

  (* sigma is [] *)
  - now simpl.

  (* sigma is  (v1, t1) :: rest *)
  - simpl.
    destruct (beq_reflect v1 v) as [y|n].
    -- rewrite y.
       decide (v=v).
    + apply SVhead.
    + easy.
      -- rewrite neq_if_eq_dec.
         apply SVtail.
         ++ congruence.
         ++ easy.
         ++ congruence.
Qed.

Lemma apply_sub_Apply' sigma t:
  Apply_sub sigma t ( sigma @ t).
Proof.
  revert sigma.
  induction t.
  (* T0 *)
  - intros sigma.
    apply S0.
  - intros sigma. apply S1.
  (* Var *)
  - intros sigma.
    apply apply_sub_Apply_var.

  (* t1 + t2 *)
  - intros sigma.
    simpl.
    apply SA; easy.

  (* t1 * t2 *)
  - intros sigma.
    simpl.
    apply SM; easy.
Qed.

Lemma apply_sub_Apply sigma t u:
  sigma @ t = u ->
  Apply_sub sigma t u.
Proof.
  intros H.
  rewrite <- H.
  apply apply_sub_Apply'.
Qed.

(*
We have
               Apply sigma s t <-> apply sigma s = t

and

<< apply sigma s = t      s == s'       apply sigma s' t'
   ----------------------------------------------------
                        t == t'
>>
and
<<
                   Apply sigma s t      s == s'
                ---------------------------------------
                 exists t', t == t' and Apply sigma s' t'
>>

might want
<<                Apply sigma s t      s == s'
                ---------------------------
                      Apply sigma s' t
>>
but that won't be true unless we build it in.

 *)

Lemma Apply_compat sigma s s' t  :
  Apply_sub sigma s t ->
  s == s' ->
  exists t',   t' == t /\
               Apply_sub sigma s' t'.
Proof.
  intros H1 H2 .

  assert (a:= (Apply_sub_apply sigma s t) H1).
  assert (b:= (apply_sub_compat sigma s s') H2).

  exists (sigma @ s').
  split.
  - now rewrite a in b.
  - apply (apply_sub_Apply sigma s' (sigma @ s')).
    now rewrite a in b.
Qed.

(** ** Some 01_subs results *)

Lemma all_01subs_add_1 t :
  all_01subs t = all_01subs (t +' T1).
Proof.
  unfold all_01subs.
  assert (vars_term t = vars_term (t +' T1)).
  simpl. apply app_nil_end.
  now rewrite H.
Qed.

Lemma update0_all01subs (x: var) (vars : list var) (sigma: subL) :
  sigma el (all_01subs_list vars) ->
  (update_subL sigma x T0) el all_01subs_list (x::vars).
Proof.
  intros H.
  unfold update_subL.
  simpl.
  apply el_app_L.
  unfold update_subL.
  now apply in_map.
Qed.

Lemma update1_all01subs (x: var) (l' : list var) (sigma: subL) :
  sigma el (all_01subs_list l') ->
  (update_subL sigma x T1) el all_01subs_list (x::l').
Proof.
  intros H.
  unfold update_subL.
  simpl.
  apply el_app_R.
  unfold update_subL.
  now apply in_map.
Qed.

(*

(** This shouldn't be this complicated.  ? *)

Lemma blah1 (sigma : subL) (x: var) :
  x el domain_sub sigma ->
  (exists (t: term), (t el range_sub sigma) /\
                     (sigma @ (V x)) = t).
Proof.
  intros H.
  induction sigma as [ | [v u] rest IH ].
  - inversion H.
  - assert (A:= in_inv H).
    decide (x=v).
    + subst.
      simpl.
      exists u.
      split.
      now left.
      now apply eq_if_eq_dec.
    + destruct A.
      * congruence.
      * assert (B:= IH H0).
        destruct B as [t B1]. destruct B1 as [B11 B12].
        exists t.
        split.
        simpl.
        now right.
        simpl.
        apply neq_comm in n.
        rewrite neq_if_eq_dec.
        now unfold apply_sub in B12; easy.
        easy.
Qed.

*)

Lemma All_all vars sigma :
  All01 vars sigma -> sigma el all_01subs_list vars.
Proof.
  intros H.
  induction H.
  -   unfold all_01subs_list.
      easy.
  - simpl.
    apply el_app_L.
    now apply in_map.
  - simpl.
    apply el_app_R.
    now apply in_map.
Qed.

Lemma all_All vars :
  forall sigma,
  sigma el all_01subs_list vars ->  All01 vars sigma.
Proof.
induction vars as [| v vars' IH].
intros sigma H.

- simpl in H.
  destruct H.
  rewrite <- H.
  now apply All01_nil.
  now exfalso.
- intros sigma H.
  simpl in H.
  apply in_app_or in H.
  destruct H as [l | r].
  * apply in_map_iff in l.
    destruct l as  [delta l1]; destruct l1.
    rewrite <- H in *.
    apply All01_cons0.
    now apply IH.
  * apply in_map_iff in r.
    destruct r as  [delta r1]; destruct r1.
    rewrite <- H in *.
    apply All01_cons1.
    now apply IH.
Qed.

Lemma applys_T0_or_T1 (sigma : subL) (vars: list var) (v: var) :
    All01 vars sigma ->
    v el vars ->
    (sigma @ (V v)) = T0 \/  (sigma @ (V v)) = T1.
Proof.
  intros H1 H2.
  induction H1.
  - easy.
  - assert (A:= in_inv H2).
    decide (x=v).
    +
    destruct A as [l|r].
    * rewrite l.
      left.
      simpl.
      now apply eq_if_eq_dec.
    * subst.
      assert (B:= IHAll01 r).
      simpl.
      left.
      now apply eq_if_eq_dec.

    + assert (B: v el vars).
      now destruct A.
      assert (C:= IHAll01 B).
      * simpl.
        simpl in C.
        destruct C.
        -- left. rewrite H. now apply neq_if_eq_dec.
        -- right. rewrite H.  now apply neq_if_eq_dec.
  - assert (A:= in_inv H2).
    decide (x=v).
    +
    destruct A as [l|r].
    * rewrite l.
      simpl.
      right.
      simpl.
      now apply eq_if_eq_dec.
    * subst.
      assert (B:= IHAll01 r).
      simpl.
      right.
      now apply eq_if_eq_dec.

    + assert (B: v el vars).
      now destruct A.
      assert (C:= IHAll01 B).
      * simpl.
        simpl in C.
        destruct C.
        -- left. rewrite H. now apply neq_if_eq_dec.
        -- right. rewrite H.  now apply neq_if_eq_dec.

Qed.

    Lemma all_01subs_give_ground_var (sigma : subL) (vars: list var) (v: var) :
  sigma el all_01subs_list vars ->
  v el vars ->
  Ground_term (sigma @ (V v)).
Proof.
  intros H1 H2.
  assert (B:= all_All vars sigma H1).
  assert (A:= applys_T0_or_T1 sigma vars v B H2).
  inversion A; now rewrite H.
Qed.

Lemma all_01subs_give_ground_help (l: list var) (t: term) (sigma : subL) :
  sigma el all_01subs_list l ->
  vars_term t <<= l  ->
  Ground_term (sigma @ t).
Proof.
  intros H1 H2.
  induction t as [ | | x | t1 IH1 t2 IH2 | t1 IH1 t2 IH2]; simpl; auto.
  - (* var *) simpl in H2.
    assert (A: x el l).
    + assert (B:= (incl_lcons x nil l)).
      auto.
    + now apply all_01subs_give_ground_var with l.
  - (* + *) assert (B: (vars_term t1 <<= vars_term (t1 +' t2))).
    apply vars_term_incl_A_L.
    assert (C: vars_term t1 <<= l). now apply incl_tran with (vars_term (t1 +' t2)).
    apply GA. now apply IH1.

    assert (D: (vars_term t2 <<= vars_term (t1 +' t2))).
    apply vars_term_incl_A_R.
    assert (E: vars_term t2 <<= l). now apply incl_tran with (vars_term (t1 +' t2)).
    now apply IH2.

    - (* * *) assert (B: (vars_term t1 <<= vars_term (t1 *' t2))).
    apply vars_term_incl_M_L.
    assert (C: vars_term t1 <<= l). now apply incl_tran with (vars_term (t1 *' t2)).
    apply GM. now apply IH1.

    assert (D: (vars_term t2 <<= vars_term (t1 *' t2))).
    apply vars_term_incl_M_R.
    assert (E: vars_term t2 <<= l). now apply incl_tran with (vars_term (t1 *' t2)).
    now apply IH2.
Qed.

Lemma all_01subs_give_ground (t: term) (sigma : subL) :
  sigma el all_01subs t ->
  Ground_term (sigma @ t).
Proof.
  intros H.
  unfold all_01subs in H.
  now apply (all_01subs_give_ground_help (vars_term t) t sigma).
Qed.

Lemma mgu_T0 t:
  t == T0 -> mgu id_sub t.
Proof.
  intros H.
  unfold mgu. unfold mgu_strong_all.
  split.
  - unfold solves. now rewrite apply_sub_id.
  - intros gamma H1 x.
    now simpl.
Qed.


(**
  Reprezentacja prostego Ledgera w stylu UTxO.
*)

Require Import List.
Import ListNotations.

Record Coin : Type := coin
{
  uncoin : nat;
}.

Parameter Addr : Type.

Record Out : Type := out
{
  adr : Addr;
  val : Coin;
}.

Inductive Tx : Type := tx
{
  ins  : list Inp;
  outs : list Out;
}

with Inp : Type := inp
{
  _ : Tx;
  _ : nat;
}.

Definition Ledger : Type := list Tx.

Parameter a0 a1 a2 : Addr.

Definition t0 : Tx := tx [] [out a0 (coin 1000)].
Definition t1 : Tx := tx [inp t0 0] [out a1 (coin 50); out a0 (coin 950)].
Definition t2 : Tx := tx [inp t1 0] [out a2 (coin 50)].

Definition l : Ledger := [t0; t1; t2].

Definition UTxO : Type := list (Inp * Out).

Record Wallet : Type :=
{
  ours : list Addr;
  utxo : UTxO;
}.

Lemma Coin_eq_dec :
  forall c1 c2 : Coin, {c1 = c2} + {c1 <> c2}.
Proof.
  do 2 decide equality.
Defined.

Parameter Addr_eq_dec :
  forall a1 a2 : Addr, {a1 = a2} + {a1 <> a2}.

Lemma Out_eq_dec :
  forall o1 o2 : Out, {o1 = o2} + {o1 <> o2}.
Proof.
  decide equality.
  - apply Coin_eq_dec.
  - apply Addr_eq_dec.
Defined.

Lemma Tx_eq_dec :
  forall t1 t2 : Tx, {t1 = t2} + {t1 <> t2}
with Inp_eq_dec :
  forall i1 i2 : Inp, {i1 = i2} + {i1 <> i2}.
Proof.
  - decide equality.
    + apply list_eq_dec, Out_eq_dec.
    + apply list_eq_dec, Inp_eq_dec.
  - do 2 decide equality.
Defined.

Lemma Ledger_eq_dec :
  forall l1 l2 : Ledger, {l1 = l2} + {l1 <> l2}.
Proof.
  apply list_eq_dec, Tx_eq_dec.
Defined.

Definition restrictDomain (ins : list Inp) (utxo : UTxO) : UTxO :=
  filter (fun '(i, _) => if in_dec Inp_eq_dec i ins then true else false) utxo.

Definition subtractDomain (ins : list Inp) (utxo : UTxO) : UTxO :=
  filter (fun '(i, _) => if in_dec Inp_eq_dec i ins then false else true) utxo.

Definition restrictRange (utxo : UTxO) (addrs : list Addr) : UTxO :=
  filter (fun '(_, o) => if in_dec Addr_eq_dec (adr o) addrs then true else false) utxo.

Fixpoint imap {A B : Type} (f : nat -> A -> B) (l : list A) : list B :=
match l with
| [] => []
| h :: t => f 0 h :: imap (fun n a => f (S n) a) t
end.

Definition txouts (tx : Tx) : UTxO :=
  imap (fun n o => (inp tx n, o)) (outs tx).

Definition txins (tx : Tx) : list Inp := ins tx.

Definition apply (tx : Tx) (w : Wallet) : Wallet :=
{|
  ours := ours w;
  utxo := subtractDomain (txins tx) (utxo w) ++ restrictRange (txouts tx) (ours w);
|}.

Definition correctWallet (w : Wallet) : Prop :=
  Forall (fun '(_, o) => In (adr o) (ours w)) (utxo w).

Definition EmptyWallet (addrs : list Addr) : Wallet :=
{|
  ours := addrs;
  utxo := [];
|}.

Fixpoint balance' (utxo : UTxO) : nat :=
match utxo with
| [] => 0
| (_, o) :: utxo' => uncoin (val o) + balance' utxo'
end.

Definition balance (utxo : UTxO) : Coin :=
  coin (balance' utxo).

Record CachedWallet : Type :=
{
  wallet  : Wallet;
  cachedBalance : Coin;
}.

Definition cachesCorrectly (cw : CachedWallet) : Prop :=
  balance (utxo (wallet cw)) = cachedBalance cw.

Definition cachedApply (tx : Tx) (cw : CachedWallet) : CachedWallet :=
  let w' := apply tx (wallet cw) in
{|
  wallet  := w';
  cachedBalance := balance (utxo w');
|}.

Definition EmptyCachedWallet (addrs : list Addr) : CachedWallet :=
{|
  wallet := EmptyWallet addrs;
  cachedBalance := coin 0;
|}.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require HighOrd.
Require set.Set.
Require map.Map.
Require map.Const.

(* Why3 assumption *)
Definition rel (a:Type) (b:Type) := (a* b)%type -> bool.

Parameter power:
  forall {a:Type} {a_WT:WhyType a}, (a -> bool) -> (a -> bool) -> bool.

Axiom mem_power :
  forall {a:Type} {a_WT:WhyType a},
  forall (x:a -> bool) (y:a -> bool),
  (set.Set.mem x (power y)) <-> (set.Set.subset x y).

Parameter times:
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b}, (a -> bool) ->
  (b -> bool) -> (a* b)%type -> bool.

Axiom times_def :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (a1:a -> bool) (b1:b -> bool) (x:a) (y:b),
  (set.Set.mem (x, y) (times a1 b1)) <->
  ((set.Set.mem x a1) /\ (set.Set.mem y b1)).

(* Why3 assumption *)
Definition relations {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b}
    (u:a -> bool) (v:b -> bool) : ((a* b)%type -> bool) -> bool :=
  power (times u v).

Axiom break_mem_in_add :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (c:(a* b)%type) (s:(a* b)%type -> bool) (x:a) (y:b),
  (set.Set.mem c (map.Map.set s (x, y) true)) <->
  ((c = (x, y)) \/ (set.Set.mem c s)).

Axiom break_power_times :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (r:(a* b)%type -> bool) (u:a -> bool) (v:b -> bool),
  (set.Set.mem r (power (times u v))) <-> (set.Set.subset r (times u v)).

Axiom subset_of_times :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (r:(a* b)%type -> bool) (u:a -> bool) (v:b -> bool),
  (set.Set.subset r (times u v)) <->
  forall (x:a) (y:b), (set.Set.mem (x, y) r) ->
  (set.Set.mem x u) /\ (set.Set.mem y v).


(**
Here we define the bicategory of groupoids.
Note: this bicategory is not univalent since the groupoids are not univalent.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.

Local Open Scope cat.

Definition grpd_prebicat_data
  : prebicat_data.
Proof.
  use build_prebicat_data.
  - exact groupoid.
  - exact (λ G₁ G₂, G₁ ⟶ G₂).
  - exact (λ _ _ F₁ F₂, pr1 F₁ ⟹ pr1 F₂).
  - exact (λ G, functor_identity _).
  - exact (λ _ _ _ F₁ F₂, F₁ ∙ F₂).
  - exact (λ _ _ F, nat_trans_id F).
  - exact (λ _ _ _ _ _ α β, nat_trans_comp _ _ _ α β).
  - exact (λ _ _ _ F _ _ α, pre_whisker F α).
  - exact (λ _ _ _ _ _ H α, post_whisker α H).
  - exact (λ _ _ F, nat_trans_id F).
  - exact (λ _ _ F, nat_trans_id F).
  - exact (λ _ _ F, nat_trans_id F).
  - exact (λ _ _ F, nat_trans_id F).
  - exact (λ _ _ _ _ _ _ _, nat_trans_id _).
  - exact (λ _ _ _ _ _ _ _, nat_trans_id _).
Defined.

Definition grpd_prebicat_laws
  : prebicat_laws grpd_prebicat_data.
Proof.
  repeat split; cbn.
  - intros C D F G η.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply id_left.
  - intros C D F G η.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply id_right.
  - intros C D F₁ F₂ F₃ F₄ α β γ.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply assoc.
  - intros C₁ C₂ C₃ F G.
    apply nat_trans_eq.
    { apply homset_property. }
    reflexivity.
  - intros C₁ C₂ C₃ F G.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply functor_id.
  - intros C₁ C₂ C₃ F G₁ G₂ G₃ α β.
    apply nat_trans_eq.
    { apply homset_property. }
    reflexivity.
  - intros C₁ C₂ C₃ F₁ F₂ F₃ G α β.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    exact (!(functor_comp G _ _)).
  - intros C D F G α.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    rewrite id_left, id_right.
    reflexivity.
  - intros C D F G α.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    rewrite id_left, id_right.
    reflexivity.
  - intros C₁ C₂ C₃ C₄ F G H₁ H₂ α.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    rewrite id_left, id_right.
    reflexivity.
  - intros C₁ C₂ C₃ C₄ F G₁ G₂ H α.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    rewrite id_left, id_right.
    reflexivity.
  - intros C₁ C₂ C₃ C₄ F₁ F₂ G H α.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    rewrite id_left, id_right.
    reflexivity.
  - intros C₁ C₂ C₃ F₁ F₂ G₁ H₂ α β.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    exact ((nat_trans_ax β _ _ _)).
  - intros C D F.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply id_left.
  - intros C D F.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply id_left.
  - intros C D F.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply id_left.
  - intros C D F.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply id_left.
  - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply id_left.
  - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    apply id_left.
  - intros C₁ C₂ C₃ F G.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    exact (id_left _ @ functor_id G _).
  - intros C₁ C₂ C₃ C₄ C₅ F₁ F₂ F₃ F₄.
    apply nat_trans_eq.
    { apply homset_property. }
    intros ; cbn.
    rewrite !id_left.
    exact (functor_id F₄ _).
Qed.

Definition grpd_prebicat
  : prebicat.
Proof.
  use tpair.
  - exact grpd_prebicat_data.
  - exact grpd_prebicat_laws.
Defined.

Lemma isaset_cells_grpd_prebicat : isaset_cells grpd_prebicat.
Proof.
  intros a b f g.
  apply isaset_nat_trans.
  apply homset_property.
Qed.

Definition grpd_bicat
  : bicat.
Proof.
  use tpair.
  - exact grpd_prebicat.
  - exact isaset_cells_grpd_prebicat.
Defined.

Definition make_grpd_bicat
           (X : UU)
           (M : X → X → UU)
           (idX : ∏ (x : X), M x x)
           (invX : ∏ (x y : X), M x y → M y x)
           (cX : ∏ (x y z : X), M x y → M y z → M x z)
           (cidX : ∏ (x y : X) (f : M x y), cX _ _ _ f (idX y) = f)
           (idcX : ∏ (x y : X) (f : M x y), cX _ _ _ (idX x) f = f)
           (ccX : ∏ (w x y z : X)
                    (f : M w x) (g : M x y) (h : M y z),
                  cX _ _ _ f (cX _ _ _ g h)
                  =
                  cX _ _ _ (cX _ _ _ f g) h)
           (cinvX : ∏ (x y : X) (f : M x y), cX _ _ _ f (invX _ _ f) = idX _)
           (invcX : ∏ (x y : X) (f : M x y), cX _ _ _ (invX _ _ f) f = idX _)
           (isasetM : ∏ (x y : X), isaset (M x y))
  : grpd_bicat.
Proof.
  use make_groupoid.
  - use make_category.
    + use make_precategory.
      * use make_precategory_data.
        ** use make_precategory_ob_mor.
           *** exact X.
           *** exact M.
        ** exact idX.
        ** exact cX.
      * use make_is_precategory.
        ** exact idcX.
        ** exact cidX.
        ** exact ccX.
        ** intros w x y z f g h.
           exact (!(ccX w x y z f g h)).
    + exact isasetM.
  - intros x y f.
    use make_is_z_isomorphism.
    + exact (invX _ _ f).
    + split.
      * exact (cinvX _ _ f).
      * exact (invcX _ _ f).
Defined.

(** Every 2-cell is invertible. *)
Definition grpd_bicat_is_invertible_2cell
           {G₁ G₂ : grpd_bicat}
           {F₁ F₂ : G₁ --> G₂}
           (α : F₁ ==> F₂)
  : is_invertible_2cell α.
Proof.
  use make_is_invertible_2cell.
  - use make_nat_trans.
    + intros X.
      exact (inv_from_z_iso (_ ,, pr2 G₂ _ _ (pr1 α X))).
    + abstract
        (intros X Y f ; cbn ;
         refine (!_) ;
         apply z_iso_inv_on_right ;
         rewrite !assoc ;
         apply z_iso_inv_on_left ;
         simpl ;
         exact (!(pr2 α X Y f))).
  - abstract
      (apply nat_trans_eq ; try apply homset_property ;
       intro x ; cbn ;
       exact (z_iso_inv_after_z_iso (_ ,, _))).
  - abstract
      (apply nat_trans_eq ; try apply homset_property ;
       intro x ; cbn ;
       exact (z_iso_after_z_iso_inv (_ ,, _))).
Defined.

Definition groupoid_cancel
           {G : groupoid}
           {a b c : G}
           (f₁ f₂ : a --> b)
           (g : b --> c)
  : f₁ · g = f₂ · g → f₁ = f₂.
Proof.
  intro H.
  refine (!(id_right _) @ _).
  simple refine (maponpaths (λ x, _ · x) (!(z_iso_inv_after_z_iso (g ,, _))) @ _).
  { apply G. }
  simpl.
  refine (assoc _ _ _ @ _).
  refine (maponpaths (λ x, x · _) H @ _).
  refine (assoc' _ _ _ @ _).
  refine (maponpaths (λ x, _ · x) (z_iso_inv_after_z_iso (g ,, _)) @ _).
  apply id_right.
Qed.


(**
Here we collect some basic facts and definitions.
 *)
Require Import prelude.imports.

Open Scope cat.

(**
Sum of two maps.
 *)
Definition coprod_maps
           {C : category}
           (BC : BinCoproducts C)
           {X₁ X₂ Y₁ Y₂ : C}
           (f₁ : X₁ --> Y₁)
           (f₂ : X₂ --> Y₂)
  : bincoproduct_functor BC (X₁ ,, X₂) --> bincoproduct_functor BC (Y₁ ,, Y₂).
Proof.
  refine (#(bincoproduct_functor BC) (_ ,, _)).
  - exact f₁.
  - exact f₂.
Defined.

(**
If two maps are invertible, then so is their sum
 *)
Definition coprod_maps_inverse
           {C : category}
           (BC : BinCoproducts C)
           {X₁ X₂ Y₁ Y₂ : C}
           {f₁ : X₁ --> Y₁} {g₁ : Y₁ --> X₁}
           {f₂ : X₂ --> Y₂} {g₂ : Y₂ --> X₂}
           (H₁ : is_inverse_in_precat f₁ g₁)
           (H₂ : is_inverse_in_precat f₂ g₂)
  : is_inverse_in_precat (coprod_maps BC f₁ f₂) (coprod_maps BC g₁ g₂).
Proof.
  split.
  - cbn.
    rewrite BinCoproductOfArrows_comp.
    rewrite (pr1 H₁), (pr1 H₂).
    unfold BinCoproductOfArrows.
    refine (_ @ !(BinCoproductArrowEta _ _ _ _ _ _)).
    rewrite !id_left, !id_right.
    reflexivity.
  - cbn.
    rewrite BinCoproductOfArrows_comp.
    rewrite (pr2 H₁), (pr2 H₂).
    unfold BinCoproductOfArrows.
    refine (_ @ !(BinCoproductArrowEta _ _ _ _ _ _)).
    rewrite !id_left, !id_right.
    reflexivity.
Qed.

(**
Product of two maps.
 *)
Definition prod_maps
           {C : category}
           (BC : BinProducts C)
           {X₁ X₂ Y₁ Y₂ : C}
           (f₁ : X₁ --> Y₁)
           (f₂ : X₂ --> Y₂)
  : binproduct_functor BC (X₁ ,, X₂) --> binproduct_functor BC (Y₁ ,, Y₂).
Proof.
  refine (#(binproduct_functor BC) (_ ,, _)).
  - exact f₁.
  - exact f₂.
Defined.

(**
If two maps are invertible, then so is their product.
 *)
Definition prod_maps_inverse
           {C : category}
           (BC : BinProducts C)
           {X₁ X₂ Y₁ Y₂ : C}
           {f₁ : X₁ --> Y₁} {g₁ : Y₁ --> X₁}
           {f₂ : X₂ --> Y₂} {g₂ : Y₂ --> X₂}
           (H₁ : is_inverse_in_precat f₁ g₁)
           (H₂ : is_inverse_in_precat f₂ g₂)
  : is_inverse_in_precat (prod_maps BC f₁ f₂) (prod_maps BC g₁ g₂).
Proof.
  split.
  - cbn.
    rewrite BinProductOfArrows_comp.
    rewrite (pr1 H₁), (pr1 H₂).
    unfold BinProductOfArrows.
    refine (_ @ !(BinProductArrowEta _ _ _ _ _ _)).
    rewrite !id_left, !id_right.
    reflexivity.
  - cbn.
    rewrite BinProductOfArrows_comp.
    rewrite (pr2 H₁), (pr2 H₂).
    unfold BinProductOfArrows.
    refine (_ @ !(BinProductArrowEta _ _ _ _ _ _)).
    rewrite !id_left, !id_right.
    reflexivity.
Qed.

(**
This is a particular way to construct the inverse of a natural transformation.
The coordinates of the inverse is given by `θ`.
 *)
Section InvNatTrans.
  Context {C D : precategory}
          {F G : C ⟶ D}.
  Variable (η : F ⟹ G)
           (θ : ∏ (X : C), G X --> F X)
           (ηθ : ∏ (X : C), is_inverse_in_precat (η X) (θ X)).

  Local Definition θ_is_nat_trans
    : is_nat_trans G F θ.
  Proof.
    intros X Y f.
    refine (!(id_left _) @ _).
    refine (assoc _ _ _ @ _ @ _).
    {
      do 2 apply maponpaths_2.
      exact (!(pr2 (ηθ X))).
    }
    rewrite <- !assoc.
    apply maponpaths.
    refine (assoc _ _ _ @ _ @ _).
    {
      apply maponpaths_2.
      exact (!(pr2 η _ _ f)).
    }
    refine (!(assoc _ _ _) @ _).
    refine (maponpaths (λ z, # F f · z) (pr1 (ηθ Y)) @ _).
    apply id_right.
  Qed.

  Definition inv_nat_trans
    : G ⟹ F.
  Proof.
    use make_nat_trans.
    - exact θ.
    - exact θ_is_nat_trans.
  Defined.
End InvNatTrans.

(**
Left adjoints preserve initial objects.
 *)
Definition adj_initial
           {C D : category}
           {L : C ⟶ D}
           {R : D ⟶ C}
           (adj : are_adjoints L R)
           (X : C)
           (X_initial : isInitial _ X)
  : isInitial D (L X).
Proof.
  use make_isInitial.
  intros Y.
  apply (iscontrweqf (invweq (pr1 (nathomweq_from_adj adj) X Y))).
  apply X_initial.
Defined.

(**
Pairing of natural transfomations.
 *)
Section PairNatTrans.
  Context {C₁ C₂ C₃ : category}
          {F : C₁ ⟶ C₂}
          {G₁ G₂ G₃ : C₂ ⟶ C₃}.
  Variable (H : BinProducts C₃)
           (η₁ : F ∙ G₁ ⟹ F ∙ G₂)
           (η₂ : F ∙ G₁ ⟹ F ∙ G₃).

  Local Definition pair_nat_trans_data
    : nat_trans_data (F ∙ G₁) (F ∙ BinProduct_of_functors C₂ C₃ H G₂ G₃).
  Proof.
    intros x.
    apply (BinProductArrow).
    - exact (η₁ x).
    - exact (η₂ x).
  Defined.

  Definition pair_nat_trans_is_nat_trans
    : is_nat_trans
        (F ∙ G₁)
        (F ∙ BinProduct_of_functors C₂ C₃ H G₂ G₃)
        pair_nat_trans_data.
  Proof.
    intros x y f ; cbn.
    refine (precompWithBinProductArrow _ _ _ _ _ @ _).
    pose (pr2 η₁ x y f) as p.
    pose (pr2 η₂ x y f) as q.
    cbn in p, q.
    refine (_ @ _).
    {
      apply maponpaths.
      exact q.
    }
    refine (_ @ _).
    {
      apply maponpaths_2.
      exact p.
    }
    unfold BinProduct_of_functors_mor, BinProductOfArrows, BinProductPr1, BinProductPr2.
    exact (!(postcompWithBinProductArrow _ _ _ _ _ _ _)).
  Qed.

  Definition pair_nat_trans
    : F ∙ G₁ ⟹ F ∙ (BinProduct_of_functors _ _ H G₂ G₃).
  Proof.
    use make_nat_trans.
    - exact pair_nat_trans_data.
    - exact pair_nat_trans_is_nat_trans.
  Defined.
End PairNatTrans.

(**
Initial objects are isomorphic
 *)
Definition initial_z_iso
           {C : precategory}
           {X Y : C}
           (IX : isInitial _ X)
           (IY : isInitial _ Y)
  : z_iso X Y.
Proof.
  use tpair.
  - apply IX.
  - use tpair.
    + apply IY.
    + split ; simpl.
      * exact (pr2 (IX X) _ @ !(pr2 (IX X) _)).
      * exact (pr2 (IY Y) _ @ !(pr2 (IY Y) _)).
Defined.

(**
Transport lemmata
 *)
Definition transportf_is_transportb
           {X : UU}
           (Y : X → UU)
           {x₁ x₂ : X}
           (p : x₁ = x₂)
           (z : Y x₂)
  : transportb Y p z = transportf Y (!p) z
  := idpath _.

Definition sum_hset_fam
           {A B : UU}
           (Y₁ : A → hSet)
           (Y₂ : B → hSet)
  : A ⨿ B → hSet.
Proof.
  intros x.
  induction x as [x | x].
  - exact (Y₁ x).
  - exact (Y₂ x).
Defined.

Definition transportf_inl
           {A B : UU}
           (Y₁ : A → hSet)
           (Y₂ : B → hSet)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           (y : Y₁ a₁)
  : transportf (sum_hset_fam Y₁ Y₂) (maponpaths inl p) y = transportf Y₁ p y.
Proof.
  induction p ; simpl.
  reflexivity.
Qed.

Definition transportf_inr
           {A B : UU}
           (Y₁ : A → hSet)
           (Y₂ : B → hSet)
           {b₁ b₂ : B}
           (p : b₁ = b₂)
           (y : Y₂ b₁)
  : transportf (sum_hset_fam Y₁ Y₂) (maponpaths inr p) y = transportf Y₂ p y.
Proof.
  induction p ; simpl.
  reflexivity.
Qed.

Definition prod_hset_fam
           {A B : UU}
           (Y₁ : A → hSet)
           (Y₂ : B → hSet)
  : A × B → hSet
  := (λ x, Y₁ (pr1 x) × Y₂ (pr2 x))%set.

Definition transportf_pr1
           {A B : UU}
           {Y₁ : A → hSet}
           {Y₂ : B → hSet}
           (x₁ x₂ : A × B)
           (p : x₁ = x₂)
           (y : Y₁ (pr1 x₁) × Y₂ (pr2 x₁))
  : pr1 (transportf (prod_hset_fam Y₁ Y₂) p y) = transportf Y₁ (maponpaths pr1 p) (pr1 y).
Proof.
  induction p ; simpl.
  reflexivity.
Qed.

Definition transportf_pr2
           {A B : UU}
           {Y₁ : A → hSet}
           {Y₂ : B → hSet}
           (x₁ x₂ : A × B)
           (p : x₁ = x₂)
           (y : Y₁ (pr1 x₁) × Y₂ (pr2 x₁))
  : pr2 (transportf (prod_hset_fam Y₁ Y₂) p y) = transportf Y₂ (maponpaths dirprod_pr2 p) (pr2 y).
Proof.
  induction p ; simpl.
  reflexivity.
Qed.

Definition transportf_paths_2
           {X : hSet}
           (Y : X → UU)
           {x₁ x₂ x₃ : X}
           (p₁ : x₁ = x₃)
           (p₂ : x₂ = x₃)
           {y₁ : Y x₁}
           {y₂ : Y x₂}
           (q : y₁ = transportf Y (p₂ @ ! p₁) y₂)
  : transportf Y p₁ y₁ = transportf Y p₂ y₂.
Proof.
  refine (!_).
  apply transportf_transpose_right.
  unfold transportb.
  rewrite transport_f_f.
  exact (!q).
Qed.

Definition transportf_paths_3
           {X : hSet}
           (Y : X → UU)
           {x₁ x₂ : X}
           (p₁ p₂ : x₁ = x₂)
           {y₁ y₂ : Y x₁}
           (q : y₁ = y₂)
  : transportf Y p₁ y₁ = transportf Y p₂ y₂.
Proof.
  apply transportf_paths_2.
  refine (q @ !(transportf_set _ _ _ _)).
  apply X.
Qed.

(** Alternative form of `fiber_paths` *)
Definition fiber_paths_b
           {A : UU}
           {B : A → UU}
           {u v : ∑ (x : A), B x}
           (p : u = v)
  : pr2 u = transportb (λ x, B x) (base_paths u v p) (pr2 v).
Proof.
  apply transportf_transpose_right.
  unfold transportb.
  refine (_ @ fiber_paths p).
  apply transportf_paths.
  apply pathsinv0inv0.
Qed.


Require Import Coq.Classes.RelationClasses.
Require Import CoLoR.Util.Relation.RelUtil.

Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.misc.util.
Require Import MathClasses.misc.decision.

Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Data.Monads.OptionMonad.

Require Import Helix.Tactics.HelixTactics.

Global Instance option_Equiv {T:Type} `{Te:Equiv T}:
  Equiv (option T) := @opt_r T Te.

Global Instance option_Equivalence  `{Te: Equiv T} `{H: Equivalence T Te}
  : Equivalence (@option_Equiv T Te).
Proof.
  split.
  - apply opt_r_refl, H.
  - apply opt_r_sym, H.
  - apply opt_r_trans, H.
Qed.

Lemma Some_inj_eq {A:Type}:
  forall (a b:A), a ≡ b <-> Some a ≡ Some b.
Proof.
  intros a b.
  split; intros H.
  -
    f_equiv.
    apply H.
  -
    inversion H.
    auto.
Qed.

Lemma Some_inj_equiv `{E: Equiv A}:
  forall (a b:A), a = b <-> Some a = Some b.
Proof.
  intros a b.
  split; intros H.
  -
    f_equiv.
    apply H.
  -
    inversion H.
    auto.
Qed.

Global Instance Some_proper `{Equiv A}:
  Proper ((=) ==> (=)) (@Some A).
Proof.
  intros a b E.
  apply Some_prop, E.
Qed.

Ltac norm_some_none :=
  repeat
    match goal with
    | [H: is_Some (Some _) |- _ ] => clear H
    | [H: is_None (None) |- _ ] => clear H
    | [|- is_Some (None) ] => exfalso
    | [|- is_None (Some _)] => exfalso
    | [H: is_Some _ |- _ ] => apply is_Some_def in H; destruct H
    | [H: is_None _ |- _ ] => apply is_None_def in H; destruct H
    | [H: Some ≡ _ |- _ ] => symmetry in H
    | [H: None ≡ _ |- _ ] => symmetry in H
    end.

Ltac symmetry_option_hyp :=
  repeat  match goal with
          | [H: Some _ ≡ _ |- _ ] => symmetry in H
          | [H: None ≡ _  |- _ ] => symmetry in H
          end.

Lemma is_Some_ne_None `(x : option A) :
  is_Some x ↔ x ≢ None.
Proof.
  destruct x; intros; crush.
Qed.

Lemma Some_ne_None `(x : option A) y :
  x ≡ Some y → x ≢ None.
Proof. congruence. Qed.

Ltac some_none :=
  let H' := fresh in
  match goal with
  | [H1: ?x = None, H2: ?x ≠ None |- _] => congruence
  | [H1: ?x ≡ Some _, H2: ?x ≡ None |- _ ] => congruence
  | [H1: ?x = Some _, H2: ?x = None |- _ ] => rewrite H2 in H1; inversion H1
  | [H: is_Some None |- _ ] => inversion H
  | [H: is_None (Some _) |- _ ] => inversion H
  | [H: ¬ is_None None |- _] => unfold is_None in H; tauto
  | [H: Some _ = None |- _ ] => inversion H
  | [H: None = Some _ |- _ ] => inversion H
  | [H: Some _ ≡ None |- _ ] => inversion H
  | [H: None ≡ Some _ |- _ ] => inversion H
  | [ |- Some _ ≢ None ] => intros H'; inversion H'
  | [ |- None ≢ None ] => congruence
  | [ |- Some ?a ≢ Some ?a ] => congruence
  | [ |- Some _ ≠ None ] => intros H'; inversion H'
  | [ |- None ≠ Some _ ] => intros H'; inversion H'
  | [ |- None ≢ Some _ ] => intros H'; inversion H'
  | [ |- None = None ] => reflexivity
  | [ |- None ≡ None ] => reflexivity
  | [ |- Some ?a = Some ?a] => reflexivity
  | [ |- Some ?a ≡ Some ?a] => reflexivity
  | [ |- is_None None ] => apply is_None_def; reflexivity
  | [ |- is_Some (Some _)] => unfold is_Some; tauto
  | [H1: is_Some ?x, H2: is_None ?x |- _] =>
    apply is_Some_ne_None in H1; apply is_None_def in H2; congruence
  end.

Ltac some_inv :=
  match goal with
  | [H: Some ?A ≡ Some ?b |- _ ] => inversion H; clear H
  | [H: Some ?A = Some ?b |- _ ] => apply Some_inj_equiv in H
  end.

Ltac some_apply :=
  match goal with
  | [H: ?a = ?b |- Some ?a = Some ?b] => apply Some_inj_equiv in H; apply H
  | [H: Some ?a = Some ?b |- ?a = ?b] => apply Some_inj_equiv; apply H
  end.

Lemma Equiv_to_opt_r {A:Type} {a b: option A} `{Ae: Equiv A}:
  a = b <-> RelUtil.opt_r Ae a b.
Proof.
  split.
  -
    intros H.
    destruct a, b; try some_none; constructor.
    some_inv.
    apply H.
  -
    intros H.
    auto.
Qed.

Global Instance liftM_option_proper `{Ae:Equiv A} `{Be: Equiv B}:
  Proper (((=) ==> (=)) ==> (=) ==> (=)) (@liftM option Monad_option A B).
Proof.
  intros f f' Ef a a' Ea.
  simpl.
  destruct a, a'; try some_none; auto.
  -
    f_equiv.
    apply Ef.
    inversion Ea.
    auto.
  -
    apply opt_r_None.
Qed.

Lemma Option_equiv_eq
      {A: Type}
      `{Ae: Equiv A}
      `{Ar: Equivalence A Ae}
      (a b: option A) :
  (a ≡ b) -> (a = b).
Proof.
  intros H.
  rewrite H.
  reflexivity.
Qed.

Ltac eq_to_equiv_hyp :=
  repeat
    match goal with
    | [H: _ ≡ _ |- _] => apply Option_equiv_eq in H
    end.

Lemma None_nequiv_neq
      {A: Type}
      `{Ae: Equiv A}
      `{Ar: Equivalence A Ae}
      (a: option A) :
  (a ≢ None) <-> (a ≠ None).
Proof.
  destruct a; split; intros; try some_none; crush.
Qed.

Lemma None_equiv_eq
      {A: Type}
      `{Ae: Equiv A}
      `{Aee: Equivalence A Ae}
      {x: option A}:
  x ≡ None <-> x = None.
Proof.
  split.
  -
    intros H.
    rewrite H.
    reflexivity.
  -
    intros H.
    inversion H.
    reflexivity.
Qed.

Lemma Some_nequiv_None `(x : option A) `{Ae: Equiv A} y :
  x = Some y → x ≠ None.
Proof.
  intros H.
  intros H1.
  destruct x; some_none.
Qed.

Fact equiv_Some_is_Some `{Equiv A} (x:A) (y: option A):
  (y = Some x) -> is_Some y.
Proof.
  dep_destruct y.
  -
    crush.
  -
    intros H0.
    some_none.
Qed.

Fact eq_Some_is_Some {A:Type} (x:A) (y: option A):
  (y ≡ Some x) -> is_Some y.
Proof.
  crush.
Qed.

Lemma is_Some_equiv_def `{Ae: Equiv A} `{Equivalence A Ae} `(x : option A) :
  is_Some x ↔ ∃ y, x = Some y.
Proof.
  unfold is_Some.
  destruct x.
  -
    split; intros H0; auto.
    exists a.
    f_equiv.
  -
    split; intros H0; destruct H0.
    some_none.
Qed.

Lemma is_Some_nequiv_None
      (A : Type)
      `{Ae: Equiv A}
      (x : option A):
  is_Some x ↔ x ≠ None.
Proof.
  split; intros H.
  -
    destruct x.
    some_none.
    crush.
  -
    destruct x.
    + crush.
    + exfalso.
      unfold equiv, option_Equiv in H.
      contradict H.
      apply RelUtil.opt_r_None.
Qed.

Lemma Some_neq {T:Type} {a b: T}:
  (Some a ≢ Some b) <-> a ≢ b.
Proof.
  split;crush.
Qed.

Lemma None_nequiv_Some
      {A: Type} (x : option A) {Ae: Equiv A} (y : A):
  x = None → x ≠ Some y.
Proof.
  intros H H0.
  destruct x; some_none.
Qed.

Lemma is_None_equiv_def `(x : option A) `{Ae: Equiv A} `{H: Equivalence A Ae}:
  is_None x ↔ x = None.
Proof.
  unfold is_None.
  destruct x; split; intros; try some_none; try tauto.
Qed.

Lemma not_is_None_is_Some {A: Type} {x: option A}:
  ¬ is_None x <-> is_Some x.
Proof.
  split; intros.
  -
    destruct x; some_none.
  -
    intros H1.
    some_none.
Qed.

(* In monadic world `(f >=> g) ∘ Some` *)
Definition option_compose
           {A B C: Type}
           (f: B → option C)
           (g: A → option B): A → option C
  := fun x =>
       match g x with
       | None => None
       | Some y => f y
       end.

Global Instance option_compose_proper
       {A B C: Type}
       `{Ae: Equiv A} `{Equivalence A Ae}
       `{Be: Equiv B} `{Equivalence B Be}
       `{Ce: Equiv C} `{Equivalence C Ce}:
  Proper (
      (((@equiv B Be) ==> (@option_Equiv C Ce))
         ==>
         ((@equiv A Ae) ==> (@option_Equiv B Be))
         ==>
         (=)
         ==>
         (@option_Equiv C Ce))) (option_compose).
Proof.
  intros f f' Ef g g' Eg x x' E.
  unfold option_compose, option_Equiv.
  repeat break_match;
    apply Option_equiv_eq in Heqo;
    apply Option_equiv_eq in Heqo0;
    setoid_replace (g x) with (g' x') in Heqo by apply Eg, E;
    rewrite Heqo in Heqo0; try some_none.
  -
    some_inv.
    apply Ef, Heqo0.
  -
    reflexivity.
Qed.

Lemma option_eq_to_opt_r {A:Type} {a b: option A}:
  a ≡ b <-> RelUtil.opt_r eq a b.
Proof.
  split; intros H.
  -
    rewrite <- H.
    destruct a; constructor.
    reflexivity.
  -
    inv H; auto.
Qed.

Ltac destruct_opt_r_equiv :=
  match goal with
  | [ |- RelUtil.opt_r _ ?a ?b] =>
    let Ha := fresh "Ha" in
    let Hb := fresh "Hb" in
    destruct a eqn:Ha, b eqn:Hb;
    match goal with
    | [ |- RelUtil.opt_r _ (Some _) None] => exfalso
    | [ |- RelUtil.opt_r _ None (Some _)] => exfalso
    | [ |- RelUtil.opt_r _ (Some _) (Some _)]  =>
      apply RelUtil.opt_r_Some
    | [ |- RelUtil.opt_r _ None None] => reflexivity
    end
  end.

Ltac opt_hyp_to_equiv :=
  repeat match goal with
           [H: @eq (option _) _ _ |- _] => apply Option_equiv_eq in H
         end.

Lemma Some_nequiv {T:Type} `{Equiv T} {a b: T}:
  (Some a ≠ Some b) <-> a ≠ b.
Proof.
  split.
  -
    intros H0.
    intros N.
    contradict H0.
    f_equiv.
    assumption.
  -
    intros H0 N.
    contradict H0.
    some_inv.
    assumption.
Qed.

Program Instance option_equiv_dec
        `{Ae: Equiv A}
        `{Aeq: Equivalence A Ae} (* needed for reflexivity *)
        `(A_dec : ∀ x y : A, Decision (x = y))
  : ∀ x y : option A, Decision (x = y)
  := λ x y,
  match x with
  | Some r =>
    match y with
    | Some s => match A_dec r s with left _ => left _ | right _ => right _ end
    | None => right _
    end
  | None =>
    match y with
    | Some s => right _
    | None => left _
    end
  end.
Next Obligation. f_equiv; assumption. Qed.
Next Obligation. apply Some_nequiv; assumption. Qed.
Next Obligation. some_none. Qed.
Next Obligation. some_none. Qed.

Section opt_p.

  Variables (A : Type) (P : A -> Prop).

  (* lifting Predicate to option. error is not allowed *)
  Inductive opt_p : (option A) -> Prop :=
  | opt_p_intro : forall x, P x -> opt_p (Some x).

  (* lifting Predicate to option. errors is allowed *)
  Inductive opt_p_n : (option A) -> Prop :=
  | opt_p_None_intro: opt_p_n None
  | opt_p_Some_intro : forall x, P x -> opt_p_n (Some x).

  Global Instance opt_p_proper
         `{Ae: Equiv A}
         {Pp: Proper ((=) ==> (iff)) P}
    :
      Proper ((=) ==> (iff)) opt_p.
  Proof.
    intros a b E.
    split.
    -
      intros H.
      destruct a,b; try some_none.
      inversion H.
      subst x.
      constructor.
      some_inv.
      rewrite <- E.
      assumption.
      inversion H.
    -
      intros H.
      destruct a,b; try some_none.
      inversion H.
      subst x.
      constructor.
      some_inv.
      rewrite E.
      assumption.
      inversion H.
  Qed.

End opt_p.
Arguments opt_p {A} P.
Arguments opt_p_n {A} P.

(* Extension to [option _] of a heterogenous relation on [A] [B] *)
Section hopt.

  Variables (A B : Type) (R: A -> B -> Prop).

  (** Reflexive on [None]. *)
  Inductive hopt_r : (option A) -> (option B) -> Prop :=
  | hopt_r_None : hopt_r None None
  | hopt_r_Some : forall a b, R a b -> hopt_r (Some a) (Some b).

  (** Non-Reflexive on [None]. *)
  Inductive hopt : (option A) -> (option B) -> Prop :=
  | hopt_Some : forall a b, R a b -> hopt (Some a) (Some b).

  (** implication-like. *)
  Inductive hopt_i : (option A) -> (option B) -> Prop :=
  | hopt_i_None_None : hopt_i None None
  | hopt_i_None_Some : forall a, hopt_i None (Some a)
  | hopt_i_Some : forall a b, R a b -> hopt_i (Some a) (Some b).

  Global Instance hopt_proper
           `{EQa : Equiv A}
           `{EQb : Equiv B}
           {PR : Proper ((=) ==> (=) ==> (iff)) R} :
    Proper ((=) ==> (=) ==> (iff)) hopt.
  Proof.
    intros a1 a2 AE b1 b2 BE.
    destruct a1, a2, b1, b2;
      invc AE; invc BE.
    2-4: split; intro C; invc C.
    split.
    all: intro E; invc E; constructor.
    specialize (PR a a0 H1 b b0 H2).
    tauto.
    eapply PR; eassumption.
  Qed.

  Global Instance hopt_r_proper
           `{EQa : Equiv A}
           `{EQb : Equiv B}
           {PR : Proper ((=) ==> (=) ==> (iff)) R} :
    Proper ((=) ==> (=) ==> (iff)) hopt_r.
  Proof.
    intros [a1|] [a2|] AE [b1|] [b2|] BE;
      try some_none; repeat some_inv.
    all: split; intro H; invc H; constructor.
    apply PR in AE; apply AE in BE; tauto.
    apply PR in AE; apply AE in BE; tauto.
  Qed.

  Lemma hopt_r_OK_inv (a : A) (b : B) :
    hopt_r (Some a) (Some b) ->
    R a b.
  Proof.
    intros O; now invc O.
  Qed.

End hopt.
Arguments hopt {A B} R.
Arguments hopt_r {A B} R.
Arguments hopt_i {A B} R.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rplus.
Require Export XR_Rplus_comm.
Require Export XR_Ropp.
Require Export XR_Rplus_opp_r.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rplus_opp_l : forall r, - r + r = R0.
Proof.
  intros x.
  rewrite Rplus_comm.
  rewrite Rplus_opp_r.
  reflexivity.
Qed.


Require Import Prelude.
Require Import CompilerRev.

Import ListNotations.

Ltac applying f := unfold f; fold f.

(* A version of the proof that goes into as much detail
   as Hutton does. *)
Lemma comp_correct_helper: forall e s c,
    exec (comp' e c) s = exec c (eval e :: s).
Proof.
  induction e; intros.
  - applying comp'.
    applying exec.
    applying (eval).
    reflexivity.
  - applying comp'.
    rewrite IHe1.
    rewrite IHe2.
    applying exec.
    applying (eval).
    reflexivity.
Qed.

Theorem comp_correct: forall e,
    exec (comp e) [] = Some [eval e].
Proof.
  intros; apply comp_correct_helper; auto.
Qed.


(** Authors: Christian Doczkal and Jan-Oliver Kaiser *)
From mathcomp Require Import all_ssreflect.
From RegLang Require Import setoid_leq misc languages dfa nfa.

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

(** * Regular Expressions

This file contains the definition of regular expressions and the proof
that regular expressions have the same expressive power as finite
automata. *)

Section RegExp.
Variable char : eqType.

Inductive regexp :=
 | Void
 | Eps
 | Atom of char
 | Star of regexp
 | Plus of regexp & regexp
 | Conc of regexp & regexp.

Lemma eq_regexp_dec (e1 e2 : regexp) : {e1 = e2} + {e1 <> e2}.
Proof. decide equality; apply: eq_comparable. Qed.

Definition regexp_eqMixin := EqMixin (compareP eq_regexp_dec).
Canonical Structure form_eqType := EqType _ regexp_eqMixin.
End RegExp.

Arguments void : clear implicits.
Arguments eps : clear implicits.
Prenex Implicits Plus.
Arguments plusP [char r s w].

Notation "'Void'" := (@Void _).
Notation "'Eps'" := (@Eps _).

(** We assign a decidable language to every regular expression *)

Fixpoint re_lang (char: eqType) (e : regexp char) : dlang char :=
  match e with
  | Void => void char
  | Eps => eps char
  | Atom x => atom x
  | Star e1 => star (re_lang e1)
  | Plus e1 e2 => plus (re_lang e1) (re_lang e2)
  | Conc e1 e2 => conc (re_lang e1) (re_lang e2)
  end.

Canonical Structure regexp_predType (char: eqType) := mkPredType (@re_lang char).

(** We instantiate Ssreflects Canonical Big Operators *)
Notation "\sigma_( i <- r )  F" := (\big[Plus/Void]_(i <- r) F) (at level 50).
Notation "\sigma_( i | P )  F" := (\big[Plus/Void]_(i | P) F) (at level 50).

Lemma big_plus_seqP (T char : eqType) (r : seq T) w (F : T -> regexp char) :
  reflect (exists2 x, x \in r & w \in F x) (w \in \sigma_(i <- r) F i).
Proof.
  elim: r w => [|r rs IHrs] w. rewrite big_nil; by constructor => [[x]].
  rewrite big_cons; apply: (iffP plusP) => [[H|H]|[x]].
  - exists r => //; by rewrite mem_head.
  - case/IHrs : H => x Hx ?. exists x => //. by rewrite in_cons Hx orbT.
  - rewrite in_cons; case/orP => [/eqP -> |]; auto => ? ?.
    right. apply/IHrs. by exists x.
Qed.

Lemma big_plusP (T char: finType) (P:pred T) w (F : T -> regexp char) :
  reflect (exists2 i, P i  & w \in F i) (w \in \sigma_(i | P i) F i).
Proof.
  rewrite -big_filter filter_index_enum.
  apply: (iffP (big_plus_seqP _ _ _)) => [|] [x] H1 H2; exists x => //;
    move: H1; by rewrite mem_enum.
Qed.

Fixpoint re_size (char: eqType) (e : regexp char) :=
  match e with
  | Star s => (re_size s).+1
  | Plus s t => ((re_size s)+(re_size t)).+1
  | Conc s t => ((re_size s)+(re_size t)).+1
  | _ => 1
  end.

Lemma big_plus_size (T char : eqType) (r : seq T) (F : T -> regexp char) m :
  (forall i, i \in r -> re_size (F i) <= m) -> re_size (\sigma_(i <- r) F i) <= (size r * m.+1).+1.
Proof.
  elim: r => [|e r IH /all1s [A B]]; first by rewrite big_nil.
  rewrite big_cons /= ltnS mulSn addSn -addnS leq_add //. exact: IH.
Qed.

(** ** Regular Expressions to Finite Automata *)
Section DFAofRE.
Variable (char : finType).

Fixpoint re_to_nfa (r : regexp char): nfa char :=
  match r with
  | Void => dfa_to_nfa (dfa_void _)
  | Eps => nfa_eps _
  | Atom a => nfa_char a
  | Star s => nfa_star (re_to_nfa s)
  | Plus s t => nfa_plus (re_to_nfa s) (re_to_nfa t)
  | Conc s t => nfa_conc (re_to_nfa s) (re_to_nfa t)
  end.

Lemma re_to_nfa_correct (r : regexp char) : nfa_lang (re_to_nfa r) =i r.
Proof.
  elim: r => [||a|s IHs |s IHs t IHt |s IHs t IHt] w //=.
  - by rewrite -dfa_to_nfa_correct inE /dfa_accept inE.
  - exact: nfa_eps_correct.
  - exact: nfa_char_correct.
  - rewrite nfa_star_correct. exact: star_eq.
  - by rewrite nfa_plus_correct /plus inE IHs IHt.
  - rewrite nfa_conc_correct. exact: conc_eq.
Qed.

Lemma re_to_nfa_size e : #|re_to_nfa e| <= 2 * re_size e.
Proof.
  elim: e; rewrite /= ?card_unit ?card_bool => //.
  - move => e IH. by rewrite card_option (leqRW IH) mulnS add2n.
  - move => e1 IH1 e2 IH2.
    by rewrite card_sum (leqRW IH1) (leqRW IH2) mulnS mulnDr add2n ltnW.
  - move => e1 IH1 e2 IH2.
    by rewrite card_sum (leqRW IH1) (leqRW IH2) mulnS mulnDr add2n ltnW.
Qed.

Definition re_to_dfa := @nfa_to_dfa _ \o re_to_nfa.

Lemma re_to_dfa_correct (r : regexp char) : dfa_lang (re_to_dfa r) =i r.
Proof. move => w. by rewrite -nfa_to_dfa_correct re_to_nfa_correct. Qed.

Lemma re_to_dfa_size e : #|re_to_dfa e| <= 2^(2 * re_size e).
Proof. by rewrite card_set leq_pexp2l // re_to_nfa_size. Qed.

(** Decidability of regular expression equivalence *)

Definition re_equiv r s := dfa_equiv (re_to_dfa r) (re_to_dfa s).

Lemma re_equiv_correct r s : reflect (r =i s) (re_equiv r s).
Proof.
  apply: (iffP (dfa_equiv_correct _ _)) => H w;
    move/(_ w) : H; by rewrite !re_to_dfa_correct.
Qed.

End DFAofRE.

(** ** Finite Automata to Regular Expressions (Kleene Construction) *)

Section KleeneAlgorithm.
  Variable char : finType.
  Variable A : dfa char.

  (** We first define the transition languages between states. The
  trasition languages are defined such that [w \in L^X q p] iff for
  all nonempty strict prefixes [v] of [w], [delta q v \in X]. *)

  Definition L (X : {set A}) (p q : A) x :=
    (delta p x == q) && [forall (i : 'I_(size x) | 0 < i), delta p (take i x) \in X].
  Notation "'L^' X" := (L X) (at level 8,format "'L^' X").

  Lemma dfa_L x y w : w \in L^setT x y = (delta x w == y).
  Proof.
    rewrite unfold_in. case: (_ == _) => //=.
    apply/forall_inP => ? ?. by rewrite inE.
  Qed.

  Lemma LP {X : {set A}} {p q : A} {x} :
    reflect (delta p x = q /\ forall i, (0 < i) -> (i < size x) -> delta p (take i x) \in X)
            (x \in L^X p q).
  Proof.
    apply: (iffP andP); case => /eqP ? H; split => //.
    - move => i I1 I2. exact: (forall_inP H (Ordinal I2)).
    - apply/forall_inP => [[i I1 /= I2]]; auto.
  Qed.

  Lemma L_monotone (X : {set A}) (x y z : A): {subset L^X x y <= L^(z |: X) x y}.
  Proof.
    move => w. rewrite !unfold_in. case: (_ == _) => //. apply: sub_forall => i /=.
    case: (_ < _) => //= H. by rewrite inE H orbT.
  Qed.

  Lemma L_nil X x y : reflect (x = y) ([::] \in L^X x y).
  Proof. apply: (iffP LP) => //=. by case. Qed.

  Lemma L_set0 p q w :
    L^set0 q p w -> p = q /\ w = [::] \/ exists2 a, w = [::a] & p = dfa_trans q a.
  Proof.
    case/LP => <-. case: w => [|a [|b w]] H ; [by left|by right;exists a|].
    move: (H 1). do 2 case/(_ _)/Wrap => //. by rewrite inE.
  Qed.

  Lemma L_split X p q z w : w \in L (z |: X) p q ->
    w \in L^X p q \/
    exists w1 w2, [/\ w = w1 ++ w2, size w2 < size w, w1 \in L^X p z & w2 \in L^(z |: X) z q].
  Proof.
    case/LP => H1 H2.
    case: (find_minn_bound (fun i => (0 < i) && (delta p (take i w) == z)) (size w)).
    - case => i [lt_w /andP [i_gt0 /eqP delta_z] min_i]; right.
      exists (take i w); exists (drop i w).
      have ? : 0 < size w by exact: ltn_trans lt_w.
      rewrite cat_take_drop size_drop -{2}[size w]subn0 ltn_sub2l //; split => //.
      + apply/LP. split => // j J1 J2.
        have lt_i_j : j < i. apply: leq_trans J2 _. by rewrite size_take lt_w.
        have/(H2 _ J1) : j < size w. exact: ltn_trans lt_w.
        case/setU1P => [H|]; last by rewrite take_take.
        move: (min_i _ lt_i_j). by rewrite negb_and J1 H eqxx.
      + apply/LP. rewrite -H1 -{2}[w](cat_take_drop i) delta_cat delta_z.
        split => // j J1 J2. rewrite -{1}delta_z -delta_cat -take_addn.
        apply: H2; first by rewrite addn_gt0 J1 orbT.
        by rewrite -[w](cat_take_drop i) size_cat size_take lt_w ltn_add2l.
    - move => H; left. apply/LP. split => // i I1 I2. apply: contraTT (H2 _ I1 I2) => C.
      rewrite inE negb_or C inE andbT. apply: contraNN (H _ I2) => ->. by rewrite I1.
  Qed.

  Lemma L_cat (X : {set A}) x y z w1 w2 :
    z \in X -> w1 \in L^X x z -> w2 \in L^X z y -> w1++w2 \in L^X x y.
  Proof.
    move => Hz /LP [H11 H12] /LP [H21 H22]. apply/LP.
    split; first by rewrite delta_cat H11 H21.
    move => i i_gt0 H. rewrite take_cat. case: (boolP (i < _)); first exact: H12.
    rewrite delta_cat H11 -leqNgt => le_w1.
    case: (posnP (i - size w1)) => [->|Hi]; first by rewrite take0.
    apply: H22 => //. by rewrite -(ltn_add2l (size w1)) subnKC // -size_cat.
  Qed.

  Lemma L_catL X x y z w1 w2 :
    w1 \in L^X x z -> w2 \in L^(z |: X) z y -> w1++w2 \in L^(z |: X) x y.
  Proof. move/(L_monotone z). apply: L_cat. exact: setU11. Qed.

  Lemma L_catR X x y z w1 w2 :
    w1 \in L^(z |: X) x z -> w2 \in L^X z y -> w1++w2 \in L^(z |: X) x y.
  Proof. move => H /(L_monotone z). apply: L_cat H. exact: setU11. Qed.

  Lemma L_star (X : {set A}) z w : w \in star (L^X z z) -> w \in L^(z |: X) z z.
  Proof.
    move/starP => [vv Hvv ->]. elim: vv Hvv => [_|r vv IHvv]; first exact/L_nil.
    move => /= /andP [/andP [_ H1] H2]. exact: L_catL H1 (IHvv H2).
  Qed.

  (** Main Lemma - L satisfies a recursive equation that can be used
  to construct a regular expression *)

  Lemma L_rec (X : {set A}) x y z :
    L^(z |: X) x y =i plus (conc (L^X x z) (conc (star (L^X z z)) (L^X z y))) (L^X x y).
  Proof.
    move => w. apply/idP/idP.
    - move: w x y. apply: (size_induction (measure := size)) => w IHw x y.
      move/L_split => [|[w1 [w2 [Hw' H1 Hw1 Hw2]]]].
      + rewrite inE => ->. by rewrite orbT.
      + move: (IHw w2 H1 z y Hw2) Hw' => H4 -> {IHw H1}.
        rewrite inE (conc_cat Hw1 _) //.
        case/plusP : H4 => H; last by rewrite -[w2]cat0s conc_cat //.
        move/concP : H => [w21] [w22] [W1 [W2]] /concP [w221] [w222] [W3 [W4 W5]]; subst.
        by rewrite catA conc_cat // star_cat.
    - case/plusP ; last exact: L_monotone.
      move/concP => [w1] [w2] [-> [Hw1]] /concP [w3] [w4] [-> [Hw3 Hw4]].
      by rewrite (L_catL Hw1) // (L_catR _ Hw4) // L_star.
  Qed.

  (** Construction of the regular expression *)

  Definition edges (x y : A) := \big[Plus/Void]_(a | dfa_trans x a == y) Atom a.

  Definition edgesP x y w :
    reflect (exists2 a, w = [::a] & dfa_trans x a = y) (w \in edges x y).
  Proof. apply: (iffP (big_plusP _ _ _)) => [|] [a] /eqP ? /eqP ?; by exists a. Qed.

  Definition R0 x y := Plus (if x == y then Eps else Void) (edges x y).

  Lemma mem_R0 w x y :
    reflect (w = [::] /\ x=y \/ exists2 a, w = [::a] & dfa_trans x a = y)
            (w \in R0 x y).
  Proof.
    apply: (iffP plusP).
    - case => [| /edgesP]; auto. case e : (x == y) => // /eqP.
      by rewrite (eqP e); auto.
    - case => [[-> ->]|/edgesP];auto. by rewrite eqxx; auto.
  Qed.

  Fixpoint R (X : seq A) (x y : A) :=
    if X isn't z :: X' then R0 x y else
      Plus (Conc (R X' x z) (Conc (Star (R X' z z)) (R X' z y))) (R X' x y).

  Notation "'R^' X" := (R X) (at level 8, format "'R^' X").

  Lemma L_R (X : seq A) x y : L^[set z in X] x y =i R^X x y.
  Proof.
    elim: X x y => [|z X' IH] x y w.
    - rewrite (_ : [set z in [::]] = set0) //=.
      apply/idP/mem_R0.
      + move/L_set0 => [[-> ->]|[a -> ->]]; by eauto.
      + move => [[-> ->]|[a -> <-]]; apply/LP => /=; split => // [[|i]] //.
    - rewrite set_cons /= (L_rec _ _) -2!topredE /= /plus /= IH.
      f_equal.
      apply: conc_eq; first exact: IH.
      apply: conc_eq; last exact: IH.
      apply: star_eq. exact: IH.
  Qed.

  Definition dfa_to_re : regexp char := \sigma_(x | x \in dfa_fin A) R^(enum A) (dfa_s A) x.

  Lemma dfa_to_re_correct : dfa_lang A =i dfa_to_re.
  Proof.
    move => w. apply/idP/big_plusP => [H|[x Hx]].
    - exists (delta_s A w) => //. by rewrite -L_R set_enum dfa_L.
    - by rewrite -L_R set_enum dfa_L inE /dfa_accept => /eqP ->.
  Qed.

  (** ** Size Bound for Kleene Theorem *)

  Let c := (2 * #|char|).+3.

  Lemma R0_size x y : re_size (R0 x y) <= c.
  Proof.
    rewrite /= [X in X + _](_ : _ = 1); last by case (_ == _).
    rewrite add1n !ltnS. rewrite /edges -big_filter.
    apply: leq_trans (big_plus_size (m := 1) _) _ => [//|].
    rewrite size_filter ltnS mulnC leq_mul2l /=.
    apply: leq_trans (count_size _ _) _. by rewrite /index_enum -enumT cardE.
  Qed.

  Fixpoint R_size_rec (n : nat) := if n is n'.+1 then 4 * R_size_rec n' + 4 else c.

  Lemma R_size x : re_size (R^(enum A) (dfa_s A) x) <= R_size_rec #|A| .
  Proof.
    rewrite cardE. elim: (enum A) (dfa_s A) x => [|r s IH] p q.
    - exact: R0_size.
    - rewrite /= 6!(addSn,addnS) addn4 !ltnS !(leqRW (IH _ _)).
      by rewrite !mulSn mul0n addn0 !addnA.
  Qed.

  Lemma R_size_low (n : nat) : 3 <= R_size_rec n.
  Proof. elim: n => // n IH. by rewrite (leqRW IH) /= -(leqRW (leq_addr _ _)) leq_pmull. Qed.

  Lemma R_size_high n : R_size_rec n <= c * 4^(2 * n).
  Proof.
    elim: n => //= [|n IH].
    - by rewrite mulnS muln0 addn0.
    - rewrite [in X in _^X]mulnS expnD mulnA [c * _]mulnC -mulnA.
      rewrite -(leqRW IH) -[4^2]/((1+3) * 4) -mulnA mulnDl mul1n leq_add //.
      by rewrite -(leqRW (R_size_low _)).
  Qed.

  Lemma dfa_to_re_size : re_size dfa_to_re <= (#|A| * (c * 4 ^ (2 * #|A|)).+1).+1.
  Proof.
    rewrite /dfa_to_re -big_filter (leqRW (big_plus_size (m := R_size_rec #|A|)_)).
    - rewrite -(leqRW (R_size_high _)) size_filter (leqRW (count_size _ _)).
      by rewrite ltnS /index_enum -enumT cardE.
    - move => q _. exact: R_size.
  Qed.

End KleeneAlgorithm.

Lemma regularP (char : finType) (L : lang char) :
  regular L <-T->  { e : regexp char | forall x, L x <-> x \in e}.
Proof.
  split => [[A HA]|[e He]].
  - exists (dfa_to_re A) => x. by rewrite -dfa_to_re_correct.
  - exists (re_to_dfa e) => x. by rewrite re_to_dfa_correct.
Qed.

(** Closure of Regular Expressions under intersection and complement *)

Definition Inter (char : finType) (r s : regexp char) :=
  dfa_to_re (dfa_op andb (re_to_dfa r) (re_to_dfa s)).

Lemma Inter_correct (char : finType) (r s : regexp char) w :
  w \in Inter r s = (w \in r) && (w \in s).
Proof. by rewrite /Inter -dfa_to_re_correct dfa_op_correct !re_to_dfa_correct. Qed.

Definition Neg (char : finType) (r : regexp char) :=
  dfa_to_re (dfa_compl (re_to_dfa r)).

Lemma Neg_correct (char : finType) (r : regexp char) w :
  w \in Neg r = (w \notin r).
Proof. by rewrite /Neg -dfa_to_re_correct dfa_compl_correct !re_to_dfa_correct. Qed.

(** ** Regular expression for images of homomorphimsms *)

Prenex Implicits Conc.
Definition String (char : finType) (w : word char) :=
  foldr Conc Eps [seq Atom a | a <- w].

Lemma StringE (char : finType) (w : word char) : String w =i pred1 w.
Proof.
  elim: w => [|a v IHv] w //=. rewrite inE /String /=. apply/concP/eqP.
  - move => [w1] [w2] [e []]. set r := foldr _ _ _.
    rewrite -/(re_lang r) inE e => /eqP -> H /=.
    rewrite IHv inE in H. by rewrite (eqP H).
  - move => e. exists [:: a]; exists v; split => //; split.
    by rewrite inE. by rewrite IHv inE eqxx.
Qed.

Section Image.
  Variables (char char' : finType) (h : seq char -> seq char').
  Hypothesis h_hom : homomorphism h.

  Fixpoint re_image (e : regexp char) : regexp char' :=
    match e with
    | Void => Void
    | Eps => Eps
    | Atom a => String (h [:: a])
    | Star e => Star (re_image e)
    | Plus e1 e2 => Plus (re_image e1) (re_image e2)
    | Conc e1 e2 => Conc (re_image e1) (re_image e2)
    end.

  Lemma re_imageP e v : reflect (image h (re_lang e) v) (v \in re_image e).
  Proof.
    elim: e v => [||a|e IHe|e1 IHe1 e2 IHe2|e1 IHe1 e2 IHe2] v /=.
    - rewrite inE; constructor. move => [u]. by case.
    - rewrite inE; apply: (iffP eqP) => [-> |[w] [] /eqP -> <-]; last exact: h0.
      exists [::]; by rewrite ?h0.
    - rewrite StringE. apply: (iffP eqP) => [->|[w /=]].
      + exists [::a] => //. by rewrite /atom inE.
      + by rewrite /atom inE => [[]] /eqP -> <-.
    - apply: (iffP idP) => [/starP [vv] /allP Hvv dev_v|].
        have {Hvv IHe} Hvv v' : v' \in vv -> image h (re_lang e) v'.
          by move => /Hvv /= /andP [_ /IHe].
        subst v. elim: vv Hvv => [|v vv IHvv] Hvv /=; first by exists [::]; rewrite ?h0.
        case: (Hvv v (mem_head _ _)) => w [Hw1 Hw2].
        case/all1s: Hvv => Hv /IHvv [ww [Hww1 Hww2]].
        exists (w++ww); split; by [exact: star_cat | rewrite h_hom Hw2 Hww2].
      + case => w [] /starP [ww] /allP Hww1 -> <-. rewrite h_flatten //.
        apply: starI => v' /mapP [w' /Hww1 /= /andP [_ Hw' ->]].
        apply/IHe. by exists w'.
    - apply: (iffP orP).
       + case => [/IHe1 | /IHe2] [w] [] H <-.
           exists w => //. by rewrite /plus inE (_ : w \in re_lang e1).
         exists w => //. by rewrite /plus inE (_ : w \in re_lang e2) ?orbT.
       + case => w []. case/orP => H <-; [left; apply/IHe1 |right; apply/IHe2]; by exists w.
    - apply: (iffP idP).
      + case/concP => v1 [v2] [e] [/IHe1 [w [Hw1 Hw2]] /IHe2 [w' [Hw1' Hw2']]].
        exists (w++w'); split; first exact: conc_cat.
        by rewrite h_hom e Hw2 Hw2'.
      + case => w [] /concP [w1] [w2] [-> [H1 H2 <-]]. rewrite h_hom.
        apply: conc_cat; [apply/IHe1|apply/IHe2]. by exists w1. by exists w2.
  Qed.

End Image.

Lemma im_regular (char char' : finType) (h : word char -> word char') L :
  homomorphism h -> regular L -> regular (image h L).
Proof.
  move => hom_h /regularP [e He]. apply/regularP. exists (@re_image _ _ h e) => w.
  transitivity (image h (re_lang e) w); first exact: image_ext.
  exact: rwP (re_imageP _ _ _).
Qed.

(** ** Regular Expression for word reversal *)

Fixpoint Rev (char : finType) (e : regexp char) :=
  match e with
  | Star e => Star (Rev e)
  | Plus e1 e2 => Plus (Rev e1) (Rev e2)
  | Conc e1 e2 => Conc (Rev e2) (Rev e1)
  | _ => e
  end.

Lemma Rev_correct (char : finType) (e : regexp char) w :
  w \in Rev e = (rev w \in e).
Proof.
  elim: e w => [||a|e IH|e1 IH1 e2 IH2|e1 IH1 e2 IH2] w //.
  - rewrite !inE. apply/eqP/idP; first by move->.
    elim/last_ind: w => //= s a _. by rewrite rev_rcons.
  - rewrite !inE. apply/eqP/eqP; first by move->.
    do 2 elim/last_ind: w => //= w ? _. by rewrite !rev_rcons.
  - rewrite /=; apply/idP/idP; case/starP => vv /allP /= H.
    + move->. rewrite rev_flatten. apply: starI => v'.
      rewrite mem_rev => /mapP [v V1 ->]. rewrite -IH. by case/andP: (H _ V1).
    + rewrite -{2}[w]revK => ->. rewrite rev_flatten. apply: starI => v'.
      rewrite mem_rev => /mapP [v V1 ->]. rewrite IH revK. by case/andP: (H _ V1).
  - by rewrite /= !inE -!/(re_lang _) IH1 IH2.
  - rewrite /=. apply/concP/concP => [] [w1] [w2]; rewrite -!/(re_lang _).
    + move => [-> [A B]]. exists (rev w2); exists (rev w1). by rewrite rev_cat -IH1 -IH2.
    + rewrite -{2}[w]revK. move => [-> [A B]]. exists (rev w2); exists (rev w1).
      by rewrite rev_cat IH1 IH2 !revK.
Qed.

Lemma regular_rev (char : finType) (L : lang char) :
  regular L -> regular (fun x => L (rev x)).
Proof. case/regularP => e H. apply/regularP. exists (Rev e) => x. by rewrite Rev_correct. Qed.


From NP Require Export Utils.

Inductive action := Tau | Snd (n:nat) | Rcv (n:nat).

Definition LTS := {X:Type & prod (X -> action -> X -> Type) X}.
Definition states (S:LTS) := match S with existT _ X _ => X end.
Definition istrans (S:LTS) (s:states S) (a:action) (t:states S) : Type. destruct S as [X [p s0]]. cbn in s. cbn in t. exact (p s a t). Defined.
Definition start (S:LTS) : states S. destruct S as [X [p s0]]. cbn. exact s0. Defined.

Definition invAction (a:action) := match a with Tau=>Tau | Snd n => Rcv n | Rcv n => Snd n end.
Lemma invCancel (a:action) : invAction (invAction a) = a. destruct a; now cbn. Defined.

Definition actionFilter := list nat.
Definition admits (H:actionFilter) (a:action) :Type := match a with Tau=>True | Snd n => n cnel H|Rcv n => n cnel H end.
Definition cAdmits (H:actionFilter) (a:action) : dec (admits H a).
destruct a. now left. cbn. apply cninDec, natDec. apply cninDec, natDec. Defined.

Inductive CCS :=
| Prefix : action -> CCS -> CCS
| Choice : CCS -> CCS -> CCS
| Par : CCS -> CCS -> CCS
| Restrict : CCS -> actionFilter -> CCS
| Var : nat -> CCS
| Stop : CCS.

Inductive trans (G:nat -> CCS) : CCS -> action -> CCS -> Type :=
  tPrefix a P : trans G (Prefix a P) a P
| tChoiceL a P Q P' : trans G P a P' -> trans G (Choice P Q) a P'
| tChoiceR a P Q Q' : trans G Q a Q' -> trans G (Choice P Q) a Q'
| tParL a P Q P' : trans G P a P' -> trans G (Par P Q) a (Par P' Q)
| tParR a P Q Q' : trans G Q a Q' -> trans G (Par P Q) a (Par P Q')
| tSync a P Q P' Q' : a <> Tau -> trans G P a P' -> trans G Q (invAction a) Q' -> trans G (Par P Q) Tau (Par P' Q')
| tRes a P P' (H:actionFilter) : admits H a -> trans G P a P' -> trans G (Restrict P H) a (Restrict P' H)
| tRec n a P P' : G n = P -> trans G P a P' -> trans G (Var n) a P'.

Fixpoint ptrans (S:LTS) (s:states S) (A:list action) (t:states S) : Type := match A with nil => s = t | a::A => {r:states S & prod (istrans S s a r) (ptrans S r A t)} end.

Definition cLTS (S:LTS) := prod (prod {A:list (states S) & covering A} (eqDec (states S))) ({B:list ((states S) * action * (states S)) & forall (s:states S) (a:action) (t:states S), istrans S s a t <=> ((s,a),t) cel B}).
Definition CCSLTS (G:nat->CCS) (s0:CCS) : LTS := existT (fun X => prod (X -> action -> X -> Type) X) CCS (pair (fun s a t => trans G s a t) s0).

Lemma finiteLTS' {n:nat} (A:list ((finT (S n) * action * finT (S n)))) (s0:finT (S n)) : LTS.
exists (finT (S n)). split.
* intros s a t. exact ((s,a,t) cel A).
* exact s0.
Defined.

Lemma finiteLTS {n:nat} (A:list ((finT (S n) * action * finT (S n)))) (s0:finT (S n)) : {S:LTS & cLTS S}.
pose (finiteLTS' A s0) as SS.
exists SS. unfold finiteLTS' in SS. split. split.
* unfold states. unfold SS. apply coveringFinT.
* apply edFin.
* exists A. intros s a t. now split.
Defined.

Definition eqAction : eqDec(action).
intros [|n|n] [|m|m]; try firstorder congruence.
* destruct (natDec n m) as [Heq|Hneq]. left. congruence. right. congruence.
* destruct (natDec n m) as [Heq|Hneq]. left. congruence. right. congruence.
Defined.

Definition eqCCS : eqDec(CCS).

intros A B. induction A as [a P IH|P IHP Q IHQ|P IHP Q IHQ|P IH H|n|] in B|-*; destruct B as [a' P'|P' Q'|P' Q'|P' H'|n'|]; try firstorder congruence.
* destruct (IH P') as [Hl|Hr]. destruct (eqAction a a') as [Hal|Har]. left. congruence. right. congruence. right. congruence.
* destruct (IHP P') as [Hl|Hr]. destruct (IHQ Q') as [HQl|HQr].  left. congruence. right. congruence. right. congruence.
* destruct (IHP P') as [Hl|Hr]. destruct (IHQ Q') as [HQl|HQr].  left. congruence. right. congruence. right. congruence.
* destruct (IH P') as [Hl|Hr]. destruct (edList (natDec) H H') as [HHl|HHr]. left. congruence. right. congruence. right. congruence.
* destruct (natDec n n') as [Hl|Hr]. left. congruence. right. congruence.
Defined.

Definition ttrans (R:LTS) (s t:states R) : Type := {n:nat & (fix ttrans (s t:states R) (m:nat) : Type := match m with 0 => s = t | S m => {r:states R & prod (istrans R s Tau r) (ttrans r t m)} end) s t n}.
Definition isatrans (R:LTS) (s:states R) (a:action) (t:states R) := {r1 : states R & {r2 : states R & prod (prod (ttrans R s r1) (istrans R r1 a r2)) (ttrans R r2 t)}}.
Definition iswtrans (R:LTS) (s:states R) (a:action) (t:states R) := match a with Tau => ttrans R s t | a => isatrans R s a t end.

Fixpoint istrace (R:LTS) (s:states R) (al:list action) : Type := match al with nil => True | a::ar => {s' : states R & prod (istrans R s a s') (istrace R s' ar)} end.
Fixpoint ispath (R:LTS) (s:states R) (al:list action) (t:states R) : Type := match al with nil => s = t | a::ar => {s' : states R & prod (istrans R s a s') (ispath R s' ar t)} end.
Fixpoint isttrace (R:LTS) (s:states R) (al:list action) : Type := match al with nil => ({t:states R & {aa : action  & istrans R s aa t}} -> False) | a::ar => {s':states R & prod (istrans R s a s') (isttrace R s' ar)} end.

Definition Reachable (R:LTS) (s:states R) (t:states R) := {ar : list action & ispath R s ar t}.
Definition Reach (R:LTS) := Reachable R (start R).

Definition changeStart (A:LTS) (s0:states A) : LTS := existT _ (states A) (pair (istrans A) s0).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O0 E0 Eprime0 A B : Universe, ((wd_ O0 E0 /\ (wd_ O0 A /\ (wd_ A B /\ (wd_ O0 B /\ (wd_ E0 Eprime0 /\ (wd_ O0 Eprime0 /\ (col_ O0 E0 A /\ (col_ O0 E0 B /\ col_ O0 E0 O0)))))))) -> col_ O0 A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

Require Import rel square cl.

Set Implicit Arguments.

Section cl_confluent.

  Reserved Notation "x '-r->' y" (at level 70).

  Inductive cl_rho : clterm -> clterm -> Prop :=

    | in_cl_rho_I : forall x,               I o x -r-> x

    | in_cl_rho_K : forall x y,         K o x o y -r-> x

    | in_cl_rho_S : forall x y z,   S o x o y o z -r-> x o z o (y o z)

    | in_cl_rho_0 : forall f,                   f -r-> f

    | in_cl_rho_1 : forall f g a b,         f     -r-> g
                                 ->             a -r->     b
                                 ->         f o a -r-> g o b

  where "x -r-> y" := (cl_rho x y).

  Infix "-r>>" := (crt cl_rho) (at level 70).

  Fact cl_rho_I_inv v : I -r-> v -> v = I.
  Proof. inversion_clear 1; auto. Qed.

  Fact cl_rho_K_inv v : K -r-> v -> v = K.
  Proof. inversion_clear 1; auto. Qed.

  Fact cl_rho_S_inv v : S -r-> v -> v = S.
  Proof. inversion_clear 1; auto. Qed.

  Fact cl_rho_var_inv p v : µ p -r-> v -> v = µ p.
  Proof. inversion_clear 1; auto. Qed.

  Fact cl_rho_inv f g :
       f -r-> g
    -> f = I o g
    \/ (exists y, f = K o g o y)
    \/ (exists x y z, f = S o x o y o z /\ g = x o z o (y o z))
    \/ f = g
    \/ (exists u v a b, f = u o a /\ g = v o b /\ u -r-> v /\ a -r-> b).
  Proof.
    induction 1.
    do 0 right; left; auto.
    do 1 right; left; exists y; auto.
    do 2 right; left; exists x, y, z; auto.
    do 3 right; left; auto.
    do 4 right; exists f, g, a, b; auto.
  Qed.

  Fact cl_rho_app_inv f a v :
      f o a -r-> v
   -> (exists g b, v = g o b /\ f -r-> g /\ a -r-> b)
   \/ (f = I /\ a = v)
   \/ (f = K o v)
   \/ (exists x y, f = S o x o y /\ v = x o a o (y o a)).
  Proof.
    intros H.
    apply cl_rho_inv in H.
    destruct H as [ H
                | [ (y & H)
                | [ (x & y & z & H & ?)
                | [ H
                | (x & y & z & k & H & ? & ? & ?) ] ] ] ]; subst.
    apply cl_app_inj in H; destruct H; subst.
    right; left; auto.
  Admitted.

  Fact cl_rho_I_app_inv a v :
         I o a -r-> v
      -> (exists b, v = I o b /\ a -r-> b)
       \/ a = v.
  Proof.
    intros H.
    apply cl_rho_app_inv in H.
    destruct H as [ (g1 & b1 & ? & G1 & G2)
                | [ ?
                | [ ?
                  | (x1 & y1 & G1 & G2) ] ] ].
    apply cl_rho_I_inv in G1; subst.
    left; exists b1; auto.
  Admitted.

  Fact cl_rho_K_app_inv a v : K o a -r-> v -> exists b, v = K o b /\ a -r-> b.
  Proof.
    intros H.
    apply cl_rho_app_inv in H.
    destruct H as [ (g1 & b1 & ? & G1 & G2)
                | [ ?
                | [ ?
                  | (x1 & y1 & G1 & G2) ] ] ].
    apply cl_rho_K_inv in G1; subst; auto.
  Admitted.

  Fact cl_rho_S_app_inv a v : S o a -r-> v -> exists b, v = S o b /\ a -r-> b.
  Proof.
  Admitted.

  Fact cl_rho_S_app2_inv a b v : S o a o b -r-> v -> exists x y, v = S o x o y /\ a -r-> x /\ b -r-> y.
  Proof.
    intros H.
    apply cl_rho_app_inv in H.
    destruct H as [ (g1 & b1 & ? & G1 & G2)
                | [ ?
                | [ ?
                  | (x1 & y1 & G1 & G2) ] ] ].
    apply cl_rho_S_app_inv in G1.
    destruct G1 as (c & ? & ?); subst.
    exists c, b1; auto.
    discriminate (proj1 H).
    discriminate H.
    discriminate G1.
  Qed.

  Ltac cl_rho_inv_0 :=
    match goal with
      | H : S      -r-> ?v |- _ => apply cl_rho_S_inv in H; subst v
      | H : K      -r-> ?v |- _ => apply cl_rho_K_inv in H; subst v
      | H : I      -r-> ?v |- _ => apply cl_rho_I_inv in H; subst v
      | H : µ _    -r-> ?v |- _ => apply cl_rho_var_inv in H; subst v
    end.

  Ltac cl_rho_inv_1 b :=
    match goal with
      | H : S o ?x -r-> ?v |- _ => apply cl_rho_S_app_inv in H; destruct H as (b & E & H); subst v
      | H : K o ?x -r-> ?v |- _ => apply cl_rho_K_app_inv in H; destruct H as (b & E & H); subst v
    end.

  Ltac cl_rho_inv_2 a b :=
    match goal with
      | H : S o ?x o ?y -r-> ?v |- _ => apply cl_rho_S_app2_inv in H; destruct H as (a & b & E & H & ?); subst v
    end.

  Theorem cl_rho_square : square cl_rho.
  Proof.
    intros f.
    induction f as [ | | | f Hf a Ha | p ]; intros u v.

    intros; do 2 cl_rho_inv_0.
    exists S; split; constructor 4.

    intros; do 2 cl_rho_inv_0.
    exists K; split; constructor 4.

    intros; do 2 cl_rho_inv_0.
    exists I; split; constructor 4.

    Focus 2.
    intros; do 2 cl_rho_inv_0.
    exists (µ p); split; constructor 4.

    intros H1 H2.
    apply cl_rho_app_inv in H1.
    apply cl_rho_app_inv in H2.
    destruct H1 as [ (g1 & b1 & G0 & G1 & G2)
             | [ (G1 & G2) | [ G1 | (x1 & y1 & G1 & G2) ] ] ];
    destruct H2 as [ (g2 & b2 & H0 & H1 & H2)
             | [ (H1 & H2) | [ H1 | (x2 & y2 & H1 & H2) ] ] ]; subst.

    admit.

    cl_rho_inv_0.
    exists b1; split; auto; constructor.

    cl_rho_inv_1 w.
    exists w; split; auto; constructor.

    cl_rho_inv_2 x3 y3.
    exists (x3 o b1 o (y3 o b1)); split.
    constructor 3.
    do 2 constructor 5; auto.

    admit.

    subst; exists v; split; constructor.

    discriminate H1.

    admit.

    admit.

    admit.

    admit.

    discriminate H1.

    cl_rho_inv_2 x3 y3.
    exists (x3 o b2 o (y3 o b2)); split.
    do 2 constructor 5; auto.
    constructor.

    admit.

    admit.

    apply cl_app_inj in H1; destruct H1 as (H1 & ?); subst y2.
    apply cl_app_inj, proj2 in H1; subst x2.
    exists (x1 o a o (y1 o a)); split; constructor.
  Admitted.

  Corollary cl_rho_confluent : confluent cl_rho.
  Proof.
    apply square_crt; apply cl_rho_square.
  Qed.

End cl_confluent.


Require BinNums.
Require BinPos.

Require Import FP.Data.Ascii.
Require Import FP.Data.Function.
Require Import FP.Data.Nat.
Require Import FP.Relations.RelDec.
Require Import FP.Structures.Additive.
Require Import FP.Structures.Iterable.
Require Import FP.Structures.Convertible.
Require Import FP.Structures.EqDec.
Require Import FP.Structures.Eqv.
Require Import FP.Structures.Lattice.
Require Import FP.Structures.Monoid.
Require Import FP.Structures.Multiplicative.
Require Import FP.Structures.Ord.
Require Import FP.Structures.Show.
Require Import FP.Structures.Comonad.
Require Import FP.Structures.Foldable.
Require Import FP.Structures.Peano.

Import AdditiveNotation.
Import EqDecNotation.
Import FunctionNotation.
Import MonoidNotation.
Import ComonadNotation.

Definition positive := BinNums.positive.
Definition xH := BinNums.xH.
Definition xO := BinNums.xO.
Definition xI := BinNums.xI.

Module PositiveNotation.
  Delimit Scope positive_scope with positive.
End PositiveNotation.
Local Open Scope positive_scope.

Instance positive_nat_Convertible : Convertible positive nat :=
  { convert := BinPos.Pos.to_nat }.

Section EqDec.
  Global Instance pos_EqDec : EqDec positive := { eq_dec := BinPos.Pos.eqb }.
End EqDec.

Section Eqv.
  Global Instance pos_Eqv : Eqv positive := { eqv := eq }.
End Eqv.

Section EqvDec.
  Global Instance pos_EqvDec : EqvDec positive := { eqv_dec := eq_dec }.
End EqvDec.

Section Ord.
  Global Instance pos_Ord : Ord positive := { lt := BinPos.Pos.lt }.
End Ord.

Section OrdDec.
  Definition pos_ord_dec (z1:positive) (z2:positive) : comparison :=
    if z1 =! z2 then Eq
    else if BinPos.Pos.ltb z1 z2 then Lt
    else Gt.
  Global Instance pos_OrdDec : OrdDec positive := { ord_dec := pos_ord_dec }.
End OrdDec.

Section Lattice.
  Global Instance pos_Lattice : Lattice positive :=
    { lmeet := BinPos.Pos.min
    ; ljoin := BinPos.Pos.max
    }.
End Lattice.

Section Show.
  Definition pos_show {R} {SR:ShowResult R} : positive -> R := show '.' convert_to nat.
  Global Instance pos_Show : Show positive := { show := @pos_show }.
End Show.

Section Semiadditive.
  Definition pos_additive_DivSemigroup : DivSemigroup positive :=
    {| div_semigroup_times := BinPos.Pos.add
     ; div_semigroup_div := BinPos.Pos.sub
    |}.
  Global Instance MinusSemiadditive_N : MinusSemiadditive positive :=
    { minus_semiadditive_DivSemigroup := pos_additive_DivSemigroup }.
End Semiadditive.

Section Multiplicative.
  Definition multiplicative_pos_Monoid : Monoid positive :=
    {| monoid_times := BinPos.Pos.mul
     ; monoid_unit := BinNums.xH
    |}.
  Global Instance Multiplicative_N : Multiplicative positive :=
    { multiplicative_Monoid := multiplicative_pos_Monoid }.
End Multiplicative.

Fixpoint pos_cofold' {m} {M:Comonad m} {A}
    (f:positive -> m A -> A) (aM:m A) (n:positive) : A :=
  let double_cofold :=
    pos_cofold' $ fun n aM =>
      let aM := codo aM => f (xI n) aM in
      f (xO n) aM
  in
  match n with
  | xH => coret aM
  | xO n =>
      let aM := codo aM => double_cofold aM n in
      f xH aM
  | xI n =>
      let aM := codo aM => f (xO n) aM in
      let aM := codo aM => double_cofold aM n in
      f xH aM
  end.
Definition pos_cofold {m} {M:Comonad m} {A}
    (f:positive -> m A -> A) (aM:m A) (n:positive) : A :=
  let aM := codo aM => f n aM in
  pos_cofold' f aM n.
Instance pos_Foldable : Foldable positive positive :=
  { cofold := @pos_cofold }.

Fixpoint pos_coiter' {m} {M:Comonad m} {A}
    (f:m A -> positive -> A) (aM:m A) (n:positive) : A :=
  let double_cofold :=
    pos_coiter' $ fun aM n =>
      let aM := codo aM => f aM (xO n) in
      f aM (xI n)
  in
  match n with
  | xH => coret aM
  | xO n =>
      let aM := codo aM => f aM xH in
      double_cofold aM n
  | xI n =>
      let aM := codo aM => f aM xH in
      let aM := codo aM => double_cofold aM n in
      f aM (xO n)
  end.
Definition pos_coiter {m} {M:Comonad m} {A}
    (f:m A -> positive -> A) (aM:m A) (n:positive) : A :=
  let aM := codo aM => pos_coiter' f aM n in
  f aM n.
Instance pos_Iterable : Iterable positive positive :=
  { coiter := @pos_coiter }.

Fixpoint pos_coloopr' {m} {M:Comonad m} {A}
    (f:m A -> A) (aM:m A) (n:positive) : A :=
  let double_coloopr :=
    pos_coloopr' $ fun aM =>
      let aM := codo aM => f aM in
      f aM
  in
  match n with
  | xH => coret aM
  | xO n =>
      let aM := codo aM => double_coloopr aM n in
      f aM
  | xI n =>
      let aM := codo aM => double_coloopr aM n in
      let aM := codo aM => f aM in
      f aM
  end.
Definition pos_coloopr {m} {M:Comonad m} {A}
    (f:m A -> A) (aM:m A) (n:positive) : A :=
  let aM := codo aM => pos_coloopr' f aM n in
  f aM.

Fixpoint pos_coloopl' {m} {M:Comonad m} {A}
    (f:m A -> A) (aM:m A) (n:positive) : A :=
  let double_coloopl :=
    pos_coloopl' $ fun aM =>
      let aM := codo aM => f aM in
      f aM
  in
  match n with
  | xH => coret aM
  | xO n =>
      let aM := codo aM => f aM in
      double_coloopl aM n
  | xI n =>
      let aM := codo aM => f aM in
      let aM := codo aM => f aM in
      double_coloopl aM n
  end.
Definition pos_coloopl {m} {M:Comonad m} {A}
    (f:m A -> A) (aM:m A) (n:positive) : A :=
  let aM := codo aM => f aM in
  pos_coloopl' f aM n.
Instance pos_Peano : Peano positive :=
  { pzero := xH
  ; psucc := BinPos.Pos.succ
  ; coloopr := @pos_coloopr
  ; coloopl := @pos_coloopl
  }.

(*
Require Import FP.Structures.Functor.
Require Import FP.Data.Option.

Definition fix_fact (fuel:positive) : positive -> option positive :=
  flip loopr_fix fuel $ fun fact n =>
    if n '=! 1 then
      Some n
    else
      fmap (times n) $ fact (BinPos.Pos.sub n 1).

Eval compute in fix_fact 1000000000 4.
*)