From Coq Require Import PArith.
From Coq Require Import List.

Import List.ListNotations.
Open Scope list_scope.

From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import NLustre.IsDefined.
From Velus Require Import NLustre.Memories.

From Coq Require Import Sorting.Permutation.

(** * Stack variables *)

(**

  The [Is_variable] predicate identifies those variables that will
  stay on the stack after compilation, ie. anything not defined by an
  [fby].

 *)

Module Type ISVARIABLE
       (Ids          : IDS)
       (Op           : OPERATORS)
       (Import CESyn : CESYNTAX      Op)
       (Import Syn   : NLSYNTAX  Ids Op CESyn)
       (Import Mem   : MEMORIES  Ids Op CESyn Syn)
       (Import IsD   : ISDEFINED Ids Op CESyn Syn Mem).

  Inductive Is_variable_in_eq : ident -> equation -> Prop :=
  | VarEqDef: forall x ck e,   Is_variable_in_eq x (EqDef x ck e)
  | VarEqApp: forall x xs ck f e r, In x xs -> Is_variable_in_eq x (EqApp xs ck f e r).

  (* definition is needed in signature *)
  Definition Is_variable_in (x: ident) (eqs: list equation) : Prop :=
    List.Exists (Is_variable_in_eq x) eqs.

  (** ** Properties *)

  Lemma not_Is_variable_in_EqDef:
    forall x ck y e,
      ~ Is_variable_in_eq x (EqDef y ck e) -> x <> y.
  Proof.
    Hint Constructors Is_variable_in_eq.
    intros ** Hxy. subst x. auto.
  Qed.

  Lemma not_Is_variable_in_EqApp:
    forall x ys ck f e r,
      ~ Is_variable_in_eq x (EqApp ys ck f e r) -> ~ List.In x ys.
  Proof. eauto using Is_variable_in_eq. Qed.

  Lemma Is_variable_in_eq_Is_defined_in_eq:
    forall x eq,
      Is_variable_in_eq x eq
      -> Is_defined_in_eq x eq.
  Proof.
    destruct eq; inversion_clear 1; auto using Is_defined_in_eq.
  Qed.

  Lemma Is_variable_in_Is_defined_in:
    forall x eqs,
      Is_variable_in x eqs
      -> Is_defined_in x eqs.
  Proof.
    induction eqs as [|eq eqs IH]; [now inversion 1|].
    inversion_clear 1 as [Hin ? Hivi|]; [|constructor 2; intuition].
    apply Is_variable_in_eq_Is_defined_in_eq in Hivi.
    now constructor.
  Qed.

  Lemma not_Is_defined_in_eq_not_Is_variable_in_eq:
    forall x eq, ~Is_defined_in_eq x eq -> ~Is_variable_in_eq x eq.
  Proof.
    Hint Constructors Is_defined_in_eq.
    intros x eq Hnidi.
    destruct eq; inversion 1; subst; intuition.
  Qed.

  Lemma not_Is_defined_in_not_Is_variable_in:
    forall x eqs, ~Is_defined_in x eqs -> ~Is_variable_in x eqs.
  Proof.
    Hint Constructors Is_defined_in_eq.
    induction eqs as [|eq].
    - intro H; contradict H; inversion H.
    - intros Hndef Hvar.
      inv Hvar;
      eapply Hndef.
      + constructor; now apply Is_variable_in_eq_Is_defined_in_eq.
      + constructor 2;
            now apply Exists_exists in H0 as (eq' & ? & ?);
                apply Exists_exists; exists eq'; split; auto;
                apply Is_variable_in_eq_Is_defined_in_eq.
  Qed.

  Lemma Is_variable_in_var_defined:
    forall x eqs,
      Is_variable_in x eqs
      <-> In x (vars_defined (filter (notb is_fby) eqs)).
  Proof.
    unfold notb.
    induction eqs as [|eq eqs].
    now apply Exists_nil.
    split; intro HH.
    - inversion_clear HH as [? ? Hdef|? ? Hdef].
      + inversion_clear Hdef; simpl; try apply in_app; auto.
      + apply IHeqs in Hdef. simpl;
        destruct eq; simpl; intuition.
    - destruct eq; simpl in *.
      + destruct HH as [HH|HH].
        * subst; repeat constructor.
        * apply IHeqs in HH. now constructor 2.
      + unfold vars_defined in HH;
        apply in_app in HH.
        destruct HH as [HH|HH].
        * subst; constructor; auto using Is_variable_in_eq.
        * apply IHeqs in HH. now constructor 2.
      + apply IHeqs in HH. now constructor 2.
  Qed.

  Lemma In_EqDef_Is_variable_in:
    forall x ck e eqs,
      In (EqDef x ck e) eqs ->
      Is_variable_in x eqs.
  Proof.
    induction eqs; inversion_clear 1; subst.
    now repeat constructor.
    constructor 2; intuition.
  Qed.

  Lemma In_EqApp_Is_variable_in:
    forall x xs ck f es eqs r,
      List.In x xs ->
      In (EqApp xs ck f es r) eqs ->
      Is_variable_in x eqs.
  Proof.
    induction eqs; inversion_clear 2.
    - now subst; repeat constructor.
    - constructor; eapply IHeqs; eauto.
  Qed.

  Lemma n_out_variable_in_eqs:
    forall n x,
      In x (map fst n.(n_out)) ->
      Is_variable_in x n.(n_eqs).
  Proof.
    intros.
    apply Is_variable_in_var_defined.
    eapply not_In2_app; eauto using n.(n_vout).
    unfold vars_defined; simpl; setoid_rewrite flat_map_concat_map.
    rewrite <- concat_app, <-map_app, Permutation_app_comm, filter_notb_app.
    pose proof n.(n_defd) as HH.
    unfold vars_defined in HH; rewrite flat_map_concat_map in HH.
    rewrite HH, map_app.
    now intuition.
  Qed.

  (** * Decision procedure *)

  Fixpoint variable_eq (vars: PS.t) (eq: equation) {struct eq} : PS.t :=
    match eq with
    | EqDef x _ _   => PS.add x vars
    | EqApp xs _ _ _ _ => ps_adds xs vars
    | EqFby _ _ _ _ => vars
    end.

  Definition variables (eqs: list equation) : PS.t :=
    List.fold_left variable_eq eqs PS.empty.

  (** ** Properties *)

  Lemma Subset_variable_eq:
    forall eq m1 m2,
      PS.Subset m1 m2 ->
      PS.Subset (variable_eq m1 eq) (variable_eq m2 eq).
  Proof.
    intros * Hsub.
    destruct eq; simpl; auto.
    - apply PSP.subset_add_3, PSP.subset_add_2; try apply PS.add_spec; auto.
    - now apply Subset_ps_adds.
  Qed.

  Lemma In_variable_eq:
    forall x eq m,
      PS.In x (variable_eq m eq) <-> PS.In x m \/ PS.In x (variable_eq PS.empty eq).
  Proof.
    destruct eq; simpl;
      try setoid_rewrite PS.add_spec; try setoid_rewrite ps_adds_spec; intuition.
  Qed.

  Lemma In_fold_left_variable_eq:
    forall x eqs m,
      PS.In x (List.fold_left variable_eq eqs m)
      <-> PS.In x (List.fold_left variable_eq eqs PS.empty) \/ PS.In x m.
  Proof.
    induction eqs as [|eq eqs IH]; simpl.
    now split; intro HH; auto; destruct HH as [HH|]; auto;
      apply not_In_empty in HH.
    setoid_rewrite IH; clear IH.
    setoid_rewrite In_variable_eq.
    split; intros [HH|HH]; auto; repeat (destruct HH as [HH|HH]; auto).
    now apply not_In_empty in HH.
  Qed.

  (* tactic definition needed in signature *)
  Ltac not_Is_variable x y :=
    match goal with
    | H: ~ Is_variable_in_eq x (EqDef y _ _) |- _ =>
      apply not_Is_variable_in_EqDef in H
    | H: ~ Is_variable_in_eq x (EqApp y _ _ _ _) |- _ =>
      apply not_Is_variable_in_EqApp in H
    end.

  Lemma Is_variable_in_eq_dec:
    forall x eq, {Is_variable_in_eq x eq}+{~Is_variable_in_eq x eq}.
  Proof.
    intros x eq.
    destruct eq as [y cae|ys f lae|y v0 lae].
    - destruct (ident_eq_dec x y); subst; auto.
      right. inversion 1; subst; auto.
    - destruct (in_dec ident_eq_dec x ys); auto.
      right. inversion 1; subst; auto.
    - right. inversion 1; subst; auto.
  Qed.

  Lemma Is_variable_in_cons:
    forall x eq eqs,
      Is_variable_in x (eq :: eqs) ->
      Is_variable_in_eq x eq
      \/ (~Is_variable_in_eq x eq /\ Is_variable_in x eqs).
  Proof.
    intros x eq eqs Hdef.
    apply List.Exists_cons in Hdef.
    destruct (Is_variable_in_eq_dec x eq); intuition.
  Qed.

  Lemma not_Is_variable_in_cons:
    forall x eq eqs,
      ~Is_variable_in x (eq :: eqs)
      <-> ~Is_variable_in_eq x eq /\ ~Is_variable_in x eqs.
  Proof.
    intros x eq eqs. split.
    intro H0; unfold Is_variable_in in H0; auto.
    destruct 1 as [H0 H1]; intro H; apply Is_variable_in_cons in H; intuition.
  Qed.

  Lemma Is_variable_in_variables:
    forall x eqs,
      PS.In x (variables eqs)
      <-> Is_variable_in x eqs.
  Proof.
    unfold variables, Is_variable_in.
    induction eqs as [ | eq ].
    - rewrite List.Exists_nil; split; intro H;
      try apply not_In_empty in H; contradiction.
    - simpl.
      rewrite In_fold_left_variable_eq.
      split.
      + rewrite List.Exists_cons.
        destruct 1. intuition.
        destruct eq;
          match goal with
          | |- context[ EqApp _ _ _ _ _ ] =>
            generalize ps_adds_spec; intro add_spec
          | _ =>
            generalize PS.add_spec; intro add_spec
          end;
          try (apply not_In_empty in H; intuition);
          (simpl in H; apply add_spec in H; destruct H;
           [ try rewrite H; left; constructor; auto
           | apply not_In_empty in H; contradiction ]).
      + intro H; apply List.Exists_cons in H; destruct H.
        destruct eq;
          match goal with
          | |- context[ EqApp _ _ _ _ _ ] =>
            generalize ps_adds_spec; intro add_spec
          | _ =>
            generalize PS.add_spec; intro add_spec
          end; try inversion H;
            (right; apply add_spec; intuition).
        left; apply IHeqs; apply H.
  Qed.

  Lemma Is_variable_in_dec:
    forall x eqs, {Is_variable_in x eqs}+{~Is_variable_in x eqs}.
  Proof.
    intros x eqs.
    apply Bool.reflect_dec with (b := PS.mem x (variables eqs)).
    apply Bool.iff_reflect.
    rewrite PS.mem_spec.
    symmetry.
    apply Is_variable_in_variables.
  Qed.

  Lemma variable_eq_empty:
    forall x eq variables,
      PS.In x (variable_eq variables eq)
      <-> PS.In x (variable_eq PS.empty eq) \/ PS.In x variables.
  Proof.
    split; intro H.
    destruct eq;
      match goal with
      | |- context[ EqApp _ _ _ _ _ ] =>
        generalize ps_adds_spec; intro add_spec
      | _ =>
        generalize PS.add_spec; intro add_spec
      end;
      simpl in *;
        try (apply add_spec in H; destruct H; [try subst i|]);
        try (rewrite add_spec; auto).
        intuition.
    destruct eq eqn:Heq; simpl in *; destruct H;
      match goal with
      | _ : _ = EqApp _ _ _ _ _ |- _ =>
        generalize ps_adds_spec; intro add_spec
      | _ =>
        generalize PS.add_spec; intro add_spec
      end;
      try (apply add_spec in H; destruct H); try apply PS.empty_spec in H;
        try (rewrite ps_adds_spec; auto);
        intuition.
  Qed.

End ISVARIABLE.

Module IsVariableFun
      (Ids    : IDS)
       (Op    : OPERATORS)
       (CESyn : CESYNTAX      Op)
       (Syn   : NLSYNTAX  Ids Op CESyn)
       (Mem   : MEMORIES  Ids Op CESyn Syn)
       (IsD   : ISDEFINED Ids Op CESyn Syn Mem)
       <: ISVARIABLE Ids Op CESyn Syn Mem IsD.
  Include ISVARIABLE Ids Op CESyn Syn Mem IsD.
End IsVariableFun.


Fail Inductive tm :=
| app : tm -> tm -> tm
| abs : (tm -> tm) -> tm.

Module m1.
Inductive tm (V:Type) :=
| app : tm V -> tm V -> tm V
| abs : (V -> tm V) -> tm V.
End m1.

Module m2.

Inductive ty (V:Type) :=
| arr : ty V -> ty V -> ty V
| all : (V -> ty V) -> ty V.

Inductive tm (V W:Type) :=
| app : tm V W -> tm V W -> tm V W
| tapp : tm V W -> ty V -> tm V W
| vt : vl V W -> tm V W
with vl (V W:Type) :=
| lam : ty V -> (W -> tm V W) -> vl V W
| tlam : (V -> tm V W) -> vl V W.
End m2.

From MetaCoq.Template Require Import All.
Require Import String List.
Import ListNotations MonadNotation.
Open Scope string.

Module m3.
  Variables V W : Type.

  Inductive ty :=
  | arr : ty -> ty -> ty
  | all : (V -> ty) -> ty.

  Inductive tm :=
  | app : tm -> tm -> tm
  | tapp : tm -> ty -> tm
  | vt : vl -> tm
  with vl :=
  | lam : ty -> (W -> tm) -> vl
  | tlam : (V -> tm) -> vl.

  Definition Autosubst_map := [(ty, V); (vl, W)].
  Definition Autosubst_sorts := [ty; tm].
End m3.

Definition printInductive (q : qualid): TemplateMonad unit :=
  kn <- tmLocate1 q ;;
  match kn with
  | IndRef ind => (tmQuoteInductive ind.(inductive_mind)) >>= tmPrint
  | _ => tmFail ("not an inductive")
  end.

MetaCoq Run (printInductive "m2.tm").

MetaCoq Run (printInductive "m3.tm").

Module m4.
  (* How would a language with dependent types look? *)
  Parameter V W : Type.

  (* and here we see we need more information from the user about which variable corresponds to which sort since there is no difference between all and dep *)
  Inductive ty :=
  | arr : ty -> ty -> ty
  | all : (V -> ty) -> ty
  | dep : (W -> ty) -> ty.

  Inductive tm :=
  | app : tm -> tm -> tm
  | tapp : tm -> ty -> tm
  | vt : vl -> tm
  with vl :=
  | lam : ty -> (W -> tm) -> vl
  | tlam : (V -> tm) -> vl.

  Parameter X : Type.
  Definition variadic (p: nat) (t:Type) := t.
  Notation " < p , t > " := (variadic p t) (t at next level).
  Inductive tm' :=
  | app' : tm' -> list tm' -> tm'
  | lam' : forall p:nat, ty -> (<p, X> -> tm') -> tm'
  | lam'' (p: nat): ty -> (<p, X> -> tm') -> tm'.

  (* if the user specifies this kind of list it should work.
   We can even check that it's the same variables that appear bound in the constructors. *)
  Definition Autosubst_map :=
    [ (V, ty); (W, vl) ].
  Definition Autosubst_sorts := [ ty; tm ].
End m4.

Module m5.
  (* How would a language with dependent types look? *)
  Parameter V W : Type.

  (* and here we see we need more information from the user about which variable corresponds to which sort since there is no difference between all and dep *)
  Inductive ty :=
  | arr : ty -> ty -> ty
  | all : (V -> ty) -> ty
  with ty2 :=
  | bla : ty2.

  Inductive tm :=
  | app : tm -> tm -> tm
  | tapp : tm -> ty -> tm
  | vt : vl -> tm
  with vl :=
  | lam : ty -> (W -> tm) -> vl
  | tlam : (V -> tm) -> vl.

  (* if the user specifies this kind of list it should work.
   We can even check that it's the same variables that appear bound in the constructors. *)
  Definition Autosubst_map :=
    [ (V, ty); (W, vl) ].
  Definition Autosubst_sorts := [ ty; tm ].
End m5.

Require Import hsig.
MetaCoq Test Quote m5.ty.

Fixpoint chain (actions: list (TemplateMonad unit)) : TemplateMonad unit :=
  match actions with
  | [] => tmReturn tt
  | a :: actions =>
    a;;
    chain actions
  end.

Fixpoint alternate {A:Type} (ms: list (TemplateMonad A)) : TemplateMonad (list A) :=
  match ms with
  | [] => tmReturn []
  | m :: ms =>
    a <- m;;
    as_ <- alternate ms;;
    tmReturn (a :: as_)
  end.

Definition tm_a_map {A B: Type} (f: A -> TemplateMonad B) (ms: list A) : TemplateMonad (list B) :=
  alternate (map f ms).

Definition get_inductives (slist: list Type) : TemplateMonad (list term) :=
  inductives <- tm_a_map (fun ind =>
                            indq <- tmQuote ind;;
                            tmReturn indq) slist;;
  tmReturn inductives.

MetaCoq Run (get_inductives m3.Autosubst_sorts >>= tmPrint).

Definition get_inductive_kernames (slist: list Type) : TemplateMonad (list kername) :=
  refs <- get_inductives slist;;
  kernames <- tm_a_map (fun t: term =>
                        match t return TemplateMonad kername with
                        | tInd {| inductive_mind := inductive_mind; inductive_ind := _ |} _ => tmReturn inductive_mind
                        | _ => tmFail ""
                        end) refs;;
  tmReturn kernames.

Definition flat_map {A B : Type} (f: A -> list B) : list A -> list B
  := fix flat_map (l : list A) : list B := match l with
                                             | [] => []
                                             | x :: t => (f x ++ flat_map t)%list
                                             end.

Definition get_inductive_bodies (slist: list Type) : TemplateMonad _ :=
  kernames <- get_inductive_kernames slist;;
  mutual_bodies <- tm_a_map tmQuoteInductive kernames;;
  let bodies := flat_map ind_bodies mutual_bodies in
  ebodies <- tmEval lazy bodies;;
  tmReturn ebodies.

(* working with inductive entries might be easier. TODO check what Marcel did *)
(*
Definition get_inductive_entries (slist: list Type) : TemplateMonad (list one_inductive_entry) :=
  kernames <- get_inductive_kernames slist;;
  mutual_bodies <- tm_a_map tmQuoteInductive kernames;;
  let mutual_entries := map mind_body_to_entry mutual_bodies in
  let entries := flat_map mind_entry_inds mutual_entries in
  eentries <- tmEval lazy entries;;
  tmReturn eentries.
 *)

MetaCoq Run (get_inductive_bodies m3.Autosubst_sorts >>= tmPrint).

(* MetaCoq Run (get_inductive_bodies [m4.tm'] >>= tmPrint). *)

Fixpoint translate_positions (sname: tId) (t: term) : list Position :=
  match t with
  (* base case since all constructors must end with a reference to their inductive type *)
  | tRel _ => []
  | tProd {| binder_name := nAnon; binder_relevance := _ |} t1 t2 =>
    let pos := match t1 with
               | tRel _ => {| pos_binders := []; pos_head := Atom sname |}
               | _ => bla
               end in
    pos :: (translate_positions sname t2)
  (* should really use error monad here *)
  | _ => []
  end.

Definition translate_constructor (ctor: (string * term) * nat) : Constructor :=
  let '((cname, ctype), _) := ctor in
  let positions := translate_positions ctype in
  {| con_parameters := []; con_name := cname; con_positions := positions |}.

Definition translate_inductive_body (b: one_inductive_body) : (tId * list Constructor) :=
  let ctors := map translate_constructor (ind_ctors b) in
  (ind_name b, ctors).

Definition translate_inductives (slist: list Type) (vlist: list (Type * Type)) : spec.
Admitted.

(* Definition quote_inductive (indref: term) := *)
(*   match indref with *)
(*   | tInd {| inductive_mind := } *)


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config.
From MetaCoq.PCUIC Require Import
  PCUICAst PCUICAstUtils PCUICTyping PCUICSafeLemmata PCUICValidity
  PCUICReduction PCUICEquality PCUICConfluence PCUICUnivSubstitutionConv
  PCUICUnivSubstitutionTyp.

Require Import Equations.Prop.DepElim.

(** We assume normalization of the reduction.
    We state is as well-foundedness of the reduction.
*)

Record normalizing_flags {cf : checker_flags} : Prop :=
  { nor_check_univs :> check_univs }.

Existing Class normalizing_flags.

#[local] Instance default_normalizing :
  @normalizing_flags default_checker_flags.
Proof.
  now constructor.
Qed.

#[local] Instance extraction_normalizing :
  @normalizing_flags extraction_checker_flags.
Proof.
  now constructor.
Qed.

#[local] Instance weakening_config_normalizing {cf1 cf2} :
  config.impl cf2 cf1 -> @normalizing_flags cf1 -> @normalizing_flags cf2.
Proof.
  intros Hcf no.
  destruct cf1, cf2, no; constructor; cbv -[andb] in *.
  subst; simpl in *.
  revert Hcf; cbv [andb].
  repeat match goal with |- context[if ?b then _ else _] => is_var b; destruct b end.
  all: trivial.
Qed.

Class NormalizationIn {cf : checker_flags} {no : normalizing_flags} (Σ : global_env_ext) :=
  normalization_in :
    forall Γ t,
      welltyped Σ Γ t ->
      Acc (cored Σ Γ) t.
Class Normalization {cf : checker_flags} {no : normalizing_flags} :=
  normalization : forall Σ, wf_ext Σ -> NormalizationIn Σ.
#[export] Hint Mode NormalizationIn - - + : typeclass_instances.
#[export] Typeclasses Opaque Normalization.

(** Since we are working with name annotations, reduction is sensitive to names.
    In this section we provide cored' which corresponds to reduction up to
    α-renaming, as well as the necessary lemmata to show it is well-founded and
    can be used instead of the usual reduction as a measure.
*)

Section Alpha.

  Context {cf : checker_flags} {no : normalizing_flags}.
  Context (Σ : global_env_ext) {normalization : NormalizationIn Σ}.

  Notation eqt u v := (∥ upto_names u v ∥).

  Definition cored' Γ u v :=
    exists u' v', cored Σ Γ u' v' /\ eqt u u' /\ eqt v v'.

  Lemma cored_alt :
    forall Γ u v,
      cored Σ Γ u v <~> ∥ Relation.trans_clos (red1 Σ Γ) v u ∥.
  Proof using Type.
    intros Γ u v.
    split.
    - intro h. induction h.
      + constructor. constructor. assumption.
      + destruct IHh as [ih]. constructor.
        eapply Relation.t_trans.
        * eassumption.
        * constructor. assumption.
    - intros [h]. induction h.
      + constructor. assumption.
      + eapply cored_trans'. all: eassumption.
  Qed.

  Local Instance substu_pres_eq : SubstUnivPreserving eq.
  Proof using Type.
    red. intros s u u'.
    unfold R_universe_instance.
    intros f. eapply Forall2_map_inv in f.
    assert (u = u') as ->.
    { induction f; cbn; auto. f_equal; auto.
      now eapply Universe.make_inj in H. }
    reflexivity.
  Qed.

  Lemma cored'_postpone :
    forall Γ u v,
      cored' Γ u v ->
      exists u', cored Σ Γ u' v /\ eqt u u'.
  Proof using Type.
    intros Γ u v [u' [v' [r [[hu] [hv]]]]].
    apply cored_alt in r.
    destruct r as [r].
    induction r in u, v, hu, hv.
    - eapply red1_eq_term_upto_univ_r in r. 10: eassumption.
      all:tc.
      destruct r as [u' [r e]].
      exists u'. split.
      * constructor. assumption.
      * constructor. etransitivity. 1: eauto.
        now symmetry.
    - specialize (IHr1 y v).
      destruct IHr1 as [y' [h1 [e1]]]; auto. reflexivity.
      specialize (IHr2 u y').
      destruct IHr2 as [u' [h2 ?]]; auto. now symmetry.
      exists u'. split.
      + eapply cored_trans'. all: eauto.
      + assumption.
  Qed.

  Corollary cored_upto :
    forall Γ u v v',
      cored Σ Γ u v ->
      eqt v v' ->
      exists u', cored Σ Γ u' v' /\ eqt u u'.
  Proof using Type.
    intros Γ u v v' h e.
    eapply cored'_postpone.
    exists u, v. intuition eauto.
    - constructor. reflexivity.
    - destruct e; constructor; now symmetry.
  Qed.

  Lemma Acc_impl :
    forall A (R R' : A -> A -> Prop),
      (forall x y, R x y -> R' x y) ->
      forall x, Acc R' x -> Acc R x.
  Proof using Type.
    intros A R R' h x hx.
    induction hx as [x h1 h2].
    constructor. intros y hy.
    eapply h2. eapply h. assumption.
  Qed.

  Lemma Acc_cored_cored' :
    forall Γ u,
      Acc (cored Σ Γ) u ->
      forall u', eqt u u' -> Acc (cored' Γ) u'.
  Proof using Type.
    intros Γ u h. induction h as [u h ih].
    intros u' e. constructor. intros v [v' [u'' [r [[e1] [e2]]]]].
    assert (ee : eqt u'' u).
    { destruct e. constructor. symmetry; etransitivity; tea. }
    eapply cored_upto in r as hh. 2: exact ee.
    destruct hh as [v'' [r' [e']]].
    eapply ih.
    - eassumption.
    - destruct ee. constructor. symmetry; etransitivity; eassumption.
  Qed.

  Lemma normalization_upto :
    forall Γ u,
      welltyped Σ Γ u ->
      Acc (cored' Γ) u.
  Proof using normalization.
    intros Γ u h.
    apply normalization in h.
    eapply Acc_cored_cored'.
    - eassumption.
    - constructor; reflexivity.
  Qed.

  (* TODO Maybe switch to eq_context *)
  Lemma cored_eq_context_upto_names :
    forall Γ Δ u v,
      eq_context_upto_names Γ Δ ->
      cored Σ Γ u v ->
      cored Σ Δ u v.
  Proof using Type.
    intros Γ Δ u v e h.
    apply cored_alt in h as [h].
    induction h in Δ, e |- *.
    - constructor. eapply red1_eq_context_upto_names. all: eauto.
    - eapply cored_trans'.
      + eapply IHh2. assumption.
      + eapply IHh1. assumption.
  Qed.

  Lemma cored_eq_term_upto :
    forall Σ' Re Rle Γ u v u',
      RelationClasses.Reflexive Re ->
      SubstUnivPreserving Re ->
      RelationClasses.Reflexive Rle ->
      SubstUnivPreserving Rle ->
      RelationClasses.Symmetric Re ->
      RelationClasses.Transitive Re ->
      RelationClasses.Transitive Rle ->
      RelationClasses.subrelation Re Rle ->
      eq_term_upto_univ Σ' Re Rle u u' ->
      cored Σ Γ v u ->
      exists v', cored Σ Γ v' u' /\ ∥ eq_term_upto_univ Σ' Re Rle v v' ∥.
  Proof using Type.
    intros Σ' Re Rle Γ u v u' X X0 X1 X2 X3 X4 X5 X6 e h.
    apply cored_alt in h as [h].
    induction h in u', e |- *.
    - eapply red1_eq_term_upto_univ_l in r. 9: eauto. all: auto.
      destruct r as [? [? ?]].
      eexists. split.
      + constructor. eassumption.
      + constructor. assumption.
    - specialize (IHh1 _ e). destruct IHh1 as [y' [r1 [e1]]].
      specialize (IHh2 _ e1). destruct IHh2 as [z' [r2 [e2]]].
      exists z'. split.
      + eapply cored_trans'. all: eassumption.
      + constructor. assumption.
  Qed.

  Lemma cored_eq_context_upto :
    forall Σ' Re Γ Δ u v,
      RelationClasses.Reflexive Re ->
      RelationClasses.Symmetric Re ->
      RelationClasses.Transitive Re ->
      SubstUnivPreserving Re ->
      eq_context_upto Σ' Re Re Γ Δ ->
      cored Σ Γ u v ->
      exists u', cored Σ Δ u' v /\ ∥ eq_term_upto_univ Σ' Re Re u u' ∥.
  Proof using Type.
    intros Σ' Re Γ Δ u v hRe1 hRe2 hRe3 hRe4 e h.
    apply cored_alt in h as [h].
    induction h.
    - eapply red1_eq_context_upto_l in r. all: eauto. 2:tc.
      destruct r as [? [? ?]].
      eexists. split.
      + constructor. eassumption.
      + constructor. assumption.
    - destruct IHh1 as [x' [r1 [e1]]].
      destruct IHh2 as [y' [r2 [e2]]].
      eapply cored_eq_term_upto in r2. 10: exact e1. all: auto.
      2:tc.
      destruct r2 as [y'' [r2' [e2']]].
      exists y''. split.
      * eapply cored_trans'. all: eassumption.
      * constructor. eapply eq_term_upto_univ_trans. all: eauto.
  Qed.

  (* Lemma eq_context_upto_nlctx :
    forall Γ,
      eq_context_upto Σ eq eq Γ (nlctx Γ).
  Proof.
    intros Γ.
    induction Γ as [| [na [b|] A] Γ ih ].
    - constructor.
    - simpl. constructor; simpl; try apply binder_anonymize; tas.
      + constructor; tas; auto. eapply eq_term_upto_univ_tm_nl.
        all: auto.
        eapply eq_term_upto_univ_tm_nl.
        all: auto.
    - simpl. constructor; auto. constructor.
      + apply binder_anonymize.
      + simpl. eapply eq_term_upto_univ_tm_nl.
        all: auto.
  Qed.

  Lemma cored_cored'_nl :
    forall Γ u v,
      cored Σ Γ u v ->
      cored' (nlctx Γ) (nl u) (nl v).
  Proof.
    intros Γ u v h.
    eapply cored_eq_context_upto in h.
    6: eapply eq_context_upto_nlctx.
    all: auto.
    - destruct h as [u' [r [e]]].
      eexists _, _. intuition eauto.
      + constructor. eapply eq_term_trans.
        * eapply eq_term_sym. eapply eq_term_tm_nl.
        * eapply eq_term_upto_univ_impl; eauto. all:typeclasses eauto.
      + constructor. eapply eq_term_sym. eapply eq_term_tm_nl.
    - intros ? ? ? []. auto.
    - intros ? ? ? r. apply Forall2_eq in r. apply map_inj in r.
      + subst. reflexivity.
      + apply Universe.make_inj.
  Qed. *)

  Lemma cored_cored' :
    forall Γ u v,
      cored Σ Γ u v ->
      cored' Γ u v.
  Proof using Type.
    intros Γ u v h.
    exists u, v. intuition eauto.
    - constructor. reflexivity.
    - constructor. reflexivity.
  Qed.

End Alpha.


(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

From Coq Require Import Arith List.
From CoLoR Require Import more_list list_sort term_spec ac cf_eq_ac.

Module Type S.

Declare Module Import Cf_eq_ac : cf_eq_ac.S.

Import Cf_eq_ac.Ac Sort EqTh EqTh.T F LPermut.

Record partly_solved_term : Type :=
  mk_pst
  {
    head_symb : symbol;
    new_var : variable;
    closed_term : term
  }.

Record matching_problem : Type :=
  mk_pb
  {
    existential_vars : list variable;
    unsolved_part : list (term * term);
    solved_part : substitution;
    partly_solved_part : list (variable * partly_solved_term)
  }.

Definition is_rough_sol pb sigma :=
 (forall t1 t2, In (t1,t2) pb.(unsolved_part) -> apply_cf_subst sigma t1 = t2) /\
 (forall v, match find X.eq_bool v pb.(partly_solved_part) with
            | None => True
            | Some pst =>
              let l := (apply_cf_subst sigma (Var pst.(new_var))) :: pst.(closed_term) :: nil in
              apply_cf_subst sigma (Var v) =
             Term pst.(head_symb) (quicksort (flatten pst.(head_symb) l))
             end) /\
 (forall v, match find X.eq_bool v pb.(solved_part) with
            | None => True
            | Some t => apply_cf_subst sigma (Var v) = t
            end).

Definition is_sol pb sigma :=
  exists sigma', is_rough_sol pb sigma' /\
                  (forall v, In v (existential_vars pb) \/
                             apply_cf_subst sigma (Var v) = apply_cf_subst sigma' (Var v)).

Fixpoint occurs_in_term (v : variable) (t : term) {struct t} : Prop :=
  match t with
  | Var v' => v=v'
  | Term _ l =>
      let occurs_in_term_list :=
       (fix occurs_in_term_list v (l : list _) {struct l} : Prop :=
        match l with
        | nil => False
        | h :: tl => (occurs_in_term v h) \/ (occurs_in_term_list v tl)
        end) in
        occurs_in_term_list v l
    end.

Fixpoint occurs_in_term_list (v : variable) (l : list term) {struct l} : Prop :=
  match l with
  | nil => False
  | cons h tl => (occurs_in_term v h) \/ (occurs_in_term_list v tl)
  end.

Definition occurs_in_pb v pb :=
 (occurs_in_term_list v (map (fun p => match p with | (t1,t2) => t1 end) pb.(unsolved_part))) \/
 (match find X.eq_bool v pb.(partly_solved_part) with
   | None => False | Some _ => True end) \/
 (match find X.eq_bool v pb.(solved_part) with
   | None => False | Some _ => True end).

Parameter fresh_var : matching_problem -> variable.
Parameter fresh_var_spec : forall pb, ~(occurs_in_pb (fresh_var pb) pb).

Definition ac_elementary_solve_term_term_term
pb f g lg list_of_terms l' list_of_equations : list matching_problem :=
(* t1 = Term f (cons (Term g lg) list_of_terms as l); t2 = Term _ l' *)
  map_without_repetition T.eq_bool
  (fun t =>
    match t with
    | Term h _ =>
      if F.Symb.eq_bool g h
      then
         match remove T.eq_bool t l' with
           | None => None
           | Some rmv =>
              let t1' := build f list_of_terms in
              let t2' := build f rmv in
                Some
                  (mk_pb  (existential_vars pb)
                         (cons ((Term g lg),t) (cons (t1',t2') list_of_equations))
                         (solved_part pb)
                         (partly_solved_part pb))
          end
       else None
    | Var _ => None
    end)
    l'.

Definition ac_elementary_solve_term_var_with_val_term
pb f x_val list_of_terms l' list_of_equations : list matching_problem :=
(* t1 = Term f (cons (Var x) list_of_terms as l); t2 = Term _ l' *)
  match remove T.eq_bool x_val l' with
  | None =>
     match x_val with
     | Var _ => nil
     | Term g ll =>
         if F.Symb.eq_bool f g
         then
            match remove_list ll l' with
            | Some rmv =>
               if le_gt_dec (length list_of_terms) (length rmv)
               then
                   let t1' := build f list_of_terms in
                   let t2' := build f rmv in
                   let new_pb :=
                   mk_pb (existential_vars pb)
                   (cons (t1',t2') list_of_equations)
                   (solved_part pb)
                   (partly_solved_part pb) in
                   cons new_pb nil
                 else nil
            | None => nil
            end
         else nil
     end
  | Some rmv =>
    let t1' := build f list_of_terms in
    let t2' := build f rmv in
    let new_pb :=
      mk_pb (existential_vars pb)
      ((t1',t2') :: list_of_equations)
            (solved_part pb)
            (partly_solved_part pb) in
      new_pb :: nil
  end.

Definition ac_elementary_solve_term_var_with_part_val_term
pb f x_part_val list_of_terms l' list_of_equations : list matching_problem :=
(* t1 = Term f (cons (Var x) list_of_terms as l); t2 = Term _ l' *)
  if (F.Symb.eq_bool f (head_symb x_part_val))
  then
      match remove T.eq_bool (closed_term x_part_val) l' with
      | None => nil
      | Some rmv =>
        let t1' := build f (cons (Var (new_var x_part_val)) list_of_terms) in
        let t2' := build f rmv in
        let new_pb :=
          mk_pb  (existential_vars pb)
                ((t1',t2') :: list_of_equations)
                (solved_part pb)
                (partly_solved_part pb) in
         new_pb :: nil
     end
  else
      map_without_repetition T.eq_bool
       (fun t =>
          match t with
          | Term h l''' =>
              if F.Symb.eq_bool h (head_symb x_part_val)
              then
                  match remove T.eq_bool (closed_term x_part_val) l''' with
                  | None => None
                  | Some rmv =>
                    match remove T.eq_bool t l' with
                    | None => None
                    | Some rmv2 =>
                      let y := new_var x_part_val in
                      let y_val := build h rmv in
                      let t1' := build f list_of_terms in
                      let t2' := build f rmv2 in
                      let new_pb :=
                        mk_pb (existential_vars pb)
                              ((Var y, y_val) :: (t1',t2') :: list_of_equations)
                              (solved_part pb)
                              (partly_solved_part pb) in
                      Some new_pb
                    end
                  end
              else None
           | Var _ => None
           end)
         l'.

Definition ac_elementary_solve_term_var_without_val_term
pb f x list_of_terms l' list_of_equations : list matching_problem :=
(* t1 = Term f ((Var x) :: list_of_terms as l); t2 = Term _ l' *)
  map12_without_repetition T.eq_bool
  (fun t =>
    match remove T.eq_bool t l' with
    | None => (None, None)
    | Some rmv =>
      let l'_without_t := rmv in
      let t1' := build f list_of_terms in
      let t2' := build f l'_without_t in
      let new_pb :=
        mk_pb (existential_vars pb)
              ((t1', t2') :: list_of_equations)
              ((x, t) :: (solved_part pb))
              (partly_solved_part pb) in
       if le_gt_dec (length l') ((length list_of_terms) + 1)
       then (Some new_pb, None)
       else
         let y := fresh_var pb in
         let t1'' := build f (Var y :: list_of_terms) in
         let new_pb' :=
           mk_pb (y :: existential_vars pb)
                 ((t1'', t2') :: list_of_equations)
                 (solved_part pb)
                 ((x, mk_pst f y t) :: (partly_solved_part pb)) in
          (Some new_pb, Some new_pb')
    end)
    l'.

Definition ac_elementary_solve pb t1 t2 list_of_equations :=
  match t1, t2 with
  | (Term f (s :: list_of_terms as l)), (Term _ l') =>
    match s with
    | Term g lg =>
        ac_elementary_solve_term_term_term
          pb f g lg list_of_terms l' list_of_equations
    | Var x =>
      match find X.eq_bool x (solved_part pb) with
      | Some x_val =>
         ac_elementary_solve_term_var_with_val_term
           pb f x_val list_of_terms l' list_of_equations
      | None =>
        match find X.eq_bool x (partly_solved_part pb) with
        | Some x_part_val =>
           ac_elementary_solve_term_var_with_part_val_term
             pb f x_part_val list_of_terms l' list_of_equations
        | None =>
           ac_elementary_solve_term_var_without_val_term
             pb f x list_of_terms l' list_of_equations
        end
      end
    end
  | (Term _ nil), (Term _ _) =>
     let new_pb :=
       mk_pb (existential_vars pb)
             list_of_equations
             (solved_part pb)
             (partly_solved_part pb) in
       new_pb :: nil
  | _, _ => nil
  end.

Definition solve pb : list matching_problem :=
  match unsolved_part pb with
  | (tt1,tt2 as e) :: list_of_equations =>
    match tt1, tt2 with
    | Var x, _ =>
      match find X.eq_bool x (solved_part pb) with
      | Some x_val =>
        if T.eq_bool x_val tt2
        then
          let new_pb :=
            mk_pb (existential_vars pb)
            list_of_equations (solved_part pb) (partly_solved_part pb) in
          new_pb :: nil
        else nil
      | None =>
        match find X.eq_bool x (partly_solved_part pb) with
        | Some x_part_val =>
          match tt2 with
          | Var _ => nil
          | Term f2 l2 =>
            if F.Symb.eq_bool (head_symb x_part_val) f2
            then
              let y := new_var x_part_val in
              match remove T.eq_bool (closed_term x_part_val) l2 with
              | Some rmv =>
                let y_val := build f2 rmv in
                let new_pb :=
                  mk_pb (existential_vars pb)
                        ((Var y, y_val) :: list_of_equations)
                        (solved_part pb) (partly_solved_part pb) in
                  new_pb :: nil
              | None => nil
              end
            else nil
         end
       | None =>
           let new_pb :=
             mk_pb (existential_vars pb)
             list_of_equations ((x, tt2) :: (solved_part pb)) (partly_solved_part pb) in
           new_pb :: nil
       end
     end
    | Term f1 l1, Term f2 l2 =>
        if F.Symb.eq_bool f1 f2
        then
            match arity f1 with
            | Free _ =>
              match fold_left2
                (fun current_list_of_eqs t1 t2 => (t1,t2) :: current_list_of_eqs)
                list_of_equations l1 l2 with
              | Some new_list_of_equations =>
                let new_pb :=
                  mk_pb (existential_vars pb)
                  new_list_of_equations (solved_part pb) (partly_solved_part pb) in
                new_pb :: nil
              | None => nil
              end
            | AC =>
              if le_gt_dec (length l1) (length l2)
              then ac_elementary_solve pb tt1 tt2 list_of_equations
              else nil
            | C =>
              match l1, l2 with
              | (s1 :: s2 :: nil), (t1 :: t2 :: nil) =>
                let new_pb1 :=
                  mk_pb (existential_vars pb)
                  ((s1,t1) :: (s2,t2) :: list_of_equations)
                        (solved_part pb) (partly_solved_part pb) in
               let new_pb2 :=
                  mk_pb (existential_vars pb)
                  ((s1,t2) :: (s2,t1) :: list_of_equations)
                        (solved_part pb) (partly_solved_part pb) in
                 new_pb1 :: new_pb2 :: nil
                | _, _ => nil
              end
            end
        else nil
    | _, _ => nil
    end
  | nil => nil
end.

Fixpoint well_sorted_partly_solved_part (l :  list (variable * partly_solved_term)) : Prop :=
 match l with
 | nil => True
 | (v,p) :: tl =>
    v <> new_var p /\
    (forall v', 1 <= nb_occ X.eq_bool v' tl -> v' <> new_var p) /\
    well_sorted_partly_solved_part tl
end.

Definition well_formed_pb pb :=
(forall t1 t2, In (t1,t2) pb.(unsolved_part) ->
                   well_formed_cf t1 /\ well_formed_cf t2) /\
(forall v, match (find X.eq_bool v pb.(solved_part)) with
  | None => True
  | Some t => well_formed_cf t
  end) /\
(forall v, match (find X.eq_bool v pb.(partly_solved_part)) with
  | None => True
  | Some pst =>
      match arity pst.(head_symb) with
      | AC => well_formed_cf pst.(closed_term) /\
              match pst.(closed_term) with
              | Var _ => True
              | Term f _ => pst.(head_symb)<>f
              end
      | _ => False
      end
  end) /\
(forall v,
  nb_occ X.eq_bool v (solved_part pb) + nb_occ X.eq_bool v (partly_solved_part pb) <= 1) /\
well_sorted_partly_solved_part (partly_solved_part pb) /\
(forall v p,
  find X.eq_bool v (partly_solved_part pb) = Some p -> occurs_in_pb (new_var p) pb).

Definition is_well_formed_sol pb sigma :=
 (exists sigma',  is_rough_sol pb sigma' /\
                  (forall v, In v (existential_vars pb) \/
                      apply_cf_subst sigma (Var v) = apply_cf_subst sigma' (Var v)) /\
                         (well_formed_cf_subst sigma')).

Parameter list_permut_occurs_in_term_list :
  forall v l1 l2, permut l1 l2 -> occurs_in_term_list v l1 ->
  occurs_in_term_list v l2.

Parameter add_new_var_to_subst :
  forall t1 v t2 sigma, ~occurs_in_term v t1 ->
  	  apply_cf_subst sigma t1 = apply_cf_subst ((v,t2) ::  sigma) t1.

Parameter add_new_var_to_rough_sol :
  forall pb sigma t, well_formed_pb pb -> is_rough_sol pb sigma ->
  (is_rough_sol pb ((fresh_var pb, t) :: sigma)).

End S.

Module Make (Cf_eq_ac1 : cf_eq_ac.S) : S with Module Cf_eq_ac := Cf_eq_ac1.

Module Cf_eq_ac := Cf_eq_ac1.
Import Cf_eq_ac1 Ac EqTh T F X Sort LPermut.

Record partly_solved_term : Type :=
  mk_pst
  {
    head_symb : symbol;
    new_var : variable;
    closed_term : term
  }.

Record matching_problem : Type :=
  mk_pb
  {
    existential_vars : list variable;
    unsolved_part : list (term * term);
    solved_part : substitution;
    partly_solved_part : list (variable * partly_solved_term)
  }.

Definition is_rough_sol pb sigma :=
 (forall t1 t2, In (t1,t2) pb.(unsolved_part) -> apply_cf_subst sigma t1 = t2) /\
 (forall v, match find X.eq_bool v pb.(partly_solved_part) with
            | None => True
            | Some pst =>
              let l := (apply_cf_subst sigma (Var pst.(new_var))) :: pst.(closed_term) :: nil in
              apply_cf_subst sigma (Var v) =
             Term pst.(head_symb) (quicksort (flatten pst.(head_symb) l))
             end) /\
 (forall v, match find X.eq_bool v pb.(solved_part) with
            | None => True
            | Some t => apply_cf_subst sigma (Var v) = t
            end).

Definition is_sol pb sigma :=
  exists sigma', is_rough_sol pb sigma' /\
                  (forall v, In v (existential_vars pb) \/
                             apply_cf_subst sigma (Var v) = apply_cf_subst sigma' (Var v)).

Fixpoint occurs_in_term (v : variable) (t : term) {struct t} : Prop :=
  match t with
  | Var v' => v=v'
  | Term _ l =>
      let occurs_in_term_list :=
       (fix occurs_in_term_list v (l : list _) {struct l} : Prop :=
        match l with
        | nil => False
        | h :: tl => (occurs_in_term v h) \/ (occurs_in_term_list v tl)
        end) in
        occurs_in_term_list v l
    end.

Fixpoint occurs_in_term_list (v : variable) (l : list term) {struct l} : Prop :=
  match l with
  | nil => False
  | cons h tl => (occurs_in_term v h) \/ (occurs_in_term_list v tl)
  end.

Definition occurs_in_pb v pb :=
 (occurs_in_term_list v (map (fun p => match p with | (t1,t2) => t1 end) pb.(unsolved_part))) \/
 (match find X.eq_bool v pb.(partly_solved_part) with
   | None => False | Some _ => True end) \/
 (match find X.eq_bool v pb.(solved_part) with
   | None => False | Some _ => True end).

Parameter fresh_var : matching_problem -> variable.
Parameter fresh_var_spec : forall pb, ~(occurs_in_pb (fresh_var pb) pb).

Definition ac_elementary_solve_term_term_term
pb f g lg list_of_terms l' list_of_equations : list matching_problem :=
(* t1 = Term f (cons (Term g lg) list_of_terms as l); t2 = Term _ l' *)
  map_without_repetition T.eq_bool
  (fun t =>
    match t with
    | Term h _ =>
      if F.Symb.eq_bool g h
      then
         match remove T.eq_bool t l' with
           | None => None
           | Some rmv =>
              let t1' := build f list_of_terms in
              let t2' := build f rmv in
                Some
                  (mk_pb  (existential_vars pb)
                         (cons ((Term g lg),t) (cons (t1',t2') list_of_equations))
                         (solved_part pb)
                         (partly_solved_part pb))
          end
       else None
    | Var _ => None
    end)
    l'.

Definition ac_elementary_solve_term_var_with_val_term
pb f x_val list_of_terms l' list_of_equations : list matching_problem :=
(* t1 = Term f (cons (Var x) list_of_terms as l); t2 = Term _ l' *)
  match remove T.eq_bool x_val l' with
  | None =>
     match x_val with
     | Var _ => nil
     | Term g ll =>
         if F.Symb.eq_bool f g
         then
            match remove_list ll l' with
            | Some rmv =>
               if le_gt_dec (length list_of_terms) (length rmv)
               then
                   let t1' := build f list_of_terms in
                   let t2' := build f rmv in
                   let new_pb :=
                   mk_pb (existential_vars pb)
                   (cons (t1',t2') list_of_equations)
                   (solved_part pb)
                   (partly_solved_part pb) in
                   cons new_pb nil
                 else nil
            | None => nil
            end
         else nil
     end
  | Some rmv =>
    let t1' := build f list_of_terms in
    let t2' := build f rmv in
    let new_pb :=
      mk_pb (existential_vars pb)
      ((t1',t2') :: list_of_equations)
            (solved_part pb)
            (partly_solved_part pb) in
      new_pb :: nil
  end.

Definition ac_elementary_solve_term_var_with_part_val_term
pb f x_part_val list_of_terms l' list_of_equations : list matching_problem :=
(* t1 = Term f (cons (Var x) list_of_terms as l); t2 = Term _ l' *)
  if (F.Symb.eq_bool f (head_symb x_part_val))
  then
      match remove T.eq_bool (closed_term x_part_val) l' with
      | None => nil
      | Some rmv =>
        let t1' := build f (cons (Var (new_var x_part_val)) list_of_terms) in
        let t2' := build f rmv in
        let new_pb :=
          mk_pb  (existential_vars pb)
                ((t1',t2') :: list_of_equations)
                (solved_part pb)
                (partly_solved_part pb) in
         new_pb :: nil
     end
  else
      map_without_repetition T.eq_bool
       (fun t =>
          match t with
          | Term h l''' =>
              if F.Symb.eq_bool h (head_symb x_part_val)
              then
                  match remove T.eq_bool (closed_term x_part_val) l''' with
                  | None => None
                  | Some rmv =>
                    match remove T.eq_bool t l' with
                    | None => None
                    | Some rmv2 =>
                      let y := new_var x_part_val in
                      let y_val := build h rmv in
                      let t1' := build f list_of_terms in
                      let t2' := build f rmv2 in
                      let new_pb :=
                        mk_pb (existential_vars pb)
                              ((Var y, y_val) :: (t1',t2') :: list_of_equations)
                              (solved_part pb)
                              (partly_solved_part pb) in
                      Some new_pb
                    end
                  end
              else None
           | Var _ => None
           end)
         l'.

Definition ac_elementary_solve_term_var_without_val_term
pb f x list_of_terms l' list_of_equations : list matching_problem :=
(* t1 = Term f ((Var x) :: list_of_terms as l); t2 = Term _ l' *)
  map12_without_repetition T.eq_bool
  (fun t =>
    match remove T.eq_bool t l' with
    | None => (None, None)
    | Some rmv =>
      let l'_without_t := rmv in
      let t1' := build f list_of_terms in
      let t2' := build f l'_without_t in
      let new_pb :=
        mk_pb (existential_vars pb)
              ((t1', t2') :: list_of_equations)
              ((x, t) :: (solved_part pb))
              (partly_solved_part pb) in
       if le_gt_dec (length l') ((length list_of_terms) + 1)
       then (Some new_pb, None)
       else
         let y := fresh_var pb in
         let t1'' := build f (Var y :: list_of_terms) in
         let new_pb' :=
           mk_pb (y :: existential_vars pb)
                 ((t1'', t2') :: list_of_equations)
                 (solved_part pb)
                 ((x, mk_pst f y t) :: (partly_solved_part pb)) in
          (Some new_pb, Some new_pb')
    end)
    l'.

Definition ac_elementary_solve pb t1 t2 list_of_equations :=
  match t1, t2 with
  | (Term f (s :: list_of_terms as l)), (Term _ l') =>
    match s with
    | Term g lg =>
        ac_elementary_solve_term_term_term
          pb f g lg list_of_terms l' list_of_equations
    | Var x =>
      match find X.eq_bool x (solved_part pb) with
      | Some x_val =>
         ac_elementary_solve_term_var_with_val_term
           pb f x_val list_of_terms l' list_of_equations
      | None =>
        match find X.eq_bool x (partly_solved_part pb) with
        | Some x_part_val =>
           ac_elementary_solve_term_var_with_part_val_term
             pb f x_part_val list_of_terms l' list_of_equations
        | None =>
           ac_elementary_solve_term_var_without_val_term
             pb f x list_of_terms l' list_of_equations
        end
      end
    end
  | (Term _ nil), (Term _ _) =>
     let new_pb :=
       mk_pb (existential_vars pb)
             list_of_equations
             (solved_part pb)
             (partly_solved_part pb) in
       new_pb :: nil
  | _, _ => nil
  end.

Definition solve pb : list matching_problem :=
  match unsolved_part pb with
  | (tt1,tt2 as e) :: list_of_equations =>
    match tt1, tt2 with
    | Var x, _ =>
      match find X.eq_bool x (solved_part pb) with
      | Some x_val =>
        if T.eq_bool x_val tt2
        then
          let new_pb :=
            mk_pb (existential_vars pb)
            list_of_equations (solved_part pb) (partly_solved_part pb) in
          new_pb :: nil
        else nil
      | None =>
        match find X.eq_bool x (partly_solved_part pb) with
        | Some x_part_val =>
          match tt2 with
          | Var _ => nil
          | Term f2 l2 =>
            if F.Symb.eq_bool (head_symb x_part_val) f2
            then
              let y := new_var x_part_val in
              match remove T.eq_bool (closed_term x_part_val) l2 with
              | Some rmv =>
                let y_val := build f2 rmv in
                let new_pb :=
                  mk_pb (existential_vars pb)
                        ((Var y, y_val) :: list_of_equations)
                        (solved_part pb) (partly_solved_part pb) in
                  new_pb :: nil
              | None => nil
              end
            else nil
         end
       | None =>
           let new_pb :=
             mk_pb (existential_vars pb)
             list_of_equations ((x, tt2) :: (solved_part pb)) (partly_solved_part pb) in
           new_pb :: nil
       end
     end
    | Term f1 l1, Term f2 l2 =>
        if F.Symb.eq_bool f1 f2
        then
            match arity f1 with
            | Free _ =>
              match fold_left2
                (fun current_list_of_eqs t1 t2 => (t1,t2) :: current_list_of_eqs)
                list_of_equations l1 l2 with
              | Some new_list_of_equations =>
                let new_pb :=
                  mk_pb (existential_vars pb)
                  new_list_of_equations (solved_part pb) (partly_solved_part pb) in
                new_pb :: nil
              | None => nil
              end
            | AC =>
              if le_gt_dec (length l1) (length l2)
              then ac_elementary_solve pb tt1 tt2 list_of_equations
              else nil
            | C =>
              match l1, l2 with
              | (s1 :: s2 :: nil), (t1 :: t2 :: nil) =>
                let new_pb1 :=
                  mk_pb (existential_vars pb)
                  ((s1,t1) :: (s2,t2) :: list_of_equations)
                        (solved_part pb) (partly_solved_part pb) in
               let new_pb2 :=
                  mk_pb (existential_vars pb)
                  ((s1,t2) :: (s2,t1) :: list_of_equations)
                        (solved_part pb) (partly_solved_part pb) in
                 new_pb1 :: new_pb2 :: nil
                | _, _ => nil
              end
            end
        else nil
    | _, _ => nil
    end
  | nil => nil
end.

Fixpoint well_sorted_partly_solved_part (l :  list (variable * partly_solved_term)) : Prop :=
 match l with
 | nil => True
 | (v,p) :: tl =>
    v <> new_var p /\
    (forall v', 1 <= nb_occ X.eq_bool v' tl -> v' <> new_var p) /\
    well_sorted_partly_solved_part tl
end.

Definition well_formed_pb pb :=
(forall t1 t2, In (t1,t2) pb.(unsolved_part) ->
                   well_formed_cf t1 /\ well_formed_cf t2) /\
(forall v, match (find X.eq_bool v pb.(solved_part)) with
  | None => True
  | Some t => well_formed_cf t
  end) /\
(forall v, match (find X.eq_bool v pb.(partly_solved_part)) with
  | None => True
  | Some pst =>
      match arity pst.(head_symb) with
      | AC => well_formed_cf pst.(closed_term) /\
              match pst.(closed_term) with
              | Var _ => True
              | Term f _ => pst.(head_symb)<>f
              end
      | _ => False
      end
  end) /\
(forall v,
  nb_occ X.eq_bool v (solved_part pb) + nb_occ X.eq_bool v (partly_solved_part pb) <= 1) /\
well_sorted_partly_solved_part (partly_solved_part pb) /\
(forall v p,
  find X.eq_bool v (partly_solved_part pb) = Some p -> occurs_in_pb (new_var p) pb).

Lemma list_permut_occurs_in_term_list :
  forall v l1 l2, permut l1 l2 -> occurs_in_term_list v l1 ->
  occurs_in_term_list v l2.
Proof.
intros v;
cut (forall l l', occurs_in_term_list v l' -> occurs_in_term_list v (l ++ l')).
intros H l1; induction l1.
contradiction.
intros l2 P O.
assert (a_in_l2 : In a l2).
rewrite <- (list_permut.in_permut_in P); left; trivial.
destruct (In_split _ _ a_in_l2) as [l2' [l2'' H']]; subst l2.
elim O; clear O; intro O.
apply H; left; trivial.
rewrite <- permut_cons_inside in P.
generalize (IHl1 (l2' ++ l2'') P O).
clear l1 IHl1 P O; induction l2'.
intro; right; trivial.
simpl; intro O; destruct O as [ O | O ].
left; trivial.
right; apply IHl2'; trivial; apply in_or_app; right; left; trivial.
reflexivity.
intro l; induction l; trivial; right; apply IHl; trivial.
Qed.

Lemma add_new_var_to_subst :
forall t1 v t2 sigma, ~occurs_in_term v t1 ->
      apply_cf_subst sigma t1 = apply_cf_subst ((v,t2) ::  sigma) t1.
Proof.
intro t1; pattern t1; apply term_rec3; clear t1.
intros v v0 t2 sigma O; simpl; (* rewrite find_add_spec; *)
generalize (X.eq_bool_ok v v0); case (X.eq_bool v v0); [intro v_eq_v0; subst v | intros _].
apply False_rect; apply O; unfold occurs_in_term; trivial.
reflexivity.
intros f l IH v t2 sigma O; simpl.
assert (H : map (apply_cf_subst sigma) l = map (apply_cf_subst ((v,t2) :: sigma)) l).
induction l as [ | t l].
trivial.
simpl map; rewrite <- (IH t).
rewrite <- IHl.
reflexivity.
intros; apply IH; [right | idtac]; assumption.
intro v_in_l; apply O; right; assumption.
left; reflexivity.
intro v_in_t; apply O; left; assumption.
rewrite H; reflexivity.
Qed.

Lemma add_new_var_to_rough_sol :
  forall pb sigma t, well_formed_pb pb -> is_rough_sol pb sigma ->
  (is_rough_sol pb ((fresh_var pb, t) :: sigma)).
Proof.
intros pb sigma t ; generalize (fresh_var_spec pb);
unfold occurs_in_pb, is_rough_sol;
intros O w S'; elim S'; clear S';
intros S1 S2; elim S2; clear S2;
intros S2 S3; split.
induction pb.(unsolved_part).
contradiction.
destruct a; intros t2 t3 I; elim I; clear I; intro I.
inversion I.
rewrite <- (add_new_var_to_subst t2 (fresh_var pb) t).
apply S1; left; trivial.
unfold not; intro O'; apply O.
left; left; subst t2; trivial.
apply IHl; trivial.
intro O'; apply O; destruct O' as [O' | O']; [ left | idtac ]; right; trivial.
intros; apply S1; right; trivial.
destruct w as [ _ [_ [_ [_ [_ w]]]]]; split.
intro v; generalize (S2 v); case_eq (find X.eq_bool v (partly_solved_part pb)).
intros p F; repeat rewrite <- (add_new_var_to_subst); trivial.
intro O'; apply O; simpl in O'; rewrite O'; apply (w v p F).
intro O'; apply O; simpl in O'; rewrite O'; right; left; rewrite F; trivial.
trivial.
intro v; generalize (S3 v); case_eq (find X.eq_bool v (solved_part pb)).
intros t0 F; simpl; generalize (X.eq_bool_ok v (fresh_var pb)); case (X.eq_bool v (fresh_var pb)); [intro v_eq_fresh_var | intro v_diff_fresh_var].
apply False_rect; apply O.
do 2 right; subst v; rewrite F; exact I.
intro; assumption.
intros _ _; exact I.
Qed.

Definition is_well_formed_sol pb sigma :=
 (exists sigma',  is_rough_sol pb sigma' /\
                  (forall v, In v (existential_vars pb) \/
                      apply_cf_subst sigma (Var v) = apply_cf_subst sigma' (Var v)) /\
                         (well_formed_cf_subst sigma')).

End Make.


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 A B Aprime Bprime M1 Bprimeprime M2 Aprimeprime I : Universe, ((wd_ M1 I /\ (wd_ Bprimeprime M1 /\ (wd_ Aprime Bprime /\ (wd_ Aprime Bprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ Bprimeprime I /\ (wd_ Bprime Bprimeprime /\ (wd_ B Bprimeprime /\ (wd_ Bprime Aprimeprime /\ (wd_ A B /\ (wd_ B M1 /\ (wd_ A Aprime /\ (wd_ A Bprime /\ (wd_ B Aprime /\ (wd_ B Bprime /\ (col_ Bprimeprime Aprime Bprime /\ (col_ Aprimeprime Aprime Bprime /\ (col_ A Bprime Bprimeprime /\ (col_ M1 B I /\ (col_ Bprimeprime M1 I /\ (col_ Bprime I A /\ (col_ B M2 Aprimeprime /\ (col_ A M2 Bprime /\ (col_ B M1 Bprimeprime /\ col_ A M1 Aprime)))))))))))))))))))))))) -> col_ A Aprime Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export csubst.

Lemma lsubstc_mk_try {o} :
  forall (t1 t2 : @NTerm o) x v sub,
  forall w1 : wf_term t1,
  forall w2 : wf_term t2,
  forall wv : wf_term v,
  forall w  : wf_term (mk_try t1 t2 x v),
  forall c1 : cover_vars t1 sub,
  forall c2 : cover_vars t2 sub,
  forall cv : cover_vars_upto v (csub_filter sub [x]) [x],
  forall c  : cover_vars (mk_try t1 t2 x v) sub,
    lsubstc (mk_try t1 t2 x v) w sub c
    = mkc_try (lsubstc t1 w1 sub c1)
              (lsubstc t2 w2 sub c2)
              x
              (lsubstc_vars v wv (csub_filter sub [x]) [x] cv).
Proof.
  sp; unfold lsubstc; simpl.
  apply cterm_eq; simpl.
  unfold csubst; simpl;
  change_to_lsubst_aux4; simpl;
  rw @sub_filter_nil_r; allrw @fold_nobnd.
  rw @sub_filter_csub2sub; tcsp.
Qed.

Lemma cover_vars_try {p} :
  forall a n v b sub,
    @cover_vars p (mk_try a n v b) sub
    <=> cover_vars a sub
        # cover_vars n sub
        # cover_vars_upto b (csub_filter sub [v]) [v].
Proof.
  sp; repeat (rw @cover_vars_eq); unfold cover_vars_upto; simpl.
  allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw subvars_app_l.
  rw subvars_remove_nvars; simpl.
  rw @dom_csub_csub_filter.
  assert (v :: remove_nvars [v] (dom_csub sub)
          = [v] ++ remove_nvars [v] (dom_csub sub)) as eq by auto.
  rw eq.
  rw subvars_app_remove_nvars_r.
  rw subvars_swap_r; sp.
Qed.

Lemma lsubstc_mk_try_ex {o} :
  forall (t1 t2 : @NTerm o) x v sub,
  forall w : wf_term (mk_try t1 t2 x v),
  forall c : cover_vars (mk_try t1 t2 x v) sub,
  {w1 : wf_term t1
   & {w2 : wf_term t2
   & {wv : wf_term v
   & {c1 : cover_vars t1 sub
   & {c2 : cover_vars t2 sub
   & {cv : cover_vars_upto v (csub_filter sub [x]) [x]
   & lsubstc (mk_try t1 t2 x v) w sub c
     = mkc_try (lsubstc t1 w1 sub c1)
               (lsubstc t2 w2 sub c2)
               x
               (lsubstc_vars v wv (csub_filter sub [x]) [x] cv)}}}}}}.
Proof.
  introv.

  duplicate w.
  apply wf_try_iff in w; repnd.
  exists w1 w2 w.

  duplicate c.
  apply cover_vars_try in c; repnd.
  exists c1 c2 c.
  apply lsubstc_mk_try.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/")
*** End:
*)


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                                Product.v                                 *)
(****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.

Lemma pair_eq :
 forall (A B : Set) (p1 p1' : A) (p2 p2' : B),
 p1 = p1' -> p2 = p2' -> (p1, p2) = (p1', p2').
intros A B p1 p1' p2 p2' H1 H2; rewrite H1; rewrite H2; auto.
Qed.

Lemma eq_pair :
 forall (A B : Set) (p1 p1' : A) (p2 p2' : B),
 (p1, p2) = (p1', p2') -> p1 = p1' /\ p2 = p2'.
intros A B p1 p1' p2 p2' H; inversion H; auto.
Qed.

Lemma triplet_simpl :
 forall (A B C : Set) (x : A * (B * C)) (P : B -> Prop),
 P (fst (snd x)) ->
 let (_, p) return Prop := x in let (b, _) return Prop := p in P b.
intros A B C x P.
elim x.
intros y y0; elim y0; auto.
Qed.

Lemma Rewrite_Fst : forall (A B : Set) (a : A) (b : B), fst (a, b) = a.
auto.
Qed.

Lemma Rewrite_Snd : forall (A B : Set) (a : A) (b : B), snd (a, b) = b.
auto.
Qed.


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

Require Import List.

  Ltac lrev l :=
    let rec loop aa ll :=
        match ll with
          | ?x::?ll  => loop (x::aa) ll
          | nil      => constr:(aa)
        end
    in match type of l with
         | list ?t => loop (@nil t) l
       end.

  Ltac lflat l :=
    let rec loop aa ll :=
        match ll with
          | ?ss++?rr => let bb := loop aa ss in
                        let cc := loop bb rr
                        in constr:(cc)
          |  ?x::?rr => let bb := loop ((x::nil)::aa) rr
                        in constr:(bb)
          | nil      => constr:(aa)
          | ?ss      => constr:(ss::aa)
        end
    in  match type of l with
         | list ?t => let r1 := loop (@nil (list t)) l
                      in  lrev r1
       end.

  Ltac llin l :=
    let rec loop  aa ll :=
        match ll with
          | (?x::nil)::?ll => let bb := loop (x::aa) ll
                              in  constr:(bb)
          | ?lx::?ll       => let bb := loop (lx++aa) ll
                              in  constr:(bb)
          | nil            => constr:(aa)
        end
    in match type of l with
         | list (list ?t) =>
         match lrev l with
          | ?lx::?rr => let bb := loop lx rr
                        in  constr:(bb)
          | nil      => constr:(@nil t)
         end
       end.

  Ltac lcut x l :=
    let rec loop aa x ll :=
        match ll with
           | x::_      => let bb := lrev aa
                          in  constr:(bb++ll)
           | ?lz::?rr  => let bb := loop (lz::aa) x rr
                          in  constr:(bb)
        end
    in  match type of l with
          | list (list ?t) => loop (@nil (list t)) x l
        end.

  Ltac lmerge l :=
    match l with
      | ?aa++?ll => let bb := llin aa in
                    let cc := llin ll
                    in constr:(bb++cc)
    end.

  Ltac focus_lst z r0 :=
    let r1 := lflat  r0  in
    let r2 := lcut z r1  in
    let r3 := lmerge r2
    in  constr:(r3).

  Ltac focus_lst_2 z r0 :=
    let r1 := focus_lst z r0 in
    let r2 := match r1 with
                | ?l++?x::?r =>
                let r3 := focus_lst z r in
                match r3 with
                  | ?m++?y::?n => constr:((l++x::m)++y::n)
                end
              end
    in constr:(r2).

  Ltac focus_lst_3 z r0 :=
    let r1 := focus_lst_2 z r0 in
    let r2 := match r1 with
                | ?l++?x::?r =>
                let r3 := focus_lst z r in
                match r3 with
                  | ?m++?y::?n => constr:((l++x::m)++y::n)
                end
              end
    in constr:(r2).

  Ltac focus_elt z l := focus_lst (z::nil) l.

Section test.

  Variable X : Type.

  Variable x y z : list X.
  Variable a b c : X.

(*
  Goal True.
    let rr := lrev (1::2::3::4::nil) in idtac rr.
    let rr := lflat ((x++a::nil++nil)++b::z++y++a::nil) in idtac rr.
    let rr := llin (x::y::(a::nil)::z::(b::nil)::nil) in idtac rr.
    let rr := llin (@nil (list X)) in idtac rr.
    let rr := llin (@nil (list X)) in idtac rr.
    let rr := lcut z ( (x::y::(a::nil)::y::(b::nil)::z::nil) ) in idtac rr.
    let rr := lmerge ( (x::y::(a::nil)::nil)++(y::(b::nil)::z::nil) ) in idtac rr.
    let rr := focus_lst_2 (c::nil) ((x++c::nil++nil)++b::z++y++c::nil) in idtac rr.
    let rr := focus_lst_2 (c::nil) ((x++c::nil++nil)++b::z++y++c::z++c::x++c::z) in idtac rr.
    let rr := focus_lst z ((x++a::nil++nil)++b::z++y++c::nil) in idtac rr.
    let rr := focus_elt a (c::(x++a::nil++nil)++b::z++y++c::nil) in idtac rr.
    auto.
  Qed.
 *)

End test.


(*|
########################################
Existential goals are filled in too soon
########################################

:Link: https://stackoverflow.com/q/51332966
|*)

(*|
Question
********

I have a ``Class`` containing both data and axioms. I want to build
another instance in proof mode, based on (1) an existing instance and
(2) some other input. I want to ``destruct`` this second input before
creating the new instance of the record.

The minimal ``Class`` that works as an example is shrunk from one in
`jwiegley/category-theory
<https://github.com/jwiegley/category-theory>`__:
|*)

Require Import Coq.Unicode.Utf8.
Require Import Coq.Init.Datatypes.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.SetoidDec.

Generalizable All Variables.

Reserved Infix "~>" (at level 90, right associativity).
Reserved Infix "∘" (at level 40, left associativity).

Record Category := {
    obj : Type;

    uhom := Type : Type;
    hom : obj -> obj -> uhom where "a ~> b" := (hom a b);
    homset :> ∀ X Y, Setoid (X ~> Y);

    compose {x y z} (f: y ~> z) (g : x ~> y) : x ~> z
    where "f ∘ g" := (compose f g);

    compose_respects x y z :>
                     Proper (equiv ==> equiv ==> equiv) (@compose x y z);
  }.

(*| Suppose (2) is bool: |*)

Definition newCat (C : Category) (b : bool) : Category.
Proof.
  destruct b.
  - eapply Build_Category. Unshelve.

(*| At this point, ``obj`` is filled in with ``Type``: |*)

    Show. (* .unfold .messages *)

(*|
This behavior disappears if I remove the ``compose_respects`` axiom
(or use some other kind of ``Record`` without such a field). If I
change ``Category`` into a ``Class``, ``obj`` will be filled in as the
``obj`` of ``C``. It seems to have something to do with typeclass
resolution (the fact that the ``equiv``\ s have implicit typeclass
arguments?).

Is there someway to prevent these (or any!) variables from being
filled in with unification? The optimal result would be something like
``eapply``\ +\ ``Unshelve`` where no existentials are generated at
all, and I can fill in the record's fields as subgoals, in order.
|*)

(*|
Answer
******

It looks like ``simple notypeclasses refine {| obj := _ |}`` does the
trick.

- ``{| obj := _|}`` is record syntax that functions as shorthand for
  ``Build_Category _ _ _ _ _``.
- ``simple notypeclasses refine`` is all one tactic. It's a variant of
  ``notypeclasses refine`` that doesn't shelve goals and performs no
  reduction.
- Sadly there isn't a generic ``notypeclasses`` combinator, unlike
  ``unshelve``. There's just ``notypeclasses refine`` and ``simple
  notypeclasses refine``.

For debugging, you can use the (undocumented) ``Set Typeclasses
Debug``. This reveals that ``eapply Build_Category`` does resolve some
typeclasses, and ``refine {| obj := _|}`` is even worse.

As an aside, I don't think it makes sense to have ``Class Category``
without any type-level parameters - why would you ever want just any
category automatically inferred?
|*)


(*
 * Copyright 2015-2016 IBM Corporation
 *
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** This module contains additional definitions and lemmas on strings,
 including a total order relation. *)

Require Import Orders.
Require Import Ascii.
Require Import List.
Require Import String.
Require Import Arith.
Require Import Min.
Require Import Equivalence.
Require Import EquivDec.
Require Import Compare_dec.
Require Import Omega.
Require Import LibUtilsCoqLibAdd.

(** * Total order on characters *)

Module AsciiOrder <: OrderedTypeFull with Definition t:=ascii.
  Definition t:= ascii.
  Definition eq := @eq t.
  Definition eq_equiv : (Equivalence eq) := eq_equivalence.
  Definition eq_dec := ascii_dec.

  (* This could be done more directly, but this suffices *)
  Definition compare (a b:ascii) : comparison :=
    Nat.compare (nat_of_ascii a) (nat_of_ascii b).

  Definition lt (a b:ascii) := compare a b = Lt.

  Lemma lt_strorder : StrictOrder lt.
  Proof.
    split; repeat red; unfold lt, compare; intros;
      repeat match goal with
             | [H:Nat.compare _ _ = Lt |- _ ] => apply nat_compare_lt in H
             | [|- Nat.compare _ _ = Lt ] => apply nat_compare_lt
             end; omega.
  Qed.

  Lemma lt_compat : Proper (eq ==> eq ==> iff) lt.
  Proof.
    unfold Proper, respectful, eq; intros; subst; intuition.
  Qed.

  Lemma compare_eq_iff a b: compare a b = Eq <-> a = b.
  Proof.
    unfold AsciiOrder.compare.
    generalize (Nat.compare_eq_iff (nat_of_ascii a) (nat_of_ascii b)).
    destruct 1; split; intros; subst.
    - specialize (H H1).
      apply (f_equal ascii_of_nat) in H.
      repeat rewrite ascii_nat_embedding in H.
      trivial.
    - auto.
  Qed.

  Lemma compare_spec :
    forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
  Proof.
    intros. unfold eq, lt, compare.
    generalize (Nat.compare_spec (nat_of_ascii x) (nat_of_ascii y)); intros nc.
    inversion nc.
    - apply (f_equal ascii_of_nat) in H0.
      repeat rewrite ascii_nat_embedding in H0.
      subst. auto.
    - eauto.
    - constructor.
      apply nat_compare_lt. trivial.
  Qed.

  Lemma trichotemy a b : {lt a b} + {eq a b} + {lt b a}.
  Proof.
    generalize (compare_spec a b); intros nc.
    destruct (compare a b);
      [left; right|left;left|right]; inversion nc; trivial.
  Defined.

  Definition le (a b:ascii) :=
    match compare a b with
    | Lt => True
    | Eq => True
    | Gt => False
    end.

  Lemma le_lteq : forall x y : t, le x y <-> lt x y \/ eq x y.
  Proof.
    intros.
    generalize (compare_spec x y); inversion 1;
      unfold le, lt, eq in *;
      case_eq (compare x y); intuition congruence.
  Qed.

  Lemma compare_refl_eq a: compare a a = Eq.
  Proof.
    unfold AsciiOrder.compare.
    rewrite (Nat.compare_eq_iff (nat_of_ascii a) (nat_of_ascii a)); trivial.
  Qed.

End AsciiOrder.

(** * Total order on strings *)

Module StringOrder <: OrderedTypeFull with Definition t:=string.
  Definition t:= string.
  Definition eq := @eq t.
  Definition eq_equiv : (Equivalence eq) := eq_equivalence.
  Definition eq_dec := string_dec.

  Fixpoint compare (a:string) (b:string) : comparison :=
    match a, b with
    | EmptyString, EmptyString => Eq
    | EmptyString, String _ _ => Lt
    | String _ _, EmptyString => Gt
    | String a' a's, String b' b's =>
      match AsciiOrder.compare a' b' with
      | Lt => Lt
      | Eq => compare a's b's
      | Gt => Gt
      end
    end.

  Definition lt (a b:string) := compare a b = Lt.

  Lemma compare_spec :
    forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
  Proof.
    unfold eq, lt.
    induction x; destruct y; simpl in *; eauto.
    specialize (IHx y).
    case_eq (AsciiOrder.compare_spec a a0); intros.
    - unfold AsciiOrder.eq in *; subst.
      rewrite AsciiOrder.compare_refl_eq.
      inversion IHx; simpl; subst; eauto.
    - eauto.
    - unfold AsciiOrder.lt in *; rewrite l; eauto.
  Qed.

  Lemma trichotemy a b : {lt a b} + {eq a b} + {lt b a}.
  Proof.
    generalize (compare_spec a b); intros nc.
    destruct (compare a b);
      [left; right|left;left|right]; inversion nc; trivial.
  Defined.

  Lemma compare_refl_eq a: compare a a = Eq.
  Proof.
    induction a; simpl in *; eauto.
    rewrite AsciiOrder.compare_refl_eq; trivial.
  Qed.

  Lemma compare_eq_iff a b: compare a b = Eq <-> a = b.
  Proof.
    split; [| intros; subst; apply compare_refl_eq].
    revert b.
    induction a; destruct b; simpl in *; eauto; try congruence.
    generalize (AsciiOrder.compare_eq_iff a a1).
    intros. specialize (IHa b).
    destruct (AsciiOrder.compare a a1); intuition; congruence.
  Qed.

  Instance lt_strorder : StrictOrder lt.
  Proof.
    split; repeat red; unfold lt.
    - intros a H; rewrite compare_refl_eq in H. discriminate.
    - induction x; destruct y; destruct z; simpl; eauto; try congruence.
      intros. specialize (IHx y z).
      generalize (@StrictOrder_Transitive _ _ (AsciiOrder.lt_strorder) a a0 a1).
      unfold AsciiOrder.lt. intros AC.
      case_eq (AsciiOrder.compare a a0);
        intros re; rewrite re in *; try congruence;
          case_eq (AsciiOrder.compare a0 a1);
          intros re2; rewrite re2 in *; try congruence;
            try rewrite AsciiOrder.compare_eq_iff in *; subst;
              try rewrite re in*; try rewrite re2 in *;
                try rewrite AC by trivial;
                try rewrite AsciiOrder.compare_refl_eq;
                auto.
  Qed.

  Lemma lt_compat : Proper (eq ==> eq ==> iff) lt.
  Proof.
    unfold Proper, respectful, eq; intros; subst; intuition.
  Qed.

  Program Definition lt_dec (a b:string) : {lt a b} + {~lt a b}
    := match compare a b with
       | Lt => left _
       | Eq => right _
       | Gt => right _
       end.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    trivial.
  Qed.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    rewrite H0. apply irreflexivity.
  Qed.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    intro l2. apply (asymmetry H0 l2).
  Qed.

  Definition le (a b:string) :=
    match compare a b with
    | Lt => True
    | Eq => True
    | Gt => False
    end.

  Lemma le_lteq : forall x y : t, le x y <-> lt x y \/ eq x y.
  Proof.
    intros.
    generalize (compare_spec x y); inversion 1;
      unfold le, lt, eq in *;
      case_eq (compare x y); intuition congruence.
  Qed.

  Program Definition le_dec (a b:string) : {le a b} + {~le a b}
    := match compare a b with
       | Lt => left _
       | Eq => left _
       | Gt => right _
       end.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    apply le_lteq.
    intuition.
  Qed.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    apply le_lteq.
    intuition.
  Qed.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    intro l2.
    apply le_lteq in l2.
    destruct l2.
    - apply (asymmetry H0 H1).
    - rewrite H1 in H0. apply (irreflexivity H0).
  Qed.

End StringOrder.

(** * Conversion between lists of characters and strings *)

Section ToString.

  Fixpoint string_reverse_helper (s:string) (acc:string)
    := match s with
       | EmptyString => acc
       | String x xs => string_reverse_helper xs (String x acc)
       end.

  Definition string_reverse (s:string) := string_reverse_helper s EmptyString.

  Fixpoint string_to_list (s:string) : list ascii
    := match s with
       | EmptyString => nil
       | String x xs => cons x (string_to_list xs)
       end.

  Fixpoint list_to_string (l:list ascii) : string
    := match l with
       | nil => EmptyString
       | cons x xs => String x (list_to_string xs)
       end.

  Lemma string_to_list_to_string (s:string) :
    list_to_string (string_to_list s) = s.
  Proof.
    induction s; simpl; intuition congruence.
  Qed.

  Lemma list_to_string_to_list (l:list ascii) :
    string_to_list (list_to_string l) = l.
  Proof.
    induction l; simpl; intuition congruence.
  Qed.

  Lemma string_to_list_inj (x y:string) :
    string_to_list x = string_to_list y -> x = y.
  Proof.
    intros.
    generalize (f_equal list_to_string H); intros fe.
    repeat rewrite  string_to_list_to_string in fe; trivial.
  Qed.

  Lemma list_to_string_inj (x y:list ascii) :
    list_to_string x = list_to_string y -> x = y.
  Proof.
    intros.
    generalize (f_equal string_to_list H); intros fe.
    repeat rewrite  list_to_string_to_list in fe; trivial.
  Qed.

  Lemma string_reverse_helper_reverse_append s acc:
    string_reverse_helper s acc = list_to_string (List.rev_append (string_to_list s) (string_to_list acc)).
  Proof.
    revert acc.
    induction s; simpl; intros.
    - rewrite string_to_list_to_string; trivial.
    - rewrite IHs. simpl; auto.
  Qed.

  Lemma string_reverse_reverse s :
    string_reverse s = list_to_string (List.rev (string_to_list s)).
  Proof.
    rewrite List.rev_alt. apply string_reverse_helper_reverse_append.
  Qed.

  Lemma string_reverse_involutive x : string_reverse (string_reverse x) = x.
  Proof.
    repeat rewrite string_reverse_reverse.
    rewrite list_to_string_to_list, List.rev_involutive, string_to_list_to_string.
    trivial.
  Qed.

  Lemma string_reverse_inj x y :
    string_reverse x = string_reverse y ->
    x = y.
  Proof.
    intros re.
    generalize (f_equal string_reverse re); intros fe.
    repeat rewrite string_reverse_involutive in fe; trivial.
  Qed.

  Lemma lt_contr1 s1 s2 :
    ~StringOrder.lt s1 s2 -> ~StringOrder.lt s2 s1 -> StringOrder.eq s1 s2.
  Proof.
    unfold not; intros.
    generalize (StringOrder.trichotemy s1 s2); intros.
    inversion H1.
    elim H2; intros.
    congruence.
    assumption.
    congruence.
  Qed.

  Lemma lt_contr2 s1 s2 :
    StringOrder.lt s1 s2 -> ~StringOrder.eq s1 s2.
  Proof.
    compare s1 s2.
    intros. rewrite e in *; clear e.
    unfold not; intros.
    apply asymmetry with (x := s2) (y := s2); assumption.
    intros. assumption.
    apply ascii_dec.
  Qed.

  Lemma lt_contr3 s :
    StringOrder.lt s s -> False.
  Proof.
    generalize (lt_contr2 s s); intros.
    unfold not in *.
    apply (H H0).
    reflexivity.
  Qed.

End ToString.

(** * String prefixes *)

Section Prefix.
  Lemma substring_zero s :
    substring 0 0 s = ""%string.
  Proof.
    induction s; reflexivity.
  Qed.

  Lemma substring_S a m s :
    substring 0 (S m) (String a s) = String a (substring 0 m s).
  Proof.
    reflexivity.
  Qed.

  Lemma append_string_distr a s1 s2 :
    (String a s1 ++ s2 = String a (s1 ++ s2))%string.
  Proof.
    auto.
  Qed.

  Lemma append_eq_inv1 x y z : append x y = append x z -> y = z.
  Proof.
    revert y z.
    induction x; simpl; trivial; intros.
    inversion H; subst.
    auto.
  Qed.

  Lemma prefix_refl y : prefix y y = true.
  Proof.
    induction y; simpl; trivial.
    match_destr; congruence.
  Qed.

  Lemma substring_append_cancel x y :
    substring (String.length x) (String.length y) (append x y) = y.
  Proof.
    revert y.
    induction x; simpl; intros.
    - apply prefix_correct. apply prefix_refl.
    - trivial.
  Qed.

  Lemma string_length_append x y :
    String.length (append x y) = String.length x + String.length y.
  Proof.
    revert y.
    induction x; simpl; auto.
  Qed.

  Lemma prefix_nil post : prefix ""%string post = true.
  Proof.
    destruct post; trivial.
  Qed.

  Lemma prefix_app pre post : prefix pre (append pre post) = true.
  Proof.
    revert post.
    induction pre; intros; simpl.
    - apply prefix_nil.
    - match_destr; intuition.
  Qed.

  Lemma prefix_break {pre x} :
    prefix pre x = true ->
    {y | x = append pre y}.
  Proof.
    revert x.
    induction pre; simpl.
    - eauto.
    - destruct x; simpl; try discriminate.
      match_destr.
      subst; intros p.
      destruct (IHpre _ p).
      subst.
      eauto.
  Qed.

  Lemma substring_split s n m l :
    append (substring s n l) (substring (s+n) m l) = substring s (n+m) l.
  Proof.
    revert n m s.
    induction l; simpl; destruct s; destruct n; simpl; trivial.
    - f_equal.
      apply IHl.
    - rewrite IHl; simpl; trivial.
    - rewrite IHl. simpl; trivial.
  Qed.

  Lemma substring_all l :
    substring 0 (String.length l) l = l.
  Proof.
    induction l; simpl; congruence.
  Qed.

  Lemma substring_bounded s n l :
    substring s n l = substring s (min n (String.length l - s)) l.
  Proof.
    revert s n.
    induction l; destruct s; destruct n; simpl; trivial.
    - rewrite IHl; simpl.
      f_equal.
      f_equal.
      f_equal.
      omega.
    - rewrite IHl.
      match_case.
  Qed.

  Lemma substring_le_prefix s n m l :
    n <= m ->
    prefix (substring s n l) (substring s m l) = true.
  Proof.
    revert s n m.
    induction l; destruct s; destruct n; destruct m; simpl; trivial;
      try omega; intuition.
    match_destr; intuition.
  Qed.

  Lemma substring_prefix n l :
    prefix (substring 0 n l) l = true.
  Proof.
    rewrite substring_bounded.
    rewrite <- (substring_all l) at 3.
    apply substring_le_prefix.
    replace (String.length l - 0) with (String.length l) by omega.
    apply le_min_r.
  Qed.

  Lemma in_of_append pre y l :
    In (append pre y) l <->
    In y (map
            (fun x => substring (String.length pre) (String.length x - String.length pre) x)
            (filter (prefix pre) l)).
  Proof.
    rewrite in_map_iff.
    split; intros.
    - exists (append pre y).
      rewrite string_length_append.
      replace ((String.length pre + String.length y - String.length pre))
        with (String.length y) by omega.
      rewrite substring_append_cancel.
      split; trivial.
      apply filter_In.
      split; trivial.
      apply prefix_app.
    - destruct H as [x [subx inx]]; subst.
      apply filter_In in inx.
      destruct inx as [inx prex].
      destruct (prefix_break prex).
      subst.
      rewrite string_length_append.
      replace ((String.length pre + String.length x0 - String.length pre))
        with (String.length x0) by omega.
      rewrite substring_append_cancel.
      trivial.
  Qed.

  Lemma append_ass s1 s2 s3 : ((s1 ++ s2) ++ s3 = s1 ++ s2 ++ s3)%string.
  Proof.
    revert s2 s3.
    induction s1; simpl.
    - trivial.
    - intros. rewrite IHs1; trivial.
  Qed.

End Prefix.

(** * Character map over strings *)

Section MapString.
  Fixpoint map_string (f:ascii->ascii) (s:string)
    := match s with
       | EmptyString => EmptyString
       | String a s' => String (f a) (map_string f s')
       end.

  Fixpoint flat_map_string (f:ascii->string) (s:string)
    := match s with
       | EmptyString => EmptyString
       | String a s' => append (f a) (flat_map_string f s')
       end.

  Global Instance ascii_dec : EqDec ascii eq
    := ascii_dec.
End MapString.

(** Support for 'like' on strings *)

Section Join.
  Definition map_concat {A} separator (f:A -> string) (elems:list A) : string :=
    match elems with
    | nil => ""
    | e :: elems' =>
      (fold_left (fun acc e => acc ++ separator ++ (f e)) elems' (f e))%string
    end.

End Join.

Section Like.
  (* This is intended to be like the SQL like operation *)
  (*  Definition string_like (s:pattern) *)

  Inductive like_clause :=
  | like_literal (literal:string) : like_clause
  | like_any_char : like_clause
  | like_any_string : like_clause.

  Fixpoint make_like_clause (s:string) (escape:option ascii) {struct s}: list like_clause
    := match s with
       | EmptyString => nil
       | String "_"%char tail => like_any_char :: make_like_clause tail escape
       | String "%"%char tail => like_any_string :: make_like_clause tail escape
       | other =>
         (fix make_like_literal_clause (ss:string)  (acc:string) {struct ss} : list like_clause
          := match ss with
             | EmptyString => like_literal (string_reverse acc) :: nil
             | String "_"%char tail => like_literal (string_reverse acc) :: like_any_char :: make_like_clause tail escape
             | String "%"%char tail => like_literal (string_reverse acc) :: like_any_string :: make_like_clause tail escape
             | String h tail =>
               if Some h == escape
               then
                 match tail with
                 | EmptyString =>
                   (* unclear what to do with an escape character at the end of the string.  We will interpret it as a literal character *)
                   like_literal (string_reverse (String h acc)) :: nil
                 | String "_"%char tail => make_like_literal_clause tail (String "_" acc)
                 | String "%"%char tail => make_like_literal_clause tail (String "%" acc)
                 | String nh ntail =>
                   if Some nh == escape
                   then make_like_literal_clause ntail (String nh acc)
                   else
                     (* unclear what to do with an escape character that is invalid.  We will interpret it as a literal character *)
                     make_like_literal_clause ntail (String nh (String h acc))
                 end
               else
                 make_like_literal_clause tail (String h acc)
             end
         ) other ""%string
       end.

  Example make_like_clause_example1 := make_like_clause "hello_there^^^%%" None.
  Example make_like_clause_example2 := make_like_clause "hello_there^^^%%" (Some "^"%char).

  (*
  Eval vm_compute in make_like_clause_example1.
  Eval vm_compute in make_like_clause_example2.
   *)

  Fixpoint  string_exists_suffix (f:string->bool) (s:string) : bool
    := f s ||
         match s with
         | EmptyString => false
         | String _ tail => string_exists_suffix f tail
         end.

  (* something like bayer-moore would be much more efficient.
     This implementation is known to have very poor performance *)
  Fixpoint like_clause_matches_string (pat:list like_clause) (s:string)
    := match pat with
       | nil => s ==b EmptyString
       | (like_literal literal)::rest =>
         andb (prefix literal s)
              (like_clause_matches_string rest (substring (String.length literal) (String.length s - String.length literal) s))
       | like_any_char::rest =>
         match s with
         | EmptyString => false
         | String _ tail => like_clause_matches_string rest tail
         end
       | like_any_string::rest =>
         string_exists_suffix (like_clause_matches_string rest) s
       end.

  (* This is intended to be like the SQL like operation *)
  Definition string_like (str pattern:string) (escape:option ascii) : bool
    := let pat_clause := make_like_clause pattern escape in
       like_clause_matches_string pat_clause str.

  Example string_like_example1 := string_like "hello there" "hello there" None.
  Example string_like_example2 := string_like "hello there" "hello %there" None.
  Example string_like_example3 := string_like "hello there" "he%th_re" None.
  Example string_like_example4 := string_like "hello there " "he%th_re" None.
  Example string_like_example5 := string_like "hello thethare" "he%th_re" None.
  Example string_like_example6 := string_like "hello thetheare" "he%th_re" None.

(*
  Eval vm_compute in string_like_example1.
  Eval vm_compute in string_like_example2.
  Eval vm_compute in string_like_example3.
  Eval vm_compute in string_like_example4.
  Eval vm_compute in string_like_example5.
  Eval vm_compute in string_like_example6.
 *)

End Like.


From iris.base_logic Require Export derived proofmode.
From iris.bi Require Export bi.
Set Default Proof Using "Type".

(* The trick of having multiple [uPred] modules, which are all exported in
another [uPred] module is by Jason Gross and described in:
https://sympa.inria.fr/sympa/arc/coq-club/2016-12/msg00069.html *)
Module Import uPred.
  Export base_logic.bi.uPred.
  Export derived.uPred.
  Export bi.bi.
End uPred.