(** * Subcategory of KTrees indexed by finite types *)

(* Definition of the [subpure] function, mapping [sub Fun fin] (functions between finite
   types) to [sub (ktree E) fin] (KTrees between finite types) and proves that
   it commutes with the various combinators from [ITree.Basics.Category].
 *)

(* begin hide *)
From Coq Require Import
     Setoid
     Morphisms.

From ITree Require Import
     ITree
     ITreeFacts
     Basics.CategorySub.

Require Import Fin.

Import CatNotations.
Local Open Scope cat_scope.
(* end hide *)

(* General theory. Functors which preserve coproducts.
   Here we assume that the functor's object mapping is the identity function.
 *)
Section CocartesianFunctor.

Context
  {obj : Type} {C D : obj -> obj -> Type}
  {bif : obj -> obj -> obj}
  `{Eq2 _ C} `{Case _ C bif} `{Inl _ C bif} `{Inr _ C bif}
  `{Eq2 _ D} `{Case _ D bif} `{Inl _ D bif} `{Inr _ D bif}
  {fmap : forall a b, C a b -> D a b}.

Arguments fmap {a b}.

Class CocartesianFunctor : Prop :=
  { fmap_case : forall a b c (f : C a c) (g : C b c),
      fmap (case_ f g) ⩯ case_ (fmap f) (fmap g)
  ; fmap_inl : forall a b,
      fmap (inl_ (a := a) (b := b)) ⩯ inl_
  ; fmap_inr : forall a b,
      fmap (inr_ (a := a) (b := b)) ⩯ inr_
  }.

Context
  `{forall a b, Equivalence (eq2 (C := D) (a := a) (b := b))}
  `{Id_ _ C} `{Cat _ C}
  `{Id_ _ D} `{Cat _ D}
  `{forall a b c, Proper (eq2 ==> eq2 ==> eq2) (cat (C := D) (a := a) (b := b) (c := c))}
  `{@Coproduct _ D _ _ bif _ _ _}
  `{@Functor _ _ C D (fun x => x) (@fmap) _ _ _ _ _ _}
  `{CocartesianFunctor}.

Lemma fmap_swap {n m}
  : fmap swap ⩯ swap (a := n) (b := m).
Proof.
  unfold swap, Swap_Coproduct.
  rewrite fmap_case, fmap_inl, fmap_inr.
  reflexivity.
Qed.

Lemma fmap_bimap {n m p q} (f : C n m) (g : C p q)
  : fmap (bimap f g) ⩯ bimap (fmap f) (fmap g).
Proof.
  unfold bimap, Bimap_Coproduct.
  rewrite fmap_case, !fmap_cat0, fmap_inl, fmap_inr.
  reflexivity.
Qed.

Lemma fmap_assoc_l {n m p}
  : fmap (a := (bif n (bif m p))) assoc_l ⩯ assoc_l.
Proof.
  unfold assoc_l, AssocL_Coproduct.
  rewrite !fmap_case, !fmap_cat0, !fmap_inl, !fmap_inr.
  reflexivity.
Qed.

Lemma fmap_assoc_r {n m p}
  : fmap (a := (bif (bif n m) p)) assoc_r ⩯ assoc_r.
Proof.
  unfold assoc_r, AssocR_Coproduct.
  rewrite !fmap_case, !fmap_cat0, !fmap_inl, !fmap_inr.
  reflexivity.
Qed.

End CocartesianFunctor.

Notation Fun_fin := (sub Fun fin).
Notation ktree_fin E := (sub (ktree E) fin).

Section PureKF.

Context {E : Type -> Type}.

Definition subpure {n m} (f : Fun_fin n m) : ktree_fin E n m :=
  subm (pure (unsubm f)).

Global Instance Functor_pure : Functor _ _ _ (@subpure).
Proof.
  constructor; intros.
  - reflexivity.
  - unfold subpure. rewrite fmap_cat, fmap_cat0. reflexivity.
  - hnf; intros. apply Proper_subm, Proper_pure. auto.
Qed.

Global Instance CocartesianFunctor_pure : CocartesianFunctor (fmap := @subpure).
Proof.
  constructor; intros.
  - intros []; cbn.
    unfold unsubm, case_, Case_Kleisli, case_sum, Case_sub, case_.
    unfold cat, Cat_sub, Cat_Fun.
    unfold to_bif, ToBifunctor_ktree_fin, ToBifunctor_Fun_fin.
    rewrite bind_ret_l.
    destruct split_fin_sum; reflexivity.
  - intros ?; cbn. rewrite bind_ret_l. reflexivity.
  - intros ?; cbn; rewrite bind_ret_l; reflexivity.
Qed.

End PureKF.


Require Import Coq.Classes.EquivDec.
Require Import Coq.Lists.List Coq.Arith.Arith Coq.Bool.Bool.
Require Import MirrorShard.Expr MirrorShard.Env.
Require Import MirrorShard.Prover.

Set Implicit Arguments.
Set Strict Implicit.

Local Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

(** * The Transitivity Prover **)

(* Algorithm for grouping expressions by equalities. Terribly inefficient... *)
Section Grouper.
  Variable A : Type.
  Variable A_seq : A -> A -> bool.

  Fixpoint in_seq (ls : list A) (a : A) : bool :=
    match ls with
      | nil => false
      | x :: ls' => A_seq x a || in_seq ls' a
    end.

  Fixpoint groupWith (grps : list (list A)) (g : list A) (a : A) :=
    match grps with
      | nil => [a :: g]
      | g' :: grps' => if in_seq g' a
                       then (g' ++ a :: g) :: grps'
                       else g' :: groupWith grps' g a
    end.

  Fixpoint addEquality (ls : list (list A)) (a : A) (b : A) : list (list A) :=
    match ls with
      | nil => [[a, b]] (* matched nothing *)
      | grp :: ls' => if in_seq grp a
                        then groupWith ls' grp b
                        else if in_seq grp b
                               then groupWith ls' grp a
                               else grp :: addEquality ls' a b
    end.

  Fixpoint inSameGroup (grps : list (list A)) (a : A) (b : A) :=
    match grps with
      | nil => false
      | g :: grps' =>
        if in_seq g a then
          if in_seq g b
            then true
            else inSameGroup grps' a b
        else inSameGroup grps' a b
    end.

  Variable R : A -> A -> Prop.
  (* An arbitrary partial equivalence relation *)

  Hypothesis Rsym : forall x y, R x y -> R y x.
  Hypothesis Rtrans : forall x y z, R x y -> R y z -> R x z.
  Hypothesis A_seq_correct : forall x y, A_seq x y = true -> R x y.

  Fixpoint InR (x : A) (ls : list A) : Prop :=
    match ls with
      | nil => False
      | y :: ls' => R y x \/ InR x ls'
    end.

  Definition groupEqualTo (a : A) := Forall (R a).

  Definition groupEqual (g : list A) :=
    match g with
      | nil => True
      | a' :: g' => groupEqualTo a' g'
    end.

  Definition groupsEqual := Forall groupEqual.

  Hint Extern 1 (groupEqual _) => hnf.

  Hint Resolve Rsym Rtrans.

  Lemma Rweaken : forall x y l,
    Forall (R x) l
    -> R x y
    -> Forall (R y) l.
    induction 1; t.
  Qed.

  Hint Resolve Rweaken.

  Lemma groupEqualTo_groupEqual : forall x xs,
    Forall (R x) xs
    -> groupEqual xs.
    induction 1; t.
  Qed.

  Hint Resolve groupEqualTo_groupEqual.

  Hint Resolve Folds.Forall_app.

  Lemma groupEqualTo_In : forall x y g,
    InR y g
    -> Forall (R x) g
    -> R x y.
    induction 2; t.
  Qed.

  Hint Immediate groupEqualTo_In.

  Hint Extern 1 (Forall _ _) => progress hnf.

  Lemma in_seq_correct : forall (a : A) (ls : list A),
    in_seq ls a = true -> InR a ls.
  Proof.
    induction ls; t.
  Qed.

  Hint Resolve in_seq_correct A_seq_correct.

  Lemma groupWith_sound : forall x xs grps,
    Forall groupEqual grps
    -> Forall (R x) xs
    -> Forall groupEqual (groupWith grps xs x).
    induction 1; t. eauto 10.
      apply in_seq_correct in H3. eauto 7.
  Qed.

  Hint Resolve groupWith_sound.

  Theorem addEquality_sound : forall x y grps,
    groupsEqual grps
    -> R x y
    -> groupsEqual (addEquality grps x y).
    induction 1; t;
      match goal with
        | [ H : _ |- _ ] => apply A_seq_correct in H || apply in_seq_correct in H
      end; eauto 7.
  Qed.

  Theorem inSameGroup_sound : forall grps, groupsEqual grps
    -> forall x y, inSameGroup grps x y = true
      -> R x y.
    induction 1; t;
      repeat match goal with
        | [ H : _ |- _ ] => apply A_seq_correct in H || apply in_seq_correct in H
      end; eauto 7.
  Qed.
End Grouper.

Section TransitivityProver.
  Variable types : list type.
  Variable fs : functions types.
  Section with_vars.
  Variables uvars vars : env types.

  Definition transitivity_summary : Type := list (list (expr types)).

  Coercion typeof_env : env >-> tenv.

  Definition eqD (e1 e2 : expr types) : Prop :=
    match typeof (typeof_funcs fs) uvars vars e1 with
      | None => False
      | Some t =>
        match exprD fs uvars vars e1 t, exprD fs uvars vars e2 t with
          | Some v1, Some v2 => v1 = v2
          | _, _ => False
        end
    end.

  Theorem eqD_refl : forall e1 e2, e1 = e2
    -> forall t, typeof (typeof_funcs fs) uvars vars e1 = Some t
      -> forall v, exprD fs uvars vars e1 t = Some v
        -> eqD e1 e2.
    t.
  Qed.

  Lemma nth_error_nil : forall T n,
    nth_error (@nil T) n = None.
  Proof.
    destruct n; simpl; auto.
  Qed.

(*
  Theorem eqD_refl_wt : forall e1 e2, e1 = e2 ->
    match is_well_typed (typeof_funcs fs) uvars vars e1 (typeof (typeof_funcs fs) uvars vars e1) return Prop with
      | None => True
      | Some t => eqD e1 e2
    end.
  Proof.
    intros; subst.
    case_eq (well_typed fs uvars vars e2); intros; auto.
    generalize is_well_typed_typeof.
    generalize well_typed_is_well_typed. intros.
    generalize H. apply H0 in H.
    generalize H.
    apply is_well_typed_correct in H.
    intros.
    apply H1 in H2. destruct H.
    eapply eqD_refl; eauto.
  Qed.
*)

  Fixpoint transitivityLearn (sum : transitivity_summary) (hyps : list (expr types)) : transitivity_summary :=
    match hyps with
      | nil => sum
      | h :: hyps' =>
        let grps := transitivityLearn sum hyps' in
          match h with
            | Equal t x y => addEquality (@expr_seq_dec  _) grps x y
            | _ => grps
          end
    end.
  Definition groupsOf := transitivityLearn nil.

  Definition transitivityEqProver (groups : transitivity_summary)
    (x y : expr types) := inSameGroup (@expr_seq_dec _) groups x y.

  Fixpoint proveEqual (groups : transitivity_summary) (e1 e2 : expr types) {struct e1} :=
    expr_seq_dec e1 e2 ||
      (inSameGroup (@expr_seq_dec _) groups e1 e2
        || match e1, e2 with
             | Func f1 args1, Func f2 args2 =>
               if eq_nat_dec f1 f2
                 then (fix proveEquals (es1 es2 : list (expr types)) :=
                   match es1, es2 with
                     | nil, nil => true
                     | e1 :: es1', e2 :: es2' => proveEqual groups e1 e2 && proveEquals es1' es2'
                     | _, _ => false
                   end) args1 args2
                 else false
             | _, _ => false
           end
    ).

  Definition transitivityProve (groups : transitivity_summary)
    (goal : expr types) :=
    match goal with
      | Equal _ x y => proveEqual groups x y
      | _ => false
    end.

  Hint Resolve addEquality_sound.
  Hint Immediate lookupAs_det.

  Ltac foundTypeof E := generalize (@exprD_principal _ fs uvars vars (typeof_funcs fs) uvars vars
    (typeof_env_WellTyped_env _) (typeof_env_WellTyped_env _) (typeof_funcs_WellTyped_funcs _) E);
  destruct (typeof (typeof_funcs fs) uvars vars E); intuition.

  Ltac foundDup E T1 T2 := match T1 with
                             | T2 => fail 1
                             | _ =>
                               assert (T1 = T2) by (apply (exprD_det fs uvars vars E);
                                 try match goal with
                                       | [ H : _ |- _ ] => solve [ intro; apply H with T1; t ]
                                     end); subst
                           end.

  Ltac eqD1 :=
    match goal with
      | [ _ : context[typeof _ _ _ ?E] |- _ ] => foundTypeof E
      | [ |- context[typeof _ _ _ ?E] ] => foundTypeof E
      | [ _ : context[exprD fs uvars vars ?E ?T1] |- context[exprD fs uvars vars ?E ?T2] ] => foundDup E T1 T2
      | [ _ : context[exprD fs uvars vars ?E ?T1], _ : context[exprD fs uvars vars ?E ?T2] |- _ ] => foundDup E T1 T2
      | [ x : tvar, H1 : forall y : tvar, _ |- False ] => apply H1 with x; t
    end.

  Ltac eqD := unfold eqD; intros; repeat eqD1; t.

  Theorem eqD_sym : forall x y : expr types, eqD x y -> eqD y x.
    unfold eqD; intros.
    eqD.
  Qed.

  Theorem eqD_trans : forall x y z : expr types, eqD x y -> eqD y z -> eqD x z.
    eqD.
  Qed.

  Hint Immediate eqD_sym eqD_trans.

  Theorem groupsOf_sound : forall hyps,
    AllProvable fs uvars vars hyps
    -> groupsEqual eqD (groupsOf hyps).
    induction hyps. intuition. simpl in *. constructor.

    intro. simpl in H. destruct H.
    specialize (IHhyps H0).

    t1.
    destruct a; auto.
    revert H; case_eq (exprD fs uvars vars (Equal t a1 a2) tvProp); intros; try contradiction.
    simpl in *. apply addEquality_sound; eauto.

    Focus 2.

    revert H.
    unfold eqD.
    case_eq (exprD fs uvars vars a1 t); try congruence; intros.
(*
    rewrite (exprD_typeof _ _ _ _ _ H). rewrite H. destruct (exprD fs uvars vars a2 t); try congruence.
    inversion H2. subst; auto.
*)
    admit. (** TODO : this isn't true in general, but the fact that everything is provable makes it true **)
    admit.
  Qed.
  End with_vars.

  Definition transitivityValid (uvars vars : env types) (sum : transitivity_summary) : Prop :=
    (forall ls, In ls sum -> forall e, In e ls -> ValidExp fs uvars vars e) ->
    groupsEqual (eqD uvars vars) sum.

  Definition transitivitySummarize := groupsOf.

  Theorem transitivitySummarizeCorrect : forall uvars vars hyps,
    AllProvable fs uvars vars hyps ->
    transitivityValid uvars vars (transitivitySummarize hyps).
  Proof.
  Admitted.

  Theorem transitivityLearnCorrect : forall uvars vars sum,
    transitivityValid uvars vars sum -> forall hyps,
    AllProvable fs uvars vars hyps ->
    transitivityValid uvars vars (transitivityLearn sum hyps).
  Proof.
  Admitted.

  Theorem transitivityProverCorrect : ProverCorrect fs transitivityValid transitivityProve.
    admit.
(*
    unfold transitivityProver; hnf; intros;
      destruct goal; try discriminate;
        match goal with
          | [ H1 : _, H2 : _ |- _ ] =>
            apply (inSameGroup_sound eqD_sym eqD_trans expr_seq_dec
              (groupsOf_sound _ H1)) in H2
        end; hnf in *; simpl in *; eqD.
*)
  Qed.

  Theorem transitivityValid_extensible : forall (u g : env types) (f : transitivity_summary)
     (ue ge : list (sigT (tvarD types))),
   transitivityValid u g f -> transitivityValid (u ++ ue) (g ++ ge) f.
  Proof.
  Admitted.

  Definition transitivityProver : ProverT types :=
  {| Facts := transitivity_summary
   ; Summarize := transitivitySummarize
   ; Learn := transitivityLearn
   ; Prove := transitivityProve
   |}.

  Definition transitivityProver_correct : ProverT_correct transitivityProver fs.
  eapply Build_ProverT_correct with (Valid := transitivityValid);
    eauto using transitivityValid_extensible, transitivitySummarizeCorrect, transitivityLearnCorrect, transitivityProverCorrect.
  Qed.

End TransitivityProver.

Definition TransitivityProver : ProverPackage :=
{| ProverTypes := nil_Repr EmptySet_type
 ; ProverFuncs := fun ts => nil_Repr (Default_signature ts)
 ; Prover_correct := fun ts fs => transitivityProver_correct fs
|}.

Ltac unfold_transitivityProver H :=
  match H with
    | tt =>
      cbv delta [
        transitivityProver proveEqual
        transitivitySummarize transitivityLearn transitivityProve

        groupsOf addEquality
        transitivityLearn
        inSameGroup
        expr_seq_dec
        in_seq
        groupWith
      ]
    | _ =>
      cbv delta [
        transitivityProver proveEqual
        transitivitySummarize transitivityLearn transitivityProve

        groupsOf addEquality
        transitivityLearn
        inSameGroup
        expr_seq_dec
        in_seq
        groupWith
      ] in H
  end.


(* Miscellaneous results that will be added to appropriate places in the HoTT library. *)

Require Import HoTT.

(* The universe variables here do not follow our general convention.  We name them nicely here because later we need to provide universe annotations when using this result. *)
Definition equiv_postcompose_equiv@{i j k u v | i <= u, j <= v, k <= u, k <= v} `{Funext}
           {X : Type@{i}} {Y : Type@{j}} (Z : Type@{k}) (e : X <~> Y)
  : Equiv@{u v} (Z <~> X) (Z <~> Y).
(* This follows from equiv_induction, but we need to control universe variables. This method also avoids Univalence. *)
Proof.
  snrapply equiv_adjointify.
  - exact (fun f => e oE f).
  - exact (fun g => e^-1 oE g).
  - intro g.
    apply path_equiv@{k j v}; cbn.
    funext z.
    apply eisretr.
  - intro f.
    apply path_equiv@{k i u}; cbn.
    funext z.
    apply eissect.
Defined.

Definition equiv_precompose_equiv@{i j k u v | i <= u, j <= v, k <= u, k <= v} `{Funext}
           {X : Type@{i}} {Y : Type@{j}} (Z : Type@{k}) (e : X <~> Y)
  : Equiv@{v u} (Y <~> Z) (X <~> Z).
(* This follows from equiv_induction, but we need to control universe variables. This method also avoids Univalence. *)
Proof.
  snrapply equiv_adjointify.
  - exact (fun g => g oE e).
  - exact (fun f => f oE e^-1).
  - intro f.
    apply path_equiv@{i k u}; cbn.
    funext x.
    apply (ap f).
    apply eissect.
  - intro g.
    apply path_equiv@{j k v}; cbn.
    funext y.
    apply (ap g).
    apply eisretr.
Defined.

Definition iff_contr_equiv {P Q : Type} (e : P <~> Q) : Contr P <-> Contr Q
  := (@contr_equiv' _ _ e, @contr_equiv' _ _ e^-1).

Definition nullhomotopy_factor_through_unit {A B : Type} (f : A -> B)
           (E : ExtensionAlong (fun _ => tt) (fun _ => B) f)
  : NullHomotopy f.
Proof.
  exists (E.1 tt).
  intro x.
  symmetry.
  apply E.2.
Defined.

Definition factor_through_unit_nullhomotopy {A B : Type} (f : A -> B)
           (N : NullHomotopy f)
  : ExtensionAlong (fun _ => tt) (fun _ => B) f.
Proof.
  destruct N as [b H].
  unfold ExtensionAlong.
  exists (fun _ => b).
  intro x.
  symmetry.
  apply H.
Defined.

(* If maps are n-extendable along the constant map [X -> Unit] for definitionally constant type families over [Unit], then they are n-extendable along all type families. *)
Definition extendable_along_unit (n : nat) (X : Type) (P : Unit -> Type)
           (ea : ExtendableAlong n (fun _ : X => tt) (fun _ : Unit => P tt))
  : ExtendableAlong n (fun _ : X => tt) P.
Proof.
  revert P ea.
  (* Using [simple_induction] avoids an extra universe variable. *)
  simple_induction n n IHn; intros P ea.
  - exact tt.
  - split.
    + intro g.
      pose (feag := (fst ea) g).
      srefine (_; _).
      * intro y; destruct y.
        exact (feag.1 tt).
      * cbn.  exact feag.2.
    + intros h k.
      apply IHn.
      apply (snd ea (fun _ => h tt) (fun _ => k tt)).
Defined.

(* ** This next part is essentially showing that [Tr n.+1] is accessible. *)
Definition istrunc_iff_sphere_null (n : trunc_index) (X : Type)
  : IsTrunc n.+1 X <-> forall f : Sphere n.+2 -> X, ExtensionAlong (fun _ : Sphere n.+2 => tt) (unit_name X) f.
Proof.
  split.
  - intros isTrX f.
    apply factor_through_unit_nullhomotopy.
    apply allnullhomot_trunc.
  - intros ea.
    apply istrunc_allnullhomot@{k k k k}; intro f.
    srapply nullhomotopy_factor_through_unit.
    apply ea.
Defined.

(* This has four universe variables, but can accept them being equal.  Can get it down to a single universe variable with some annotations. *)
Definition istrunc_iff_sphere_oo_null (n : trunc_index) (X : Type)
  : IsTrunc n.+1 X <-> ooExtendableAlong (fun _ : Sphere n.+2 => tt) (unit_name X).
Proof.
  split.
  - intros isTrX n0; revert X isTrX.
    simple_induction n0 n0 IHn0; intros X isTrX.
    + exact tt.
    + split; intros.
      * apply istrunc_iff_sphere_null; assumption.
      * apply extendable_along_unit.
        rapply IHn0.
  - intros ea.
    apply istrunc_allnullhomot; intro f.
    srapply nullhomotopy_factor_through_unit.
    apply (ea 1%nat).
Defined.


(* Copyright (c) 2008-2010, 2012, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import String List.

Require Import Cpdt.CpdtTactics Cpdt.DepList.

Set Implicit Arguments.
Set Asymmetric Patterns.
(* end hide *)

(** printing ~> $\leadsto$ *)

(** %\chapter{Generic Programming}% *)

(** %\index{generic programming}% _Generic programming_ makes it possible to write functions that operate over different types of data.  %\index{parametric polymorphism}%Parametric polymorphism in ML and Haskell is one of the simplest examples.  ML-style %\index{module systems}%module systems%~\cite{modules}% and Haskell %\index{type classes}%type classes%~\cite{typeclasses}% are more flexible cases.  These language features are often not as powerful as we would like.  For instance, while Haskell includes a type class classifying those types whose values can be pretty-printed, per-type pretty-printing is usually either implemented manually or implemented via a %\index{deriving clauses}%[deriving] clause%~\cite{deriving}%, which triggers ad-hoc code generation.  Some clever encoding tricks have been used to achieve better within Haskell and other languages, but we can do%\index{datatype-generic programming}% _datatype-generic programming_ much more cleanly with dependent types.  Thanks to the expressive power of CIC, we need no special language support.

   Generic programming can often be very useful in Coq developments, so we devote this chapter to studying it.  In a proof assistant, there is the new possibility of generic proofs about generic programs, which we also devote some space to. *)

(** * Reifying Datatype Definitions *)

(** The key to generic programming with dependent types is%\index{universe types}% _universe types_.  This concept should not be confused with the idea of _universes_ from the metatheory of CIC and related languages, which we will study in more detail in the next chapter.  Rather, the idea of universe types is to define inductive types that provide _syntactic representations_ of Coq types.  We cannot directly write CIC programs that do case analysis on types, but we _can_ case analyze on reified syntactic versions of those types.

   Thus, to begin, we must define a syntactic representation of some class of datatypes.  In this chapter, our running example will have to do with basic algebraic datatypes, of the kind found in ML and Haskell, but without additional bells and whistles like type parameters and mutually recursive definitions.

   The first step is to define a representation for constructors of our datatypes.  We use the [Record] command as a shorthand for defining an inductive type with a single constructor, plus projection functions for pulling out any of the named arguments to that constructor. *)

(* EX: Define a reified representation of simple algebraic datatypes. *)

(* begin thide *)
Record constructor : Type := Con {
  nonrecursive : Type;
  recursive : nat
}.

(** The idea is that a constructor represented as [Con T n] has [n] arguments of the type that we are defining.  Additionally, all of the other, non-recursive arguments can be encoded in the type [T].  When there are no non-recursive arguments, [T] can be [unit].  When there are two non-recursive arguments, of types [A] and [B], [T] can be [A * B].  We can generalize to any number of arguments via tupling.

   With this definition, it is easy to define a datatype representation in terms of lists of constructors.  The intended meaning is that the datatype came from an inductive definition including exactly the constructors in the list. *)

Definition datatype := list constructor.

(** Here are a few example encodings for some common types from the Coq standard library.  While our syntax type does not support type parameters directly, we can implement them at the meta level, via functions from types to [datatype]s. *)

Definition Empty_set_dt : datatype := nil.
Definition unit_dt : datatype := Con unit 0 :: nil.
Definition bool_dt : datatype := Con unit 0 :: Con unit 0 :: nil.
Definition nat_dt : datatype := Con unit 0 :: Con unit 1 :: nil.
Definition list_dt (A : Type) : datatype := Con unit 0 :: Con A 1 :: nil.

(** The type [Empty_set] has no constructors, so its representation is the empty list.  The type [unit] has one constructor with no arguments, so its one reified constructor indicates no non-recursive data and [0] recursive arguments.  The representation for [bool] just duplicates this single argumentless constructor.    We get from [bool] to [nat] by changing one of the constructors to indicate 1 recursive argument.  We get from [nat] to [list] by adding a non-recursive argument of a parameter type [A].

   As a further example, we can do the same encoding for a generic binary tree type. *)

(* end thide *)

Section tree.
  Variable A : Type.

  Inductive tree : Type :=
  | Leaf : A -> tree
  | Node : tree -> tree -> tree.
End tree.

(* begin thide *)
Definition tree_dt (A : Type) : datatype := Con A 0 :: Con unit 2 :: nil.

(** Each datatype representation stands for a family of inductive types.  For a specific real datatype and a reputed representation for it, it is useful to define a type of _evidence_ that the datatype is compatible with the encoding. *)

Section denote.
  Variable T : Type.
  (** This variable stands for the concrete datatype that we are interested in. *)

  Definition constructorDenote (c : constructor) :=
    nonrecursive c -> ilist T (recursive c) -> T.
  (** We write that a constructor is represented as a function returning a [T].  Such a function takes two arguments, which pack together the non-recursive and recursive arguments of the constructor.  We represent a tuple of all recursive arguments using the length-indexed list type %\index{Gallina terms!ilist}%[ilist] that we met in Chapter 8. *)

  Definition datatypeDenote := hlist constructorDenote.
  (** Finally, the evidence for type [T] is a %\index{Gallina terms!hlist}%heterogeneous list, including a constructor denotation for every constructor encoding in a datatype encoding.  Recall that, since we are inside a section binding [T] as a variable, [constructorDenote] is automatically parameterized by [T]. *)

End denote.
(* end thide *)

(** Some example pieces of evidence should help clarify the convention.  First, we define a helpful notation for constructor denotations.  %The ASCII \texttt{\textasciitilde{}>} from the notation will be rendered later as $\leadsto$.% *)

Notation "[ v , r ~> x ]" := ((fun v r => x) : constructorDenote _ (Con _ _)).

(* begin thide *)
Definition Empty_set_den : datatypeDenote Empty_set Empty_set_dt :=
  HNil.
Definition unit_den : datatypeDenote unit unit_dt :=
  [_, _ ~> tt] ::: HNil.
Definition bool_den : datatypeDenote bool bool_dt :=
  [_, _ ~> true] ::: [_, _ ~> false] ::: HNil.
Definition nat_den : datatypeDenote nat nat_dt :=
  [_, _ ~> O] ::: [_, r ~> S (hd r)] ::: HNil.
Definition list_den (A : Type) : datatypeDenote (list A) (list_dt A) :=
  [_, _ ~> nil] ::: [x, r ~> x :: hd r] ::: HNil.
Definition tree_den (A : Type) : datatypeDenote (tree A) (tree_dt A) :=
  [v, _ ~> Leaf v] ::: [_, r ~> Node (hd r) (hd (tl r))] ::: HNil.
(* end thide *)

(** Recall that the [hd] and [tl] calls above operate on richly typed lists, where type indices tell us the lengths of lists, guaranteeing the safety of operations like [hd].  The type annotation attached to each definition provides enough information for Coq to infer list lengths at appropriate points. *)

(** * Recursive Definitions *)

(* EX: Define a generic [size] function. *)

(** We built these encodings of datatypes to help us write datatype-generic recursive functions.  To do so, we will want a reified representation of a%\index{recursion schemes}% _recursion scheme_ for each type, similar to the [T_rect] principle generated automatically for an inductive definition of [T].  A clever reuse of [datatypeDenote] yields a short definition. *)

(* begin thide *)
Definition fixDenote (T : Type) (dt : datatype) :=
  forall (R : Type), datatypeDenote R dt -> (T -> R).

(** The idea of a recursion scheme is parameterized by a type and a reputed encoding of it.  The principle itself is polymorphic in a type [R], which is the return type of the recursive function that we mean to write.  The next argument is a heterogeneous list of one case of the recursive function definition for each datatype constructor.  The [datatypeDenote] function turns out to have just the right definition to express the type we need; a set of function cases is just like an alternate set of constructors where we replace the original type [T] with the function result type [R].  Given such a reified definition, a [fixDenote] invocation returns a function from [T] to [R], which is just what we wanted.

   We are ready to write some example functions now.  It will be useful to use one new function from the [DepList] library included in the book source. *)

Check hmake.
(** %\vspace{-.15in}% [[
  hmake
     : forall (A : Type) (B : A -> Type),
       (forall x : A, B x) -> forall ls : list A, hlist B ls
       ]]

  The function [hmake] is a kind of [map] alternative that goes from a regular [list] to an [hlist].  We can use it to define a generic size function that counts the number of constructors used to build a value in a datatype. *)

Definition size T dt (fx : fixDenote T dt) : T -> nat :=
  fx nat (hmake (B := constructorDenote nat) (fun _ _ r => foldr plus 1 r) dt).

(** Our definition is parameterized over a recursion scheme [fx].  We instantiate [fx] by passing it the function result type and a set of function cases, where we build the latter with [hmake].  The function argument to [hmake] takes three arguments: the representation of a constructor, its non-recursive arguments, and the results of recursive calls on all of its recursive arguments.  We only need the recursive call results here, so we call them [r] and bind the other two inputs with wildcards.  The actual case body is simple: we add together the recursive call results and increment the result by one (to account for the current constructor).  This [foldr] function is an [ilist]-specific version defined in the [DepList] module.

   It is instructive to build [fixDenote] values for our example types and see what specialized [size] functions result from them. *)

Definition Empty_set_fix : fixDenote Empty_set Empty_set_dt :=
  fun R _ emp => match emp with end.
Eval compute in size Empty_set_fix.
(** %\vspace{-.15in}% [[
     = fun emp : Empty_set => match emp return nat with
                              end
     : Empty_set -> nat
]]

Despite all the fanciness of the generic [size] function, CIC's standard computation rules suffice to normalize the generic function specialization to exactly what we would have written manually. *)

Definition unit_fix : fixDenote unit unit_dt :=
  fun R cases _ => (hhd cases) tt INil.
Eval compute in size unit_fix.
(** %\vspace{-.15in}% [[
     = fun _ : unit => 1
     : unit -> nat
]]

Again normalization gives us the natural function definition.  We see this pattern repeated for our other example types. *)

Definition bool_fix : fixDenote bool bool_dt :=
  fun R cases b => if b
    then (hhd cases) tt INil
    else (hhd (htl cases)) tt INil.
Eval compute in size bool_fix.
(** %\vspace{-.15in}% [[
     = fun b : bool => if b then 1 else 1
     : bool -> nat
]]
*)

Definition nat_fix : fixDenote nat nat_dt :=
  fun R cases => fix F (n : nat) : R :=
    match n with
      | O => (hhd cases) tt INil
      | S n' => (hhd (htl cases)) tt (ICons (F n') INil)
    end.

(** To peek at the [size] function for [nat], it is useful to avoid full computation, so that the recursive definition of addition is not expanded inline.  We can accomplish this with proper flags for the [cbv] reduction strategy. *)

Eval cbv beta iota delta -[plus] in size nat_fix.
(** %\vspace{-.15in}% [[
     = fix F (n : nat) : nat := match n with
                                | 0 => 1
                                | S n' => F n' + 1
                                end
     : nat -> nat
]]
*)

Definition list_fix (A : Type) : fixDenote (list A) (list_dt A) :=
  fun R cases => fix F (ls : list A) : R :=
    match ls with
      | nil => (hhd cases) tt INil
      | x :: ls' => (hhd (htl cases)) x (ICons (F ls') INil)
    end.
Eval cbv beta iota delta -[plus] in fun A => size (@list_fix A).
(** %\vspace{-.15in}% [[
     = fun A : Type =>
       fix F (ls : list A) : nat :=
         match ls with
         | nil => 1
         | _ :: ls' => F ls' + 1
         end
     : forall A : Type, list A -> nat
]]
*)

Definition tree_fix (A : Type) : fixDenote (tree A) (tree_dt A) :=
  fun R cases => fix F (t : tree A) : R :=
    match t with
      | Leaf x => (hhd cases) x INil
      | Node t1 t2 => (hhd (htl cases)) tt (ICons (F t1) (ICons (F t2) INil))
    end.
Eval cbv beta iota delta -[plus] in fun A => size (@tree_fix A).
(** %\vspace{-.15in}% [[
     = fun A : Type =>
       fix F (t : tree A) : nat :=
         match t with
         | Leaf _ => 1
         | Node t1 t2 => F t1 + (F t2 + 1)
         end
     : forall A : Type, tree A -> n
]]
*)
(* end thide *)

(** As our examples show, even recursive datatypes are mapped to normal-looking size functions. *)

(** ** Pretty-Printing *)

(** It is also useful to do generic pretty-printing of datatype values, rendering them as human-readable strings.  To do so, we will need a bit of metadata for each constructor.  Specifically, we need the name to print for the constructor and the function to use to render its non-recursive arguments.  Everything else can be done generically. *)

Record print_constructor (c : constructor) : Type := PI {
  printName : string;
  printNonrec : nonrecursive c -> string
}.

(** It is useful to define a shorthand for applying the constructor [PI].  By applying it explicitly to an unknown application of the constructor [Con], we help type inference work. *)

Notation "^" := (PI (Con _ _)).

(** As in earlier examples, we define the type of metadata for a datatype to be a heterogeneous list type collecting metadata for each constructor. *)

Definition print_datatype := hlist print_constructor.

(** We will be doing some string manipulation here, so we import the notations associated with strings. *)

Local Open Scope string_scope.

(** Now it is easy to implement our generic printer, using another function from [DepList.] *)

Check hmap.
(** %\vspace{-.15in}% [[
  hmap
     : forall (A : Type) (B1 B2 : A -> Type),
       (forall x : A, B1 x -> B2 x) ->
       forall ls : list A, hlist B1 ls -> hlist B2 ls
]]
*)

Definition print T dt (pr : print_datatype dt) (fx : fixDenote T dt) : T -> string :=
  fx string (hmap (B1 := print_constructor) (B2 := constructorDenote string)
    (fun _ pc x r => printName pc ++ "(" ++ printNonrec pc x
      ++ foldr (fun s acc => ", " ++ s ++ acc) ")" r) pr).

(** Some simple tests establish that [print] gets the job done. *)

Eval compute in print HNil Empty_set_fix.
(** %\vspace{-.15in}% [[
     = fun emp : Empty_set => match emp return string with
                              end
     : Empty_set -> string
     ]]
     *)

Eval compute in print (^ "tt" (fun _ => "") ::: HNil) unit_fix.
(** %\vspace{-.15in}% [[
     = fun _ : unit => "tt()"
     : unit -> string
   ]]
   *)

Eval compute in print (^ "true" (fun _ => "")
  ::: ^ "false" (fun _ => "")
  ::: HNil) bool_fix.
(** %\vspace{-.15in}% [[
   = fun b : bool => if b then "true()" else "false()"
   : bool -> string
   ]]
   *)

Definition print_nat := print (^ "O" (fun _ => "")
  ::: ^ "S" (fun _ => "")
  ::: HNil) nat_fix.
Eval cbv beta iota delta -[append] in print_nat.
(** %\vspace{-.15in}% [[
     = fix F (n : nat) : string :=
         match n with
         | 0%nat => "O" ++ "(" ++ "" ++ ")"
         | S n' => "S" ++ "(" ++ "" ++ ", " ++ F n' ++ ")"
         end
     : nat -> string
     ]]
     *)

Eval simpl in print_nat 0.
(** %\vspace{-.15in}% [[
     = "O()"
     : string
     ]]
     *)

Eval simpl in print_nat 1.
(** %\vspace{-.15in}% [[
     = "S(, O())"
     : string
     ]]
     *)

Eval simpl in print_nat 2.
(** %\vspace{-.15in}% [[
     = "S(, S(, O()))"
     : string
     ]]
     *)

Eval cbv beta iota delta -[append] in fun A (pr : A -> string) =>
  print (^ "nil" (fun _ => "")
  ::: ^ "cons" pr
  ::: HNil) (@list_fix A).
(** %\vspace{-.15in}% [[
     = fun (A : Type) (pr : A -> string) =>
       fix F (ls : list A) : string :=
         match ls with
         | nil => "nil" ++ "(" ++ "" ++ ")"
         | x :: ls' => "cons" ++ "(" ++ pr x ++ ", " ++ F ls' ++ ")"
         end
     : forall A : Type, (A -> string) -> list A -> string
     ]]
     *)

Eval cbv beta iota delta -[append] in fun A (pr : A -> string) =>
  print (^ "Leaf" pr
  ::: ^ "Node" (fun _ => "")
  ::: HNil) (@tree_fix A).
(** %\vspace{-.15in}% [[
     = fun (A : Type) (pr : A -> string) =>
       fix F (t : tree A) : string :=
         match t with
         | Leaf x => "Leaf" ++ "(" ++ pr x ++ ")"
         | Node t1 t2 =>
             "Node" ++ "(" ++ "" ++ ", " ++ F t1 ++ ", " ++ F t2 ++ ")"
         end
     : forall A : Type, (A -> string) -> tree A -> string
     ]]
     *)

(* begin hide *)
(* begin thide *)
Definition append' := append.
(* end thide *)
(* end hide *)

(** Some of these simplified terms seem overly complex because we have turned off simplification of calls to [append], which is what uses of the [++] operator desugar to.  Selective [++] simplification would combine adjacent string literals, yielding more or less the code we would write manually to implement this printing scheme. *)

(** ** Mapping *)

(** By this point, we have developed enough machinery that it is old hat to define a generic function similar to the list [map] function. *)

Definition map T dt (dd : datatypeDenote T dt) (fx : fixDenote T dt) (f : T -> T)
  : T -> T :=
  fx T (hmap (B1 := constructorDenote T) (B2 := constructorDenote T)
    (fun _ c x r => f (c x r)) dd).

Eval compute in map Empty_set_den Empty_set_fix.
(** %\vspace{-.15in}% [[
     = fun (_ : Empty_set -> Empty_set) (emp : Empty_set) =>
       match emp return Empty_set with
       end
     : (Empty_set -> Empty_set) -> Empty_set -> Empty_set
     ]]
     *)

Eval compute in map unit_den unit_fix.
(** %\vspace{-.15in}% [[
     = fun (f : unit -> unit) (_ : unit) => f tt
     : (unit -> unit) -> unit -> unit
     ]]
     *)

Eval compute in map bool_den bool_fix.
(** %\vspace{-.15in}% [[
     = fun (f : bool -> bool) (b : bool) => if b then f true else f false
     : (bool -> bool) -> bool -> bool
     ]]
     *)

Eval compute in map nat_den nat_fix.
(** %\vspace{-.15in}% [[
     = fun f : nat -> nat =>
       fix F (n : nat) : nat :=
         match n with
         | 0%nat => f 0%nat
         | S n' => f (S (F n'))
         end
     : (nat -> nat) -> nat -> nat
     ]]
     *)

Eval compute in fun A => map (list_den A) (@list_fix A).
(** %\vspace{-.15in}% [[
     = fun (A : Type) (f : list A -> list A) =>
       fix F (ls : list A) : list A :=
         match ls with
         | nil => f nil
         | x :: ls' => f (x :: F ls')
         end
     : forall A : Type, (list A -> list A) -> list A -> list A
     ]]
     *)

Eval compute in fun A => map (tree_den A) (@tree_fix A).
(** %\vspace{-.15in}% [[
     = fun (A : Type) (f : tree A -> tree A) =>
       fix F (t : tree A) : tree A :=
         match t with
         | Leaf x => f (Leaf x)
         | Node t1 t2 => f (Node (F t1) (F t2))
         end
     : forall A : Type, (tree A -> tree A) -> tree A -> tree A
     ]]
     *)

(** These [map] functions are just as easy to use as those we write by hand.  Can you figure out the input-output pattern that [map_nat S] displays in these examples? *)

Definition map_nat := map nat_den nat_fix.
Eval simpl in map_nat S 0.
(** %\vspace{-.15in}% [[
     = 1%nat
     : nat
     ]]
     *)

Eval simpl in map_nat S 1.
(** %\vspace{-.15in}% [[
     = 3%nat
     : nat
     ]]
     *)

Eval simpl in map_nat S 2.
(** %\vspace{-.15in}% [[
     = 5%nat
     : nat
     ]]
     *)

(** We get [map_nat S n] = [2 * n + 1], because the mapping process adds an extra [S] at every level of the inductive tree that defines a natural, including at the last level, the [O] constructor. *)

(** * Proving Theorems about Recursive Definitions *)

(** We would like to be able to prove theorems about our generic functions.  To do so, we need to establish additional well-formedness properties that must hold of pieces of evidence. *)

Section ok.
  Variable T : Type.
  Variable dt : datatype.

  Variable dd : datatypeDenote T dt.
  Variable fx : fixDenote T dt.

  (** First, we characterize when a piece of evidence about a datatype is acceptable.  The basic idea is that the type [T] should really be an inductive type with the definition given by [dd].  Semantically, inductive types are characterized by the ability to do induction on them.  Therefore, we require that the usual induction principle is true, with respect to the constructors given in the encoding [dd]. *)

  Definition datatypeDenoteOk :=
    forall P : T -> Prop,
      (forall c (m : member c dt) (x : nonrecursive c) (r : ilist T (recursive c)),
        (forall i : fin (recursive c), P (get r i))
        -> P ((hget dd m) x r))
      -> forall v, P v.

  (** This definition can take a while to digest.  The quantifier over [m : member c dt] is considering each constructor in turn; like in normal induction principles, each constructor has an associated proof case.  The expression [hget dd m] then names the constructor we have selected.  After binding [m], we quantify over all possible arguments (encoded with [x] and [r]) to the constructor that [m] selects.  Within each specific case, we quantify further over [i : fin (recursive c)] to consider all of our induction hypotheses, one for each recursive argument of the current constructor.

     We have completed half the burden of defining side conditions.  The other half comes in characterizing when a recursion scheme [fx] is valid.  The natural condition is that [fx] behaves appropriately when applied to any constructor application. *)

  Definition fixDenoteOk :=
    forall (R : Type) (cases : datatypeDenote R dt)
      c (m : member c dt)
      (x : nonrecursive c) (r : ilist T (recursive c)),
      fx cases ((hget dd m) x r)
      = (hget cases m) x (imap (fx cases) r).

  (** As for [datatypeDenoteOk], we consider all constructors and all possible arguments to them by quantifying over [m], [x], and [r].  The lefthand side of the equality that follows shows a call to the recursive function on the specific constructor application that we selected.  The righthand side shows an application of the function case associated with constructor [m], applied to the non-recursive arguments and to appropriate recursive calls on the recursive arguments. *)

End ok.

(** We are now ready to prove that the [size] function we defined earlier always returns positive results.  First, we establish a simple lemma. *)

(* begin thide *)
Lemma foldr_plus : forall n (ils : ilist nat n),
  foldr plus 1 ils > 0.
  induction ils; crush.
Qed.
(* end thide *)

Theorem size_positive : forall T dt
  (dd : datatypeDenote T dt) (fx : fixDenote T dt)
  (dok : datatypeDenoteOk dd) (fok : fixDenoteOk dd fx)
  (v : T),
  size fx v > 0.
(* begin thide *)
  unfold size; intros.
  (** [[
  ============================
   fx nat
     (hmake
        (fun (x : constructor) (_ : nonrecursive x)
           (r : ilist nat (recursive x)) => foldr plus 1%nat r) dt) v > 0
    ]]

    Our goal is an inequality over a particular call to [size], with its definition expanded.  How can we proceed here?  We cannot use [induction] directly, because there is no way for Coq to know that [T] is an inductive type.  Instead, we need to use the induction principle encoded in our hypothesis [dok] of type [datatypeDenoteOk dd].  Let us try applying it directly.
    [[
  apply dok.
    ]]
%\vspace{-.3in}%
<<
Error: Impossible to unify "datatypeDenoteOk dd" with
 "fx nat
    (hmake
       (fun (x : constructor) (_ : nonrecursive x)
          (r : ilist nat (recursive x)) => foldr plus 1%nat r) dt) v > 0".
>>

    Matching the type of [dok] with the type of our conclusion requires more than simple first-order unification, so [apply] is not up to the challenge.  We can use the %\index{tactics!pattern}%[pattern] tactic to get our goal into a form that makes it apparent exactly what the induction hypothesis is. *)

  pattern v.
  (** %\vspace{-.15in}%[[
  ============================
   (fun t : T =>
    fx nat
      (hmake
         (fun (x : constructor) (_ : nonrecursive x)
            (r : ilist nat (recursive x)) => foldr plus 1%nat r) dt) t > 0) v
      ]]
      *)

  apply dok; crush.
  (** %\vspace{-.15in}%[[
  H : forall i : fin (recursive c),
      fx nat
        (hmake
           (fun (x : constructor) (_ : nonrecursive x)
              (r : ilist nat (recursive x)) => foldr plus 1%nat r) dt)
        (get r i) > 0
  ============================
   hget
     (hmake
        (fun (x0 : constructor) (_ : nonrecursive x0)
           (r0 : ilist nat (recursive x0)) => foldr plus 1%nat r0) dt) m x
     (imap
        (fx nat
           (hmake
              (fun (x0 : constructor) (_ : nonrecursive x0)
                 (r0 : ilist nat (recursive x0)) =>
               foldr plus 1%nat r0) dt)) r) > 0
    ]]

    An induction hypothesis [H] is generated, but we turn out not to need it for this example.  We can simplify the goal using a library theorem about the composition of [hget] and [hmake]. *)

  rewrite hget_hmake.
  (** %\vspace{-.15in}%[[
  ============================
   foldr plus 1%nat
     (imap
        (fx nat
           (hmake
              (fun (x0 : constructor) (_ : nonrecursive x0)
                 (r0 : ilist nat (recursive x0)) =>
               foldr plus 1%nat r0) dt)) r) > 0
    ]]

    The lemma we proved earlier finishes the proof. *)

  apply foldr_plus.

  (** Using hints, we can redo this proof in a nice automated form. *)

  Restart.

  Hint Rewrite hget_hmake.
  Hint Resolve foldr_plus.

  unfold size; intros; pattern v; apply dok; crush.
Qed.
(* end thide *)

(** It turned out that, in this example, we only needed to use induction degenerately as case analysis.  A more involved theorem may only be proved using induction hypotheses.  We will give its proof only in unautomated form and leave effective automation as an exercise for the motivated reader.

   In particular, it ought to be the case that generic [map] applied to an identity function is itself an identity function. *)

Theorem map_id : forall T dt
  (dd : datatypeDenote T dt) (fx : fixDenote T dt)
  (dok : datatypeDenoteOk dd) (fok : fixDenoteOk dd fx)
  (v : T),
  map dd fx (fun x => x) v = v.
(* begin thide *)
  (** Let us begin as we did in the last theorem, after adding another useful library equality as a hint. *)

  Hint Rewrite hget_hmap.

  unfold map; intros; pattern v; apply dok; crush.
  (** %\vspace{-.15in}%[[
  H : forall i : fin (recursive c),
      fx T
        (hmap
           (fun (x : constructor) (c : constructorDenote T x)
              (x0 : nonrecursive x) (r : ilist T (recursive x)) =>
            c x0 r) dd) (get r i) = get r i
  ============================
   hget dd m x
     (imap
        (fx T
           (hmap
              (fun (x0 : constructor) (c0 : constructorDenote T x0)
                 (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
               c0 x1 r0) dd)) r) = hget dd m x r
    ]]

    Our goal is an equality whose two sides begin with the same function call and initial arguments.  We believe that the remaining arguments are in fact equal as well, and the [f_equal] tactic applies this reasoning step for us formally. *)

  f_equal.
  (** %\vspace{-.15in}%[[
  ============================
   imap
     (fx T
        (hmap
           (fun (x0 : constructor) (c0 : constructorDenote T x0)
              (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
            c0 x1 r0) dd)) r = r
    ]]

    At this point, it is helpful to proceed by an inner induction on the heterogeneous list [r] of recursive call results.  We could arrive at a cleaner proof by breaking this step out into an explicit lemma, but here we will do the induction inline to save space.*)

  induction r; crush.

  (* begin hide *)
  (* begin thide *)
  Definition pred' := pred.
  (* end thide *)
  (* end hide *)

  (** The base case is discharged automatically, and the inductive case looks like this, where [H] is the outer IH (for induction over [T] values) and [IHr] is the inner IH (for induction over the recursive arguments).
     [[
  H : forall i : fin (S n),
      fx T
        (hmap
           (fun (x : constructor) (c : constructorDenote T x)
              (x0 : nonrecursive x) (r : ilist T (recursive x)) =>
            c x0 r) dd)
        (match i in (fin n') return ((fin (pred n') -> T) -> T) with
         | First n => fun _ : fin n -> T => a
         | Next n idx' => fun get_ls' : fin n -> T => get_ls' idx'
         end (get r)) =
      match i in (fin n') return ((fin (pred n') -> T) -> T) with
      | First n => fun _ : fin n -> T => a
      | Next n idx' => fun get_ls' : fin n -> T => get_ls' idx'
      end (get r)
  IHr : (forall i : fin n,
         fx T
           (hmap
              (fun (x : constructor) (c : constructorDenote T x)
                 (x0 : nonrecursive x) (r : ilist T (recursive x)) =>
               c x0 r) dd) (get r i) = get r i) ->
        imap
          (fx T
             (hmap
                (fun (x : constructor) (c : constructorDenote T x)
                   (x0 : nonrecursive x) (r : ilist T (recursive x)) =>
                 c x0 r) dd)) r = r
  ============================
   ICons
     (fx T
        (hmap
           (fun (x0 : constructor) (c0 : constructorDenote T x0)
              (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
            c0 x1 r0) dd) a)
     (imap
        (fx T
           (hmap
              (fun (x0 : constructor) (c0 : constructorDenote T x0)
                 (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
               c0 x1 r0) dd)) r) = ICons a r
    ]]

    We see another opportunity to apply [f_equal], this time to split our goal into two different equalities over corresponding arguments.  After that, the form of the first goal matches our outer induction hypothesis [H], when we give type inference some help by specifying the right quantifier instantiation. *)

  f_equal.
  apply (H First).
  (** %\vspace{-.15in}%[[
  ============================
   imap
     (fx T
        (hmap
           (fun (x0 : constructor) (c0 : constructorDenote T x0)
              (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
            c0 x1 r0) dd)) r = r
    ]]

    Now the goal matches the inner IH [IHr]. *)

  apply IHr; crush.
  (** %\vspace{-.15in}%[[
  i : fin n
  ============================
   fx T
     (hmap
        (fun (x0 : constructor) (c0 : constructorDenote T x0)
           (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
         c0 x1 r0) dd) (get r i) = get r i
    ]]

    We can finish the proof by applying the outer IH again, specialized to a different [fin] value. *)

  apply (H (Next i)).
Qed.
(* end thide *)

(** The proof involves complex subgoals, but, still, few steps are required, and then we may reuse our work across a variety of datatypes. *)


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 C I P : Universe, ((wd_ B I /\ (wd_ I C /\ (wd_ B C /\ (wd_ C P /\ (wd_ B P /\ (wd_ A I /\ (wd_ I P /\ (wd_ A P /\ (col_ B I C /\ col_ C I P))))))))) -> col_ B C P)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint even (even_arg0 : natural) : bool
           := match even_arg0 with
              | Zero => true
              | Succ n => negb (even n)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.
Lemma negb_invol: forall b, negb (negb b) = b.
Proof.
   intros.
   induction b.
   - simpl. auto.
   - simpl. auto.
Qed.

Theorem theorem0 : forall (w : lst) (z : lst) (x : natural) (y : natural), eq (even (len (append w z))) (even (len (append w (Cons x (Cons y z))))).
Proof.
   intros.
   induction w.
   - simpl. rewrite IHw. reflexivity.
   - simpl. lfind. Admitted.


Add LoadPath "../..".
Require Import Setoid.
Require Export LibTactics.
Require Export HybND_Shared.
Require Export ListLib.
Require Export PermutLib.

Open Scope permut_scope.

Inductive PPermut_Hyb: list ctx_Hyb -> list ctx_Hyb -> Prop :=
| PPermut_Hyb_nil: PPermut_Hyb nil nil
| PPermut_Hyb_skip: forall G G' w Gamma Gamma',
    Gamma *=* Gamma' ->
    PPermut_Hyb G G' ->
    PPermut_Hyb ((w, Gamma)::G) ((w,Gamma')::G')
| PPermut_Hyb_swap: forall G w w' Gamma0 Gamma0' Gamma1 Gamma1',
    Gamma0 *=* Gamma1 ->
    Gamma0' *=* Gamma1' ->
    PPermut_Hyb ((w, Gamma0) :: (w', Gamma0') :: G)
                ((w', Gamma1') :: (w, Gamma1) :: G)
| PPermut_Hyb_trans: forall G G' G'',
    PPermut_Hyb G G' -> PPermut_Hyb G' G'' -> PPermut_Hyb G G''.
Hint Resolve PPermut_Hyb_nil PPermut_Hyb_skip PPermut_Hyb_swap.
Hint Constructors PPermut_Hyb : ppermut_rew.

Notation "G ~=~ G'" := (PPermut_Hyb G G') (at level 70) : permut_scope.

Lemma PPermut_Hyb_reflexive:
  Reflexive PPermut_Hyb.
unfold Reflexive; intros;
induction x; [ | destruct a]; eauto.
Qed.

Lemma PPermut_Hyb_symmetric:
  Symmetric PPermut_Hyb.
unfold Symmetric; intros;
induction H; eauto with ppermut_rew.
  apply PPermut_Hyb_trans with (G':=(w, Gamma')::G); eauto with ppermut_rew;
  apply PPermut_Hyb_skip;
  [ apply permut_sym |
    apply PPermut_Hyb_reflexive];
  auto.
  apply PPermut_Hyb_swap; apply permut_sym; assumption.
Qed.

Lemma PPermut_Hyb_transitive:
  Transitive PPermut_Hyb.
exact PPermut_Hyb_trans.
Qed.
Hint Resolve PPermut_Hyb_reflexive PPermut_Hyb_symmetric.

Theorem PPermut_Hyb'oid: Setoid_Theory _ PPermut_Hyb.
  split.
  exact PPermut_Hyb_reflexive.
  exact PPermut_Hyb_symmetric.
  exact PPermut_Hyb_transitive.
Qed.

Add Setoid (list ctx_Hyb) PPermut_Hyb PPermut_Hyb'oid as PPermut_Hyboid.

Add Morphism (@cons ctx_Hyb) : PPermut_Hyb_cons.
intro y; destruct y; auto.
Qed.
Hint Resolve PPermut_Hyb_cons.

Lemma PPermut_Hyb_app_tail:
forall G G' G0,
  G ~=~ G' ->
  G ++ G0 ~=~ G' ++ G0.
intros; induction H; simpl; rew_app; auto;
econstructor; eauto.
Qed.

Lemma PPermut_Hyb_app_head:
forall G0 G G',
  G ~=~ G' ->
  G0 ++ G ~=~ G0 ++ G'.
intros; induction G0; simpl; rew_app; auto.
Qed.
Hint Resolve PPermut_Hyb_app_tail PPermut_Hyb_app_head.

Add Morphism (@append ctx_Hyb) : PPermut_Hyb_app.
intros; induction H; simpl in *; rew_app; auto.
transitivity ((w, Gamma0) :: (w', Gamma0') :: G ++ y0); auto.
transitivity (G' ++ y0); auto.
Qed.
Hint Resolve PPermut_Hyb_app.

Theorem PPermut_Hyb_app_comm:
forall G1 G2,
  G1 ++ G2 ~=~ G2 ++ G1.
induction G1; intros; simpl; rew_app;
[ auto |
 induction G2]; simpl in *;
[ rewrite app_nil_r; auto |
  destruct a; destruct a0];
transitivity ((v,l) :: (v0, l0) :: G2 ++ G1);
[ constructor; auto; apply IHG1 |
  transitivity ((v0, l0) :: (v, l) :: G2 ++ G1); auto];
rew_app; constructor; auto;
transitivity ((v,l) :: G1 ++ G2); auto.
Qed.
Hint Resolve PPermut_Hyb_app_comm.

(*** Automation **)
(* Based on permutation tactics from tlc's LibListSorted *)

Lemma PPermut_Hyb_get_1 : forall l1 l2,
  PPermut_Hyb (l1 ++ l2) (l1 ++ l2).
auto.
Qed.

Lemma PPermut_Hyb_get_2 : forall l1 l2 l3,
  PPermut_Hyb (l1 ++ l2 ++ l3) (l2 ++ l1 ++ l3).
intros;
assert (l1 ++ l2 ~=~ l2 ++ l1) as H by auto;
transitivity ((l1 ++ l2) ++ l3); [ | rewrite H ]; rew_app; auto.
Qed.

Lemma PPermut_Hyb_get_3 : forall l1 l2 l3 l4,
  PPermut_Hyb (l1 ++ l2 ++ l3 ++ l4) (l2 ++ l3 ++ l1 ++ l4).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_Hyb_get_2.
Qed.

Lemma PPermut_Hyb_get_4 : forall l1 l2 l3 l4 l5,
  PPermut_Hyb (l1 ++ l2 ++ l3 ++ l4 ++ l5)
         (l2 ++ l3 ++ l4 ++ l1 ++ l5).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_Hyb_get_3.
Qed.

Lemma PPermut_Hyb_get_5 : forall l1 l2 l3 l4 l5 l6,
  PPermut_Hyb (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6)
         (l2 ++ l3 ++ l4 ++ l5 ++ l1 ++ l6).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_Hyb_get_4.
Qed.

Lemma PPermut_Hyb_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
  PPermut_Hyb (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l7)
         (l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l1 ++ l7).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_Hyb_get_5.
Qed.

Lemma PPermut_Hyb_tactic_setup : forall l1 l2,
  PPermut_Hyb (nil ++ l1 ++ nil) (l2 ++ nil) -> PPermut_Hyb l1 l2.
intros; rew_app in *; auto.
Qed.

Lemma PPermut_Hyb_tactic_keep : forall l1 l2 l3 l4,
  PPermut_Hyb ((l1 ++ l2) ++ l3) l4 ->
  PPermut_Hyb (l1 ++ (l2 ++ l3)) l4.
intros; rew_app in *; auto.
Qed.

Lemma PPermut_Hyb_tactic_simpl : forall l1 l2 l3 l4,
  PPermut_Hyb (l1 ++ l3) l4 ->
  PPermut_Hyb (l1 ++ (l2 ++ l3)) (l2 ++ l4).
intros; rewrite <- H; apply PPermut_Hyb_get_2.
Qed.

Lemma PPermut_Hyb_tactic_trans : forall l1 l2 l3,
  PPermut_Hyb l3 l2 -> PPermut_Hyb l1 l3 -> PPermut_Hyb l1 l2.
intros; eauto with ppermut_rew.
Qed.

Hint Rewrite app_assoc app_nil_l app_nil_r : ppermut_rew.

Ltac PPermut_Hyb_lemma_get n :=
  match nat_from_number n with
  | 1 => constr:(PPermut_Hyb_get_1)
  | 2 => constr:(PPermut_Hyb_get_2)
  | 3 => constr:(PPermut_Hyb_get_3)
  | 4 => constr:(PPermut_Hyb_get_4)
  | 5 => constr:(PPermut_Hyb_get_5)
  end.

Ltac PPermut_Hyb_isolate_cons :=
  do 20 try (* todo : repeat *)
    match goal with |- context [?x::?l] =>
      match l with
      | nil => fail 1
      | _ => rewrite <- (@app_cons_one _ x l)
      end
    end.

Ltac PPermut_Hyb_simpl_prepare :=
   autorewrite with ppermut_rew;
   PPermut_Hyb_isolate_cons;
   autorewrite with ppermut_rew;
   apply PPermut_Hyb_tactic_setup;
   repeat rewrite app_assoc.

Ltac PPermut_Hyb_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l ++ _ => constr:(1)
  | _ ++ l ++ _ => constr:(2)
  | _ ++ _ ++ l ++ _ => constr:(3)
  | _ ++ _ ++ _ ++ l ++ _ => constr:(4)
  | _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(5)
  | _ ++ _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(6)
  | _ => constr:(0) (* not found *)
  end.

Ltac PPermut_Hyb_simpl_once :=
  match goal with
  | |- PPermut_Hyb (_ ++ nil) _ => fail 1
  | |- PPermut_Hyb (_ ++ (?l ++ _)) ?l' =>
     match PPermut_Hyb_index_of l l' with
     | 0 => apply PPermut_Hyb_tactic_keep
     | ?n => let F := PPermut_Hyb_lemma_get n in
            eapply PPermut_Hyb_tactic_trans;
            [ apply F
            | apply PPermut_Hyb_tactic_simpl ]
     end
  end.

Ltac PPermut_Hyb_simpl :=
  PPermut_Hyb_simpl_prepare;
  repeat PPermut_Hyb_simpl_once;
  autorewrite with ppermut_rew;
  try apply PPermut_Hyb_reflexive;
  auto.

(*** Other lemmas ***)
(* Note:
   Some are covered by PPermut_Hyb_simpl tactic, but we want to use them
   in auto! *)

Lemma PPermut_Hyb_Mem:
forall G G' w X,
  G ~=~ G' ->
  Mem (w, X) G ->
  exists X', X' *=* X /\ Mem (w, X') G'.
intros; generalize dependent X; induction H; intros.
rewrite Mem_nil_eq in H0; contradiction.
rewrite Mem_cons_eq in H1; destruct H1.
inversion H1; subst; exists Gamma'; split; [ symmetry | apply Mem_here]; auto.
apply IHPPermut_Hyb in H1; destruct H1 as (Gamma''); exists Gamma'';
destruct H1; split; auto; rewrite Mem_cons_eq; right; auto.
repeat rewrite Mem_cons_eq in H1; destruct H1.
inversion H1; subst; exists Gamma1; split; [ symmetry | rewrite Mem_cons_eq];
auto; right; apply Mem_here.
destruct H1.
inversion H1; subst; exists Gamma1'; split; [ symmetry | rewrite Mem_cons_eq];
auto.
exists X; split; auto; repeat rewrite Mem_cons_eq; right; right; auto.
apply IHPPermut_Hyb1 in H1; destruct H1 as (X'); destruct H1.
apply IHPPermut_Hyb2 in H2; destruct H2 as (X''); destruct H2;
exists X''; split; auto; transitivity X'; auto.
Qed.

Lemma PPermut_Hyb_nil_impl:
forall L,
  nil ~=~ L -> L = nil.
intros; remember (@nil ctx_Hyb) as L' in H;
induction H; intros;
discriminate || auto.
Qed.

Lemma PPermut_Hyb_nil_contr:
forall L a,
  ~ (PPermut_Hyb nil (a::L)).
induction L; intros; intro;
apply PPermut_Hyb_nil_impl in H; discriminate.
Qed.

Hint Resolve PPermut_Hyb_nil_impl PPermut_Hyb_nil_contr.

(* Based on Sorting/Permutation/Permutation_ind_bis *)
Theorem PPermut_Hyb_ind_bis :
 forall P : list ctx_Hyb -> list ctx_Hyb -> Prop,
   P nil nil ->
   (forall w x y l l', l ~=~ l' -> P l l' ->
     x *=* y -> P ((w,x) :: l) ((w,y) :: l')) ->
   (forall w w' x x' y y' l l', l ~=~ l' -> P l l' -> x *=* x' -> y *=* y' ->
     P ((w', y) :: (w, x) :: l) ((w, x') :: (w', y') :: l')) ->
   (forall l l' l'', l ~=~ l' -> P l l' -> l' ~=~ l'' -> P l' l'' -> P l l'') ->
   forall l l', l ~=~ l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans;
  intros; induction H; auto.
  apply Htrans with ((w', Gamma0')::(w, Gamma0)::G); auto.
    apply Hswap; auto; induction G; auto; destruct a; apply Hskip; auto.
    apply Hskip; auto; apply Hskip; auto; induction G; auto;
    destruct a; apply Hskip; auto.
  eauto.
Qed.

Lemma PPermut_Hyb_app_rev:
forall G G' H H' w a a',
  a *=* a' ->
  G & (w, a) ++ G' ~=~ H & (w, a') ++ H' ->
  G ++ G' ~=~ H ++ H'.
Proof.
  set (P l l' :=
         forall w a a' l1 l2 l3 l4, a *=* a' ->
         l=l1 & (w, a) ++ l2 -> l'=l3 & (w, a') ++l4 -> (l1++l2) ~=~ (l3++l4)).
  cut (forall l l', l ~=~ l' -> P l l').
  intros; apply (H _ _ H2 w a a'); auto.
  intros; apply (PPermut_Hyb_ind_bis P); unfold P; clear P;
    try clear H l l'; simpl; auto.
  (* nil *)
  intros; destruct l1; simpl in *; discriminate.
  (* skip *)
  intros w x y l l' H IH; intros.
  destruct l1; destruct l3; rew_app in *;
  inversion H2; inversion H3; subst; auto.
    rewrite H; PPermut_Hyb_simpl; constructor; [transitivity a |] ; auto;
      symmetry; auto.
    rewrite <- H; PPermut_Hyb_simpl; constructor; auto; transitivity a';
      [ | symmetry]; auto.
  constructor; auto.
  apply (IH w0 a a' l1 l2 l3 l4); rew_app; auto.
  (* swap *)
  intros w w' x x' y y' l l' Hp IH; intros.
  destruct l1; destruct l2; rew_app in *; subst;
  inversion H2; subst; auto; try rewrite Hp; rew_app;
  PPermut_Hyb_simpl; destruct l3; destruct l4; rew_app in *; subst;
  inversion H3; subst; auto.
    constructor; auto; transitivity a'; auto; transitivity a; auto;
    symmetry; auto.
    constructor; auto; destruct l3; rew_app in *; inversion H6; subst; auto;
      PPermut_Hyb_simpl; constructor; auto; transitivity a; auto; symmetry; auto.
    constructor; auto; destruct l3; rew_app in *; inversion H6; subst; auto;
      PPermut_Hyb_simpl; constructor; auto; transitivity a; auto; symmetry; auto.
    constructor; auto; destruct l1; rew_app in *; inversion H6; subst; auto;
      PPermut_Hyb_simpl; rewrite <- Hp; PPermut_Hyb_simpl; constructor; auto;
      transitivity a'; auto; symmetry; auto.
  destruct l1; destruct l3; rew_app in *; inversion H6; inversion H7; subst;
    auto.
      constructor; auto; transitivity a'; auto; transitivity a; auto;
        symmetry; auto.
       apply PPermut_Hyb_nil_impl in Hp; destruct l3; rew_app in *; discriminate.
       symmetry in Hp; apply PPermut_Hyb_nil_impl in Hp; destruct l1;
         rew_app in *; discriminate.
       transitivity ((w', y') :: (w, x') :: l1).
         constructor; [ | constructor]; auto.
         PPermut_Hyb_simpl.
       replace l1 with (l1 ++ nil) by (rew_app; auto);
       replace l3 with (l3 ++ nil) by (rew_app; auto);
       apply IH with (w:=w0) (a0:=a) (a'0:=a'); auto;
         rew_app; auto.
  destruct l1; destruct l3; rew_app in *; inversion H6; inversion H7; subst;
    auto.
       apply PPermut_Hyb_nil_impl in Hp; discriminate.
       apply PPermut_Hyb_nil_impl in Hp; destruct l3; rew_app in *; discriminate.
       rewrite <- Hp; PPermut_Hyb_simpl; transitivity ((w,x)::(w0,y)::nil);
         PPermut_Hyb_simpl; constructor; auto; constructor; auto;
         transitivity a'; auto; symmetry; auto.
       transitivity ((w',y')::(w,x')::l1); auto; PPermut_Hyb_simpl; rew_app;
       replace l1 with (l1 ++ nil) by (rew_app; auto);
       apply IH with (w:=w0) (a0:=a) (a'0:=a'); auto;
         rew_app; auto.
  constructor; auto; rewrite <- Hp; symmetry; destruct l1; rew_app in *;
    inversion H6; subst; auto; PPermut_Hyb_simpl; constructor; auto;
    transitivity a'; auto; symmetry; auto.
  destruct l3; rew_app in *; inversion H7; subst.
    symmetry in Hp; apply PPermut_Hyb_nil_impl in Hp; subst; inversion H6; subst;
      destruct l1; rew_app in *; inversion H6; subst; destruct l1; rew_app in *;
      discriminate.
    transitivity ((w', y') ::l1 ++ p0 :: l2); PPermut_Hyb_simpl; rew_app.
    destruct l1; rew_app in *; inversion H6; subst.
      rewrite Hp; PPermut_Hyb_simpl; constructor; auto; transitivity a; auto;
      symmetry; auto.
      constructor; auto; replace l3 with (l3 ++ nil) by (rew_app; auto);
      apply IH with (w:=w0) (a0:=a) (a'0:=a'); auto; rew_app; auto.
  clear H2 H3. destruct l1; destruct l3; rew_app in *; inversion H6;
  inversion H7; subst.
    constructor; auto; transitivity a; auto; transitivity a'; auto;
    symmetry; auto.
    transitivity ((w', y'):: p0 :: l2).
      constructor; auto.
      PPermut_Hyb_simpl. clear H6 H7. rew_app; rewrite Hp; PPermut_Hyb_simpl;
      constructor; auto; transitivity a; auto; symmetry; auto.
    transitivity ((w, x)::p1::l4).
      PPermut_Hyb_simpl; rew_app; rewrite <- Hp; PPermut_Hyb_simpl; constructor;
        auto; transitivity a'; auto; symmetry; auto.
      constructor; auto.
    transitivity ((w', y') :: (w, x') :: l1 ++ p0 :: l2).
      constructor; auto; constructor; auto.
      PPermut_Hyb_simpl. clear H7 H6. rew_app.
    apply IH with (w:=w0) (a0:=a) (a'0:=a'); rew_app; auto.
  (* trans *)
  intros. destruct (PPermut_Hyb_Mem l l' w a) as (a'', (H6a, H6b)); auto.
    subst; rewrite Mem_app_or_eq; left; rewrite Mem_app_or_eq; right;
      apply Mem_here.
  destruct (Mem_split ctx_Hyb l' (w, a'')) as (l'1, (l'2, H6)); auto.
  transitivity (l'1 ++ l'2).
    apply H0 with (w:=w) (a:=a) (a':=a''); [ symmetry | | ]; auto.
    apply H2 with (w:=w) (a:=a'') (a':=a').
      transitivity a; auto; symmetry; auto.
      auto.
      auto.
Qed.

Lemma PPermut_Hyb_last_rev_simpl:
forall G G' a,
  G & a ~=~ G' & a ->
  G ~=~ G'.
intros; replace G with (G ++ nil) by (rew_app; auto);
replace G' with (G'++nil) by (rew_app; auto);
destruct a;
apply PPermut_Hyb_app_rev with (w:=v)(a:=l)(a':=l); rew_app; eauto.
Qed.

Lemma PPermut_Hyb_last_rev:
forall G G' w Gamma Gamma',
  Gamma *=* Gamma' ->
  G & (w, Gamma) ~=~ G' & (w, Gamma') ->
  G ~=~ G'.
intros;
assert (G & (w, Gamma) ~=~ G' & (w, Gamma)) by eauto with ppermut_rew;
apply PPermut_Hyb_last_rev_simpl with (a:=(w, Gamma)); auto.
Qed.

Lemma PPermut_Hyb_split_head:
forall G G' w Gamma,
  (w, Gamma) :: G ~=~ G' ->
  exists Gamma' hd tl,
    Gamma *=* Gamma' /\ G' = hd & (w, Gamma') ++ tl.
intros.
apply PPermut_Hyb_Mem with (w:=w) (X:=Gamma) in H.
destruct H as (Gamma'); destruct H.
exists Gamma'.
assert (exists hd, exists tl, G' = hd & (w, Gamma') ++ tl) by
  (eapply Mem_split; auto).
destruct H1 as (hd, (tl, H1));
exists hd; exists tl; split; [symmetry | ]; auto.
apply Mem_here.
Qed.

Lemma PPermut_Hyb_split_neq:
forall G G' w w' Gamma Gamma',
  G & (w, Gamma) ~=~ G' & (w', Gamma') ->
  ~Gamma *=* Gamma' \/ w <> w' ->
  exists Gamma0, exists GH, exists GT,
    Gamma0 *=* Gamma' /\
    G = GH & (w', Gamma0) ++ GT.
intros.
assert ((w, Gamma) ::G  ~=~ (G' & (w', Gamma'))) by
  (transitivity (G & (w,Gamma)); auto; PPermut_Hyb_simpl).
assert ((w, Gamma) :: G ~=~ (w', Gamma') :: G') by
  (transitivity (G' & (w', Gamma')); auto; PPermut_Hyb_simpl).
symmetry in H2;
apply PPermut_Hyb_split_head in H2;
destruct H2 as (Gamma'',(GH, (GT, (Ha, Hb)))).
destruct GH; rew_app in *.
inversion Hb; subst; destruct H0; elim H0; symmetry; auto.
destruct p; inversion Hb; subst.
exists Gamma''; exists GH; exists GT; split;
[symmetry | rew_app]; auto.
Qed.

Lemma PPermut_Hyb_swap2:
forall C C' G,
  C :: G & C' ~=~ G & C & C'.
intros; PPermut_Hyb_simpl.
Qed.
Hint Resolve PPermut_Hyb_swap2.

Lemma PPermut_Hyb_middle_last:
forall G G' C,
  G ++ G' & C ~=~ G ++ C :: G'.
intros; PPermut_Hyb_simpl.
Qed.
Hint Resolve PPermut_Hyb_middle_last.

Lemma PPermut_Hyb_specialized1:
forall G G' C C',
  G ++ C :: G' & C' ~=~ G ++ G' ++ C' :: C :: nil.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized2:
forall GH GT G Gamma Gamma' Gamma'',
  GH ++ Gamma :: GT & Gamma' ~=~ G & Gamma ->
  GH ++ GT ++ Gamma'' :: Gamma' :: nil ~=~ G & Gamma''.
intros; PPermut_Hyb_simpl;
apply PPermut_Hyb_last_rev_simpl with (a:=Gamma);
rewrite <- H; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized3:
forall G G' C C',
  G ++ G' ++ C :: C' :: nil ~=~ G ++ C :: G' & C'.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized4:
forall G GH GT Gamma Gamma0 Gamma'0,
  GH ++ Gamma :: GT & Gamma'0 ~=~ G & Gamma ->
  G ++ Gamma0 :: Gamma :: nil ~=~ GH ++ GT ++ Gamma0 :: Gamma'0 :: Gamma :: nil.
intros; PPermut_Hyb_simpl;
apply PPermut_Hyb_last_rev_simpl with (a:=Gamma); rewrite <- H;
PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized5:
forall G G' C C' C'',
  G ++ C :: G' ++ C' :: C'' :: nil ~=~ (G ++ G' ++ C' :: C'' :: nil) & C.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized6:
forall GH GT C0 C'' C'0,
  GH ++ GT ++ C'0 :: C'' :: C0 :: nil ~=~ GH ++ GT ++ C0 :: C'0 :: C'' :: nil.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_swap_inner:
forall G G' C C',
  C :: G ++ C' :: G' ~=~ C' :: G ++ G' & C.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_swap_inner2:
forall G G' C C',
  C :: G ++ G' & C' ~=~ C' :: G ++ G' & C.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_swap3:
forall C C' G,
  C :: G & C' ~=~ C' :: G & C.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_swap4:
forall C G' G,
  G ++ G' & C ~=~ G & C ++ G'.
intros; PPermut_Hyb_simpl.
Qed.

Hint Resolve PPermut_Hyb_swap_inner.
Hint Resolve PPermut_Hyb_swap_inner2.
Hint Resolve PPermut_Hyb_swap3 PPermut_Hyb_swap4.

Hint Resolve PPermut_Hyb_specialized2 : ppermut_rew.
Hint Resolve PPermut_Hyb_specialized1
             PPermut_Hyb_specialized3 PPermut_Hyb_specialized4
             PPermut_Hyb_specialized5 PPermut_Hyb_specialized6.

Lemma permut_PPermut_Hyb:
forall G G', G *=* G' -> G ~=~ G'.
intros. induction H; auto.
transitivity y; auto.
inversion H. PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_map_fst:
forall G G',
  G ~=~ G' ->
  map fst_ G *=* map fst_ G'.
induction G; intros.
apply PPermut_Hyb_nil_impl in H; subst; auto.
assert (a::G ~=~ G') by auto;
destruct a; apply PPermut_Hyb_split_head in H;
destruct H as (l', (hd, (tl, (Ha, Hb)))); subst;
rew_map; simpl; permut_simpl;
replace (map fst_ hd ++ map fst_ tl) with (map fst_ (hd++tl))
  by (rew_map; auto);
apply IHG.
apply PPermut_Hyb_last_rev with (w:=v) (Gamma:=l) (Gamma':=l);
auto; transitivity ((v,l)::G); [ | rewrite H0]; PPermut_Hyb_simpl.
Qed.

Close Scope permut_scope.


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.Overture.
Require Import Basics.PathGroupoids.
Require Import Basics.Notations.
Require Import Basics.Contractible.
Require Import Basics.Equivalences.
Require Import WildCat.Core.
Require Import WildCat.Equiv.

(** * Product categories *)

(** Products preserve (0,1)-categories. *)
Global Instance isgraph_prod A B `{IsGraph A} `{IsGraph B}
  : IsGraph (A * B)
  := Build_IsGraph (A * B) (fun x y => (fst x $-> fst y) * (snd x $-> snd y)).

Global Instance is01cat_prod A B `{Is01Cat A} `{Is01Cat B}
  : Is01Cat (A * B).
Proof.
  refine (Build_Is01Cat (A * B) (fun x y => (fst x $-> fst y) * (snd x $-> snd y)) _ _).
  - intros [a b]; exact (Id a, Id b).
  - intros [a1 b1] [a2 b2] [a3 b3] [f1 g1] [f2 g2]; cbn in *.
    exact (f1 $o f2 , g1 $o g2).
Defined.

(** To avoid having to define a separate notion of "two-variable functor", we define two-variable functors in uncurried form.  The following definition applies such a two-variable functor, with a currying built in. *)
Definition fmap11 {A B C : Type} `{IsGraph A} `{IsGraph B} `{IsGraph C}
  (F : A -> B -> C) {H2 : Is0Functor (uncurry F)}
  {a1 a2 : A} {b1 b2 : B} (f1 : a1 $-> a2) (f2 : b1 $-> b2)
  : F a1 b1 $-> F a2 b2
  := @fmap _ _ _ _ (uncurry F) H2 (a1, b1) (a2, b2) (f1, f2).

Global Instance is0gpd_prod A B `{Is0Gpd A} `{Is0Gpd B}
 : Is0Gpd (A * B).
Proof.
  serapply Build_Is0Gpd.
  intros [x1 x2] [y1 y2] [f1 f2].
  cbn in *.
  exact ( (f1^$, f2^$) ).
Defined.

Global Instance is1cat_prod A B `{Is1Cat A} `{Is1Cat B}
  : Is1Cat (A * B).
Proof.
  serapply (Build_Is1Cat).
  - intros [x1 x2] [y1 y2].
    rapply is01cat_prod.
  - intros [x1 x2] [y1 y2].
    apply is0gpd_prod.
    + cbn.
      apply isgpd_hom.
    + cbn.
      apply isgpd_hom.
  - intros [x1 x2] [y1 y2] [z1 z2] [h1 h2].
    serapply Build_Is0Functor.
    intros [f1 f2] [g1 g2] [p1 p2]; cbn in *.
    exact ( h1 $@L p1 , h2 $@L p2 ).
  - intros [x1 x2] [y1 y2] [z1 z2] [h1 h2].
    serapply Build_Is0Functor.
    intros [f1 f2] [g1 g2] [p1 p2]; cbn in *.
    exact ( p1 $@R h1 , p2 $@R h2 ).
  - intros [a1 a2] [b1 b2] [c1 c2] [d1 d2] [f1 f2] [g1 g2] [h1 h2].
    cbn in *.
    exact(cat_assoc f1 g1 h1, cat_assoc f2 g2 h2).
  - intros [a1 a2] [b1 b2] [f1 f2].
    cbn in *.
    exact (cat_idl _, cat_idl _).
  - intros [a1 a2] [b1 b2] [g1 g2].
    cbn in *.
    exact (cat_idr _, cat_idr _).
Defined.

(** Product categories inherit equivalences *)

Global Instance hasequivs_prod A B `{HasEquivs A} `{HasEquivs B}
  : HasEquivs (A * B).
Proof.
  srefine (Build_HasEquivs (A * B) _ _
             (fun a b => (fst a $<~> fst b) * (snd a $<~> snd b))
             _ _ _ _ _ _ _ _ _).
  1:intros a b f; exact (CatIsEquiv (fst f) * CatIsEquiv (snd f)).
  all:cbn; intros a b f.
  - split; [ exact (fst f) | exact (snd f) ].
  - split; exact _.
  - intros [fe1 fe2]; split.
    + exact (Build_CatEquiv (fst f)).
    + exact (Build_CatEquiv (snd f)).
  - intros [fe1 fe2]; cbn; split; apply cate_buildequiv_fun.
  - intros [fe1 fe2]; split; [ exact ((fst f)^-1$) | exact ((snd f)^-1$) ].
  - intros [fe1 fe2]; split; apply cate_issect.
  - intros [fe1 fe2]; split; apply cate_isretr.
  - intros g r s; split.
    + exact (catie_adjointify (fst f) (fst g) (fst r) (fst s)).
    + exact (catie_adjointify (snd f) (snd g) (snd r) (snd s)).
Defined.

Global Instance isequivs_prod A B `{HasEquivs A} `{HasEquivs B}
       {a1 a2 : A} {b1 b2 : B} {f : a1 $-> a2} {g : b1 $-> b2}
       {ef : CatIsEquiv f} {eg : CatIsEquiv g}
  : @CatIsEquiv (A*B) _ _ _ (a1,b1) (a2,b2) (f,g) := (ef,eg).

(** More coherent two-variable functors. *)

Definition fmap22 {A B C : Type} `{Is1Cat A} `{Is1Cat B} `{Is1Cat C}
  (F : A -> B -> C) `{!Is0Functor (uncurry F), !Is1Functor (uncurry F)}
  {a1 a2 : A} {b1 b2 : B} (f1 : a1 $-> a2) (f2 : b1 $-> b2) (g1 : a1 $-> a2) (g2 : b1 $-> b2)
  (alpha : f1 $== g1) (beta : f2 $== g2)
  : (fmap11 F f1 f2) $== (fmap11 F g1 g2)
  := @fmap2 _ _ _ _ _ _ (uncurry F) _ _ (a1, b1) (a2, b2) (f1, f2) (g1, g2) (alpha, beta).

Global Instance iemap11 {A B C : Type} `{HasEquivs A} `{HasEquivs B} `{HasEquivs C}
           (F : A -> B -> C) `{!Is0Functor (uncurry F), !Is1Functor (uncurry F)}
           {a1 a2 : A} {b1 b2 : B} (f1 : a1 $-> a2) (f2 : b1 $-> b2)
           {f1e : CatIsEquiv f1} {f2e : CatIsEquiv f2}
  : CatIsEquiv (fmap11 F f1 f2)
  := @iemap _ _ _ _ _ _ _ _ (uncurry F) _ _ (a1, b1) (a2, b2) (f1, f2) _.

Definition emap11 {A B C : Type} `{HasEquivs A} `{HasEquivs B} `{HasEquivs C}
           (F : A -> B -> C) `{!Is0Functor (uncurry F), !Is1Functor (uncurry F)}
           {a1 a2 : A} {b1 b2 : B} (fe1 : a1 $<~> a2)
           (fe2 : b1 $<~> b2) : (F a1 b1) $<~> (F a2 b2)
  := @emap _ _ _ _ _ _ _ _ (uncurry F) _ _ (a1, b1) (a2, b2) (fe1, fe2).


(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
(* Require Import ReflParam.paramDirect ReflParam.indType. *)
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.PIWNew.

Require Import Template.Template.

Require Import ReflParam.common.

Require Import List.
(* Run TemplateProgram (mkIndEnv "indTransEnv" ["ReflParam.matchR.Vec"]). *)

Inductive Vec (C : Set) : nat -> Set :=
    vnil : Vec C 0 | vcons : forall n : nat, C -> Vec C n -> Vec C (n+1).

Declare ML Module "paramcoq".
Parametricity Recursive Vec.

Notation Vec_RR := Vec_R.
Notation vnil_RR := Vec_R_vnil_R.
Notation vcons_RR := Vec_R_vcons_R.
Notation add_RR := Coq_o_Init_o_Nat_o_add_R.
Definition one_RR : nat_R 1 1.
  constructor. constructor.
Defined.

Notation O_RR := common.nat_R_O_R.
Notation S_RR := nat_R_S_R.

Require Import SquiggleEq.tactics.
Require Import SquiggleEq.LibTactics.
Notation nat_RR := common.nat_R.
Open Scope nat_scope.
Fixpoint Vec_rect_RR (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (P₁ : forall n : nat, Vec C₁ n -> Set)
         (P₂ : forall n : nat, Vec C₂ n -> Set)
         (P_R : forall (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
                  (v₁ : Vec C₁ n₁) (v₂ : Vec C₂ n₂),
                Vec_RR C₁ C₂ C_R n₁ n₂ n_R v₁ v₂ -> P₁ n₁ v₁ -> P₂ n₂ v₂ -> Set)
         (f₁ : P₁ 0 (vnil C₁))
         (f₂ : P₂ 0 (vnil C₂))
       (f_R: P_R 0 0 O_RR (vnil C₁) (vnil C₂) (vnil_RR C₁ C₂ C_R) f₁ f₂)
         (f₁0 : forall (n : nat) (c : C₁) (v : Vec C₁ n),
                P₁ n v -> P₁ (n + 1) (vcons C₁ n c v))
         (f₂0 : forall (n : nat) (c : C₂) (v : Vec C₂ n),
                P₂ n v -> P₂ (n + 1) (vcons C₂ n c v))
       (f0_R: forall (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂) (c₁ : C₁)
          (c₂ : C₂) (c_R : C_R c₁ c₂) (v₁ : Vec C₁ n₁) (v₂ : Vec C₂ n₂)
          (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R v₁ v₂) (H : P₁ n₁ v₁)
          (H0 : P₂ n₂ v₂),
        P_R n₁ n₂ n_R v₁ v₂ v_R H H0 ->
        P_R (n₁ + 1) (n₂ + 1)
          (add_RR n₁ n₂ n_R 1 1 one_RR)
          (vcons C₁ n₁ c₁ v₁) (vcons C₂ n₂ c₂ v₂)
          (vcons_RR C₁ C₂ C_R n₁ n₂ n_R c₁ c₂ c_R v₁ v₂ v_R)
          (f₁0 n₁ c₁ v₁ H) (f₂0 n₂ c₂ v₂ H0))
       (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂) (v₁ : Vec C₁ n₁)
         (v₂ : Vec C₂ n₂) (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R v₁ v₂) {struct v₁} :
       P_R n₁ n₂ n_R v₁ v₂ v_R (Vec_rect C₁ P₁ f₁ f₁0 n₁ v₁) (Vec_rect C₂ P₂ f₂ f₂0 n₂ v₂).
Proof.
  revert v_R.
  revert n_R.
  destruct v₁;
   destruct v₂; intros.
  - simpl. clear f₁0 f₂0 f0_R.
    Fail induction v_R.
    (* this is hard to prove, but possible to prove, because there is an isomorphism
      between Vec_R and Vec_RDed. so one can apply that isomorphism to v_R to get
      that n_R is 0_RR *)

    inverts v_R.
   simpl in v_R. unfold vnil_RR in f_R. simpl in f_R.
    subst. assumption.
  - simpl in v_R. apply False_rect. assumption.
  - simpl in v_R. apply False_rect. assumption.
  - simpl. simpl in *. exrepnd. simpl.
    Arguments existT {A} {P} x p.
    simpl. rename v_R0 into peq.
    subst. simpl. apply f0_R.
    apply Vec_rect_RR; assumption.
Defined.

       (*
vcons_RR =
fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (n n₂ : nat)
  (n_R : Coq_Init_Datatypes_nat_RR0 n n₂) (H : C) (H0 : C₂) (H1 : C_R H H0)
  (H2 : Vec C n) (H3 : Vec C₂ n₂) (H4 : ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R H2 H3) =>
existT n_R (existT H1 (existT H4 I))
*)

(* Notation Vec_RR := ReflParam_matchR_Vec_RR0. *)
(* Notation vcons_RR := ReflParam_matchR_Vec_RR0_paramConstr_1. *)

(*Definition vcons_RR {C₁ C₂ : Set} {C_R : C₁ -> C₂ -> Prop}
(n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
 (H : C₁) (H0 : C₂) (c_R: C_R H H0)
 (H1 : Vec C₁ n₁) (H2 : Vec C₂ n₂)
 (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2):
  Vec_RR C₁ C₂ C_R (S n₁) (S n₂) (S_RR n₁ n₂ n_R)
  (vcons C₁ n₁ H H1) (vcons C₂ n₂ H0 H2) :=
  existT
  (fun n_R0 : nat_RR n₁ n₂ =>
   {_ : C_R H H0 & {_ : Vec_RR C₁ C₂ C_R n₁ n₂ n_R0 H1 H2 & True}}) n_R
  (existT (fun _ : C_R H H0 => {_ : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2 & True}) c_R
     (existT (fun _ : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2 => True) v_R I)).
*)
(*
Proof.
simpl. eexists; eexists; eauto.
Defined.
*)

Require Import SquiggleEq.UsefulTypes.
Fixpoint ReflParam_matchR_vAppend_RR (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (n₁ n₂ : nat)
   (n_R : nat_RR n₁ n₂) (m₁ m₂ : nat) (m_R : nat_RR m₁ m₂)
   (vl₁ : Vec C₁ n₁) (vl₂ : Vec C₂ n₂)
   (vl_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂)
   (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂)
   (vr_R : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂) {struct vl₁ }:
    Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂).
refine (
let reT := fun n₁ vl₁ n₂ vl₂ =>
forall n_R: nat_RR n₁ n₂,
Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂
->
Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂)  in
(match vl₁ in Vec _ n₁ return reT n₁ vl₁ n₂ vl₂ with
| vnil _ =>
  match vl₂ in (Vec _ n₂) return reT 0 (vnil _) n₂ vl₂ with
  | vnil _ => fun _ _ => vr_R
  | vcons _ _ _ _ => fun _ v_R => False_rect _ v_R
  end

| vcons _ n₁ hl₁ tl₁ =>
  match vl₂ in (Vec _ n₂) return reT (S n₁) (vcons _ n₁ hl₁ tl₁) n₂ vl₂ with
  | vnil _ =>  fun _ v_R => False_rect _ v_R
  | vcons _ _ hl₂ tl₂ => fun _ v_R =>
    let n_R := projT2 v_R in
    let v_R := projT2 v_R in
    let hl_R := projT1 v_R in
    let tl_R := projT1 (projT2 v_R) in
    let peq := projT2 (projT2 v_R) in
    let old := (vcons_RR _ _ C_R _ _ _ _ _ hl_R _ _
     (ReflParam_matchR_vAppend_RR _ _ _ _ _ _ _ _ _ _ _ tl_R  _ _ vr_R))
    in _
  end
end) n_R vl_R).
simpl vAppend. simpl add_RR.
rewrite peq. exact old.
Defined.

Definition Vec_rect_type :=
forall (C : Set) (P : forall n : nat, Vec C n -> Set),
       P 0 (vnil C) ->
       (forall (n : nat) (c : C) (v : Vec C n), P n v -> P (S n) (vcons C n c v)) ->
       forall (n : nat) (v : Vec C n), P n v.

Require Import SquiggleEq.tactics.

Notation vAppend_RR := ReflParam_matchR_vAppend_RR.

Print sigT_rect.

Print ReflParam_matchR_Vec_RR0.

Definition vAppend2_RR3 (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (m₁ m₂ : nat)
  (m_R : nat_RR m₁ m₂)
  (cdef₁ : C₁) (cdef₂ : C₂) (cdef_R : C_R cdef₁ cdef₂)
  (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂) (vr : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂):
  C_R (vAppend2  cdef₁ vr₁) (vAppend2 cdef₂ vr₂) :=
(
let reT n1 n2 v1 v2 (* indices and values. move the _Rs to the body, as Pi args  *) :=
      forall (nr: nat_RR n1 n2)
        (vapr: Vec_RR C₁ C₂ C_R n1 n2 nr v1 v2),
     C_R match v1 with
      | vnil _ => cdef₁
      | vcons _ _ hl _ => hl
      end match v2 with
          | vnil _ => cdef₂
          | vcons _ _ hl _ => hl
          end in

(* the "as vap1" part cannot be inlined.
"vAppend vr₁ vr₁" has type "Vec C₁ (m₁ + m₁)" while vap1 has type "Vec C₁ n1"
*)
match vAppend vr₁ vr₁ as vap1 in Vec _ n1
  return reT n1 (m₂+m₂)(*prime of index of discriminee *)
      vap1 (vAppend vr₂ vr₂) (* prime of discriminee*)
with
| vnil _ =>
    match vAppend vr₂ vr₂ as vap2 in Vec _ n2
      return reT O (*index of this constr:vnil*) n2 (* from in *)
          (vnil _) vap2
      with
      | vnil _ => fun (nr : nat_RR 0 0) (_ : Vec_RR C₁ C₂ C_R 0 0 nr (vnil C₁) (vnil C₂))  => cdef_R
      | vcons _ n2 hl2 v2 =>
        fun (nr : nat_RR 0 (S n2))
          (vr0 : Vec_RR C₁ C₂ C_R 0 (S n2) nr (vnil C₁) (vcons C₂ n2 hl2 v2))
        => False_rect
            (*reT 0 (S n2) (vnil C₁) (vcons C₂ n2 hl2 v2) nr vr0 -- then strip the 2 pis*)
            _ vr0 (* always the last lambda *)
      end
| vcons _ n1 hl tl =>
    match vAppend vr₂ vr₂ as vap2 in Vec _ n2
      return reT (S n1) (*index of this constr*) n2 (* from in *)
          (vcons _ _ hl tl) vap2
      with
      | vnil _ => fun _ vr => False_rect _ vr
      | vcons _ _ hl _ => fun _ v_R =>
    let v_R := projT2 v_R in
    let hl_R := projT1 v_R in
    let tl_R := projT1 (projT2 v_R)
        in hl_R
      end

end (add_RR m₁ m₂ m_R m₁ m₂ m_R)
  (vAppend_RR _ _ _ _ _ _ _ _ vr _ _ vr)
).
Check indTransEnv.
Run TemplateProgram (genParam indTransEnv false true "vAppend2"). (* success!*)
Print vAppend2_RR.

(*
vAppend2_RR =
fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (m m₂ : nat) (m_R : nat_RR m m₂)
  (cdef : C) (cdef₂ : C₂) (cdef_R : C_R cdef cdef₂) (vr : Vec C m)
  (vr₂ : Vec C₂ m₂) (vr_R : Vec_RR C C₂ C_R m m₂ m_R vr vr₂) =>
match
  vAppend vr vr as vapx in (Vec _ n)
  return
    (forall n_R : nat_RR n (m₂ + m₂),
     Vec_RR C C₂ C_R n (m₂ + m₂) n_R vapx (vAppend vr₂ vr₂) ->
     C_R match vapx with
         | vnil _ => cdef
         | vcons _ _ hl _ => hl
         end match vAppend vr₂ vr₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl₂ _ => hl₂
             end)
with
| vnil _ =>
    match
      vAppend vr₂ vr₂ as vapx₂ in (Vec _ n₂)
      return
        (forall n_R : nat_RR 0 n₂,
         Vec_RR C C₂ C_R 0 n₂ n_R (vnil C) vapx₂ ->
         C_R cdef match vapx₂ with
                  | vnil _ => cdef₂
                  | vcons _ _ hl₂ _ => hl₂
                  end)
    with
    | vnil _ =>
        fun (n_R : nat_RR 0 0) (vapx_R : Vec_RR C C₂ C_R 0 0 n_R (vnil C) (vnil C₂)) =>
        ReflParam_matchR_Vec_RR0_paramConstr_0_paramInv C C₂ C_R vapx_R
          (C_R match vnil C with
               | vnil _ => cdef
               | vcons _ _ hl _ => hl
               end match vnil C₂ with
                   | vnil _ => cdef₂
                   | vcons _ _ hl₂ _ => hl₂
                   end) cdef_R
    | vcons _ n'₂ hl₂ tl₂ =>
        fun (n_R : nat_RR 0 (S n'₂))
          (vapx_R : Vec_RR C C₂ C_R 0 (S n'₂) n_R (vnil C) (vcons C₂ n'₂ hl₂ tl₂)) =>
        False_rectt
          (C_R match vnil C with
               | vnil _ => cdef
               | vcons _ _ hl _ => hl
               end
             match vcons C₂ n'₂ hl₂ tl₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl₂0 _ => hl₂0
             end) vapx_R
    end
| vcons _ n' hl tl =>
    match
      vAppend vr₂ vr₂ as vapx₂ in (Vec _ n₂)
      return
        (forall n_R : nat_RR (S n') n₂,
         Vec_RR C C₂ C_R (S n') n₂ n_R (vcons C n' hl tl) vapx₂ ->
         C_R hl match vapx₂ with
                | vnil _ => cdef₂
                | vcons _ _ hl₂ _ => hl₂
                end)
    with
    | vnil _ =>
        fun (n_R : nat_RR (S n') 0)
          (vapx_R : Vec_RR C C₂ C_R (S n') 0 n_R (vcons C n' hl tl) (vnil C₂)) =>
        False_rectt
          (C_R match vcons C n' hl tl with
               | vnil _ => cdef
               | vcons _ _ hl0 _ => hl0
               end match vnil C₂ with
                   | vnil _ => cdef₂
                   | vcons _ _ hl₂ _ => hl₂
                   end) vapx_R
    | vcons _ n'₂ hl₂ tl₂ =>
        fun (n_R : nat_RR (S n') (S n'₂))
          (vapx_R : Vec_RR C C₂ C_R (S n') (S n'₂) n_R (vcons C n' hl tl)
                      (vcons C₂ n'₂ hl₂ tl₂)) =>
        ReflParam_matchR_Vec_RR0_paramConstr_1_paramInv C C₂ C_R n' n'₂ hl hl₂ tl tl₂ vapx_R
          (C_R match vcons C n' hl tl with
               | vnil _ => cdef
               | vcons _ _ hl0 _ => hl0
               end
             match vcons C₂ n'₂ hl₂ tl₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl₂0 _ => hl₂0
             end)
          (fun (n'_R : nat_RR n' n'₂) (hl_R : C_R hl hl₂)
             (_ : Vec_RR C C₂ C_R n' n'₂ n'_R tl tl₂) => hl_R)
    end
end (add_RR m m₂ m_R m m₂ m_R) (vAppend_RR m m₂ m_R m m₂ m_R vr vr₂ vr_R vr vr₂ vr_R)
     : forall (C C₂ : Set) (C_R : C -> C₂ -> Prop) (m m₂ : nat)
         (m_R : nat_RR m m₂) (cdef : C) (cdef₂ : C₂),
       C_R cdef cdef₂ ->
       forall (vr : Vec C m) (vr₂ : Vec C₂ m₂),
       Vec_RR C C₂ C_R m m₂ m_R vr vr₂ ->
       C_R match vAppend vr vr with
           | vnil _ => cdef
           | vcons _ _ hl _ => hl
           end match vAppend vr₂ vr₂ with
               | vnil _ => cdef₂
               | vcons _ _ hl₂ _ => hl₂
               end
*)


(*

  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 substitution.
Require Export terms_props.
Require Export cvterm4.

Lemma isprog_atom_eq {o} :
  forall a b c d : @NTerm o,
    isprog (mk_int_eq a b c d)
    <=> (isprog a
         # isprog b
         # isprog c
         # isprog d).
Proof.
  introv.
  allrw @isprog_vars_nil_iff_isprog.
  apply isprog_vars_less.
Qed.

Lemma isprog_atom_eq_implies {o} :
  forall a b c d : @NTerm o,
    isprog a
    -> isprog b
    -> isprog c
    -> isprog d
    -> isprog (mk_atom_eq a b c d).
Proof.
  introv u v w z.
  apply isprog_atom_eq; sp.
Qed.

Lemma implies_isprog_atom_eq {o} :
  forall (a b c d : @NTerm o),
    isprog a
    -> isprog b
    -> isprog c
    -> isprog d
    -> isprog (mk_atom_eq a b c d).
Proof.
  introv ispa ispb ispc ispd.
  apply isprog_atom_eq; sp.
Qed.

Definition mkc_atom_eq {o} (t1 t2 t3 t4 : @CTerm o) : CTerm :=
  let (a,x) := t1 in
  let (b,y) := t2 in
  let (c,z) := t3 in
  let (d,w) := t4 in
    exist isprog (mk_atom_eq a b c d) (isprog_atom_eq_implies a b c d x y z w).

Lemma fold_int_eq {p} :
  forall (m n a b : @NTerm p),
   oterm (NCan (NCompOp CompOpEq)) [ nobnd m, nobnd n, nobnd a, nobnd b]
    = mk_int_eq m n a b.
Proof. sp. Qed.

Lemma lsubstc_mk_int_eq {o} :
  forall m n t1 t2 sub,
  forall wm : wf_term m,
  forall wn : wf_term n,
  forall w1 : wf_term t1,
  forall w2 : @wf_term o t2,
  forall w  : wf_term (mk_int_eq m n t1 t2),
  forall cm : cover_vars m sub,
  forall cn : cover_vars n sub,
  forall c1 : cover_vars t1 sub,
  forall c2 : cover_vars t2 sub,
  forall c  : cover_vars (mk_int_eq m n t1 t2) sub,
    lsubstc (mk_int_eq m n t1 t2) w sub c
    = mkc_inteq (lsubstc m wm sub cm)
                 (lsubstc n wn sub cn)
                 (lsubstc t1 w1 sub c1)
                 (lsubstc t2 w2 sub c2).
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 @fold_int_eq; sp.
Qed.

Lemma lsubstc_mk_int_eq_ex {o} :
  forall m n t1 t2 sub,
  forall w  : wf_term (@mk_int_eq o m n t1 t2),
  forall c  : cover_vars (mk_int_eq m n t1 t2) sub,
  {wm : wf_term m
   & {wn : wf_term n
   & {w1 : wf_term t1
   & {w2 : wf_term t2
   & {cm : cover_vars m sub
   & {cn : cover_vars n sub
   & {c1 : cover_vars t1 sub
   & {c2 : cover_vars t2 sub
      & lsubstc (mk_int_eq m n t1 t2) w sub c
           = mkc_inteq (lsubstc m wm sub cm)
                        (lsubstc n wn sub cn)
                        (lsubstc t1 w1 sub c1)
                        (lsubstc t2 w2 sub c2)}}}}}}}}.
Proof.
  sp.

  assert (wf_term m # wf_term n # wf_term t1 # wf_term t2) as wf.
  { rw @wf_compop_iff in w; sp. }
  repnd.

  assert (cover_vars m sub # cover_vars n sub # cover_vars t1 sub # cover_vars t2 sub) as cov.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }
  repnd.

  exists wf0 wf1 wf2 wf cov0 cov1 cov2 cov.
  apply lsubstc_mk_int_eq.
Qed.

Lemma fold_atom_eq {p} :
  forall (m n a b : @NTerm p),
   oterm (NCan (NCompOp CompOpEq)) [ nobnd m, nobnd n, nobnd a, nobnd b]
    = mk_atom_eq m n a b.
Proof. sp. Qed.

Lemma lsubstc_mk_atom_eq {o} :
  forall m n t1 t2 sub,
  forall wm : wf_term m,
  forall wn : wf_term n,
  forall w1 : wf_term t1,
  forall w2 : @wf_term o t2,
  forall w  : wf_term (mk_atom_eq m n t1 t2),
  forall cm : cover_vars m sub,
  forall cn : cover_vars n sub,
  forall c1 : cover_vars t1 sub,
  forall c2 : cover_vars t2 sub,
  forall c  : cover_vars (mk_atom_eq m n t1 t2) sub,
    lsubstc (mk_atom_eq m n t1 t2) w sub c
    = mkc_atom_eq (lsubstc m wm sub cm)
                 (lsubstc n wn sub cn)
                 (lsubstc t1 w1 sub c1)
                 (lsubstc t2 w2 sub c2).
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 @fold_int_eq; sp.
Qed.

Lemma lsubstc_mk_atom_eq_ex {o} :
  forall m n t1 t2 sub,
  forall w  : wf_term (@mk_atom_eq o m n t1 t2),
  forall c  : cover_vars (mk_atom_eq m n t1 t2) sub,
  {wm : wf_term m
   & {wn : wf_term n
   & {w1 : wf_term t1
   & {w2 : wf_term t2
   & {cm : cover_vars m sub
   & {cn : cover_vars n sub
   & {c1 : cover_vars t1 sub
   & {c2 : cover_vars t2 sub
      & lsubstc (mk_atom_eq m n t1 t2) w sub c
           = mkc_atom_eq (lsubstc m wm sub cm)
                        (lsubstc n wn sub cn)
                        (lsubstc t1 w1 sub c1)
                        (lsubstc t2 w2 sub c2)}}}}}}}}.
Proof.
  sp.

  assert (wf_term m # wf_term n # wf_term t1 # wf_term t2) as wf.
  { rw @wf_compop_iff in w; sp. }
  repnd.

  assert (cover_vars m sub # cover_vars n sub # cover_vars t1 sub # cover_vars t2 sub) as cov.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }
  repnd.

  exists wf0 wf1 wf2 wf cov0 cov1 cov2 cov.
  apply lsubstc_mk_atom_eq.
Qed.


Require Import Iron.Data.List.Base.

(* Check if any element in a list matches the given predicate. *)
Fixpoint elem {A} (p : A -> bool) (xx : list A)
 := match xx with
    | nil      => false
    | x :: xs  => if p x then true else elem p xs
    end.

Lemma elem_get_not
 :  forall {A} (p : A -> bool) (xx : list A)
 ,  not (exists ix x, get ix xx = Some x /\ p x = true)
 -> elem p xx = false.
Proof.
 intros.
 induction xx.
 - simpl. auto.
 - remember (p a) as X.
   destruct X.
   + simpl.
     rewrite <- HeqX.
     assert (exists ix x, get ix (xx :> a) = Some x /\ p x = true).
      exists 0. exists a. intuition.
     tauto.

   + simpl.
     rewrite <- HeqX.
     eapply IHxx.
     unfold not.
     intros.
     destruct H0 as [ix].
     destruct H0 as [x].
     inversion H0.
     assert (get (S ix) (xx :> a) = Some x).
      simpl. auto.
     assert (exists ix x, get ix (xx :> a) = Some x /\ p x = true).
      exists (S ix). exists x. auto.
     tauto.
Qed.