Require Import Metalib.Metatheory.
Require Import LambdaJm.Syntax.

Import LambdaJmNotations.

(***********************************************************************)
(** * Append operation *)
(***********************************************************************)

Fixpoint app_args_args (a1:gmargs) (a2:gmargs) {struct a1}: gmargs :=
  match a1 with
  | (args t l c)  => args t l (app_cont_args c a2)
  end
with app_cont_args (c:cont) (a:gmargs) : cont :=
  match c with
  | cabs v =>
    cabs (app_term_x_args v a)
  end
with app_term_x_args (v:term) (a:gmargs) {struct v}: term :=
  match v with
  | (app (var_b 0) a1) => if (testINargs_rec 0 a1)   (* if 0 is in a1 *)
                         then app v a
                         else app (var_b 0) (app_args_args a1 a)
  | _                  => app v a
  end.

Fixpoint app_term_args (t:term) (a:gmargs) {struct t}: term :=
  match t with
  | (app t1 a1)   => app t1 (app_args_args a1 a)
  | _             => app t a
  end.

Fixpoint app_term_cont (t:term) (c:cont): term :=
  match c with
  | (cabs v)  => open_term_wrt_term v t
  end.

Fixpoint app_cont_cont (c1:cont) (c2:cont) {struct c1}: cont :=
  match c1 with
  | (cabs (var_b 0))  => c2
  | (cabs (app (var_b 0) (args u l c))) =>
              if (testINargs_rec 0 (args u l c))
              then  cabs (app_term_cont (app (var_b 0) (args u l c)) c2)
              else  cabs (app (var_b 0) (args u l (app_cont_cont c c2)))

  | (cabs v)  => cabs (app_term_cont v c2)
  end.

Fixpoint app_alist_alist (l1:alist) (l2:alist): alist :=
  match l1 with
  | anil          => l2
  | (acons t l3)  => acons t (app_alist_alist l3 l2)
  end.

Notation "l1 +@+ l2"    := (app_alist_alist l1 l2) (at level 0, right associativity).

(* Mail do JES:
Na prova do Lema 2 no apêndice, penúltimo caso (v = x(u,l,c) e x \notin u,l,c),
usa-se IH relativa à continuação c, mas esta continuação c não é sub-expressão imediata
do termo v. Obviamente que isto não põe em causa a prova informal, porque c é de facto
"menor" que v. Mas isto põe, de facto, um problema à formalização, porque a prova dá
2 "saltos" num único "salto": da continuação c para o termo v via o argumento (u,l,c).

Esta passagem silenciosa pelo argumento (u,l,c) indica que, implicitamente, há um terceiro
item no lema 2 relativo a argumentos: a'@a = a' @ (z)za, se z \notin a. Mas a operação a'@c
não está (ainda) definida. A def. seria óbvia ( (u,l,c)@c' = (u,l,c@c') ) e permitiria
simplificar a Def 1, item 5. A minha sensação é que seria acertado introduzir a nova def.

Porém, é possível continuar a viver (e fazer a prova do Lema 2 em Coq) sem introduzir essa
 definição. Para isso, basta enunciar o terceiro item do Lema 2 assim

Q(a):= para todo u,l,c,z,a' [ se (a=(u,l,c) e z \notin a') então a@a' = (u,l,c(z)za') ]

Já estou a dar o nome Q a este predicado. Este predicado substitui o predicado Q(a)=true
que estávamos a usar na prova formal. Esta continua a seguir o mesmo princípio de indução.
Surge uma nova obrigação de prova relativa ao único construtor de args, que deve seguir
imediatamente pela hipótese de indução relativa à continuação do argumento, usando o item 2
da Def 1. Finalmente, de volta ao caso v = x(u,l,c) e x \notin u,l,c, há uma ligeira
alteração na prova do apêndice: não se chama o item 2 da Def 1, aplica-se imediatamente
 a IH relativa a a=(u,l,c).
*)
Lemma app_coherence :
  (forall v a, (testINargs_rec 0 a = false) ->
          (cabs (app_term_x_args v a)) = app_cont_cont (cabs v) (cabs (app (var_b 0) a))) /\
  (forall a1 u l c a, (testINargs_rec 0 a = false) /\ a1 = (args u l c) ->
              (app_args_args a1 a) = (args u l (app_cont_cont c (cabs (app (var_b 0) a)))))
  /\ (forall l:alist, True) /\
  (forall c a, (testINargs_rec 0 a = false) ->
          app_cont_args c a = app_cont_cont c (cabs (app (var_b 0) a))).
Proof.
  apply (term_gmargs_alist_cont_mutind
           (fun v => (forall a, (testINargs_rec 0 a = false) ->
                     (cabs (app_term_x_args v a)) = app_cont_cont (cabs v) (cabs (app (var_b 0) a))))
           (fun a1 => (forall u l c a, (testINargs_rec 0 a = false) /\ a1 = (args u l c) ->
                      (app_args_args a1 a) = (args u l (app_cont_cont c (cabs (app (var_b 0) a))))))
           (fun l => True)
           (fun c => (forall a, (testINargs_rec 0 a = false) ->
                      app_cont_args c a = app_cont_cont c (cabs (app (var_b 0) a)))) ).
  - intros n a H. simpl. destruct n.
    + reflexivity.
    + cbn; repeat f_equal; symmetry; apply testIN_open_rec; assumption.
  - intros x a H. cbn; repeat f_equal; symmetry; apply testIN_open_rec; assumption.
  - intros t H a H0. cbn; repeat f_equal; symmetry; apply testIN_open_rec; assumption.
  - intros t H a H0 a0 H1. simpl. destruct t.
    + destruct n.
      * destruct (testINargs_rec 0 a) eqn:Ht.
        -- destruct a. simpl in Ht. rewrite Ht. f_equal.
           cbn; repeat f_equal; symmetry; apply testIN_open_rec; assumption.
        --  destruct a.  simpl in Ht. rewrite Ht. repeat f_equal. apply H0. split.
            ++ assumption.
            ++ reflexivity.
      * cbn; repeat f_equal; symmetry; apply testIN_open_rec; assumption.
    + cbn; repeat f_equal; symmetry; apply testIN_open_rec; assumption.
    + cbn; repeat f_equal; symmetry; apply testIN_open_rec; assumption.
    + cbn; repeat f_equal; symmetry; apply testIN_open_rec; assumption.
  - intros u H l H0 c H1 u0 l0 c0 a H2. destruct H2.
    inversion H3. simpl. repeat f_equal. rewrite <- H7.  apply H1. assumption.
  - trivial.
  - trivial.
  - intros v H a H0. assert (H1 :cabs (app_term_x_args v a) = app_cont_args (cabs v) a).
    + simpl. reflexivity.
    + apply H. assumption.
Qed.

(***********************************************************************)
(** * Reduction rules *)
(***********************************************************************)

(** Note that we use [open] instead of
    substitution --- no variable names are involved.

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

Inductive beta1T : term -> term -> Prop :=
 | beta1_rule : forall (t u v:term),
     lcT (abs t) ->
     lcT u ->
     lcC (cabs v) ->
     beta1T (app (abs t) (args u anil (cabs v))) (openT v (openT t u)).

Inductive beta2T : term -> term -> Prop :=
 | beta2_rule : forall (t u u':term) (l:alist) (c:cont),
     lcT (abs t) ->
     lcT u ->
     lcT u' ->
     lcL l ->
     lcC c ->
     beta2T (app (abs t) (args u (acons u' l) c)) (app (openT t u) (args u' l c)).

Inductive betaT : term -> term -> Prop :=
 | beta_rule1 : forall (t t':term),
     beta1T t t' -> betaT t t'
 | beta_rule2 : forall (t t':term),
     beta2T t t' -> betaT t t'.

Inductive piT : term -> term -> Prop :=
 | pi_rule : forall (t:term) (a a':gmargs),
     lcT t ->
     lcA a ->
     lcA a' ->
     piT (app (app t a) a') (app t (app_args_args a a')).

Inductive betapiT : term -> term -> Prop :=
 | rule_beta : forall (t t':term),
     betaT t t' -> betapiT t t'
 | rule_pi : forall (t t':term),
     piT t t' -> betapiT t t'.

Inductive muA : gmargs -> gmargs -> Prop :=
| mu_rule : forall (u u':term) (l l':alist) (c':cont),
     lcT u ->
     lcT u' ->
     lcL l ->
     lcL l' ->
     lcC c' ->
     muA (args u l (cabs (app (var_b 0) (args u' l' c'))))
         (args u (l +@+ (u':::l')) c').

Lemma beta1_lc : forall e1 e2, beta1T e1 e2 -> lcT e1.
Proof. intros e1 e2 H. inversion H; auto. Qed.

Lemma beta2_lc : forall e1 e2, beta2T e1 e2 -> lcT e1.
Proof. intros e1 e2 H. inversion H; auto. Qed.

Lemma beta_lc : forall e1 e2, betaT e1 e2 -> lcT e1.
Proof.
  intros e1 e2 H. inversion H; auto.
  - apply (beta1_lc e1 e2). assumption.
  - apply (beta2_lc e1 e2). assumption.
Qed.

(* Lemma pi_lc : forall e1 e2, piT e1 e2 -> lcT e1. *)
(* Proof. intros e1 e2 H. inversion H; auto. Qed. *)

(* Lemma betapi_lc : forall e1 e2, betapiT e1 e2 -> lcT e1. *)
(* Proof. *)
(*   intros e1 e2 H. inversion H; auto. *)
(*   - apply (beta_lc e1 e2). assumption. *)
(*   - apply (pi_lc e1 e2). assumption. *)
(* Qed. *)

(***********************************************************************)
(** * Closures *)
(***********************************************************************)

(** WIP: mjf  *)

(**************************
 * Reflexive closures
 **************************)

(* Reflexive closure of R (in terms) *)
Inductive rcRTT (R : term -> term -> Prop) : term -> term -> Prop :=
 | rc_baseT : forall (t t':term),
     lcT t ->
     lcT t' ->  (* Probably not needed, since it follows from the other two. *)
     R t t' -> rcRTT R t t'
 | rc_reflT : forall (t :term), lcT t -> rcRTT R t t.

(* Reflexive closure of R (in gmargs) *)
Inductive rcRAA (R : gmargs -> gmargs -> Prop) : gmargs -> gmargs -> Prop :=
 | rc_baseA : forall (a a':gmargs),
     lcA a ->
     lcA a' ->  (* Probably not needed, since it follows from the other two. *)
     R a a' -> rcRAA R a a'
 | rc_reflA : forall (a :gmargs), lcA a -> rcRAA R a a.

(* Reflexive closure of R (in alist) *)
Inductive rcRLL (R : alist -> alist -> Prop) : alist -> alist -> Prop :=
 | rc_baseL : forall (l l':alist),
     lcL l ->
     lcL l' ->  (* Probably not needed, since it follows from the other two. *)
     R l l' -> rcRLL R l l'
 | rc_reflL : forall (l :alist), lcL l -> rcRLL R l l.

(* Reflexive closure of R (in cont) *)
Inductive rcRCC (R : cont -> cont -> Prop) : cont -> cont -> Prop :=
 | rc_baseC : forall (c c':cont),
     lcC c ->
     lcC c' ->  (* Probably not needed, since it follows from the other two. *)
    R c c' -> rcRCC R c c'
 | rc_reflC : forall (c :cont), lcC c -> rcRCC R c c.

(**************************
 * Transitive closures
 **************************)

(* Transitive closure of R (in terms) *)
Inductive tcRTT (R : term -> term -> Prop) : term -> term -> Prop :=
 | tc_base : forall (t t':term),
     lcT t ->
     lcT t' ->  (* Probably not needed, since it follows from the other two. *)
     R t t' -> tcRTT R t t'
 | tc_trans : forall (t t' t'':term),
     tcRTT R t t' -> tcRTT R t' t'' -> tcRTT R t t''.

(*......*)

(**************************
 * Reflexive-transitive closures
 **************************)

(* Reflexive-transitive closure of R (in terms) *)

Definition rtcRTT (R : term -> term -> Prop) : term -> term -> Prop := tcRTT (rcRTT R).

(*......*)

(**************************
 * Compatible closures
 **************************)

(* Compatible closure of R (in terms) *)

Inductive ccRTT (R : term -> term -> Prop) : term -> term -> Prop :=
 | cc_base : forall (t t':term),
     R t t' -> ccRTT R t t'  (* here we are assuming that (R t t') -> lcT t /\ lcT t',
                               which is ok for beta but has to be proved for the other rules *)
 (* the alternative definition is
    | cc_base : forall (t t':term), lcT t ->  lcT t' ->  R t t' -> ccRTT R t t'    *)
 | cc_abs : forall (t t':term) (L:vars),
     (forall (x:var), x `notin` L ->
     ccRTT R (openT t (var_f x)) (openT t' (var_f x))) -> ccRTT R (abs t) (abs t')
 | cc_app1 : forall (t t':term) (a:gmargs), lcA a ->
     ccRTT R t t' -> ccRTT R (app t a) (app t' a)
 | cc_app2 : forall (t:term) (a a':gmargs), lcT t ->
     ccRTA R a a' -> ccRTT R (app t a) (app t a')
with ccRTA (R : term -> term -> Prop) : gmargs -> gmargs -> Prop :=    (* in gmargs *)
 | cc_args1 : forall (u u':term) (l:alist) (c:cont), lcL l -> lcC c ->
     ccRTT R u u' -> ccRTA R (args u l c) (args u' l c)
 | cc_args2 : forall (u:term) (l l':alist) (c:cont), lcT u -> lcC c ->
     ccRTL R l l' -> ccRTA R (args u l c) (args u l' c)
 | cc_args3 : forall (u:term) (l:alist) (c c':cont), lcT u -> lcL l ->
     ccRTC R c c' -> ccRTA R (args u l c) (args u l c')
with ccRTL (R : term -> term -> Prop) : alist -> alist -> Prop :=     (* in alist *)
 | cc_head : forall (u u':term) (l:alist) , lcL l ->
     ccRTT R u u' -> ccRTL R (acons u l) (acons u' l)
 | cc_tail : forall (u :term) (l l':alist) , lcT u ->
     ccRTL R l l' -> ccRTL R (acons u l) (acons u l')
with ccRTC (R : term -> term -> Prop) : cont -> cont -> Prop :=       (* in cont *)
 | cc_cabs : forall (v v':term) (L:vars),
     (forall (x:var), x `notin` L ->
     ccRTT R (openT v (var_f x))  (openT v' (var_f x)))
      -> ccRTC R (cabs v) (cabs v').

Scheme ccRTT_ind_4 := Induction for ccRTT Sort Prop
  with ccRTA_ind_4 := Induction for ccRTA Sort Prop
  with ccRTL_ind_4 := Induction for ccRTL Sort Prop
  with ccRTC_ind_4 := Induction for ccRTC Sort Prop.

Combined Scheme ccRT_mutind from
         ccRTT_ind_4, ccRTA_ind_4, ccRTL_ind_4, ccRTC_ind_4.

(* Compatible closure of R (in gmargs) *)
Inductive ccRAT (R : gmargs -> gmargs -> Prop) : term -> term -> Prop :=     (* in terms *)
 | ccA_abs : forall (t t':term) (L:vars),
     (forall (x:var), x `notin` L ->
     ccRAT R (t^x) (t'^x) )-> ccRAT R (abs t) (abs t')
 | ccA_app1 : forall (t t':term) (a:gmargs), lcA a ->
     ccRAT R t t' -> ccRAT R (app t a) (app t' a)
 | ccA_app2 : forall (t:term) (a a':gmargs), lcT t ->
     ccRAA R a a' -> ccRAT R (app t a) (app t a')
with ccRAA (R : gmargs -> gmargs -> Prop) : gmargs -> gmargs -> Prop :=     (* in gmargs *)
 | ccA_base : forall (a a':gmargs),
     R a a' -> ccRAA R a a'   (* here we are assuming that (R t t') -> lcT t /\ lcT t',
                                which has to be proved for the other rules *)
 (* the alternative definition is
 | ccA_base : forall (a a':gmargs), lcA a -> lcA a' -> R a a' -> ccRAA R a a'    *)
 | ccA_args1 : forall (u u':term) (l:alist) (c:cont), lcL l -> lcC c ->
     ccRAT R u u' -> ccRAA R (args u l c) (args u' l c)
 | ccA_args2 : forall (u:term) (l l':alist) (c:cont), lcT u -> lcC c ->
     ccRAL R l l' -> ccRAA R (args u l c) (args u l' c)
 | ccA_args3 : forall (u:term) (l:alist) (c c':cont), lcT u -> lcL l ->
     ccRAC R c c' -> ccRAA R (args u l c) (args u l c')
with ccRAL (R : gmargs -> gmargs -> Prop) : alist -> alist -> Prop :=        (* in alist *)
 | ccA_head : forall (u u':term) (l:alist), lcL l ->
     ccRAT R u u' -> ccRAL R (acons u l) (acons u' l)
 | ccA_tail : forall (u :term) (l l':alist), lcT u ->
     ccRAL R l l' -> ccRAL R (acons u l) (acons u l')
with ccRAC (R : gmargs -> gmargs -> Prop) : cont -> cont -> Prop :=          (* in cont *)
 | ccA_cabs : forall (v v':term) (L:vars),
     (forall (x:var), x `notin` L -> ccRAT R (v^x) (v'^x) )
     -> ccRAC R (cabs v) (cabs v').

Scheme ccRAT_ind_4 := Induction for ccRAT Sort Prop
  with ccRAA_ind_4 := Induction for ccRAA Sort Prop
  with ccRAL_ind_4 := Induction for ccRAL Sort Prop
  with ccRAC_ind_4 := Induction for ccRAC Sort Prop.

Combined Scheme ccRA_mutind from
         ccRAT_ind_4, ccRAA_ind_4, ccRAL_ind_4, ccRAC_ind_4.

(* Compatible closure of RT and RA *)
Inductive ccRTRAT (RT:term->term->Prop) (RA:gmargs->gmargs->Prop) : term -> term -> Prop :=   (* in terms *)
 | ccTA_baseT : forall (t t':term),
     RT t t' -> ccRTRAT RT RA t t'  (* here we are assuming that (RT t t') -> lcT t /\ lcT t',
                                      which has to be proved for the other rules *)
(* the alternative definition is
 | ccTA_baseT : forall (t t':term),
     lcT t -> lcT t' ->  RT t t' -> ccRTRAT RT RA t t' *)
 | ccTA_abs :forall (t t':term) (L:vars),
     (forall (x:var), x `notin` L -> ccRTRAT RT RA (t^x) (t'^x)) ->
     ccRTRAT RT RA (abs t) (abs t')
 | ccTA_app1 : forall (t t':term) (a:gmargs), lcA a ->
     ccRTRAT RT RA t t' -> ccRTRAT RT RA (app t a) (app t' a)
 | ccTA_app2 : forall (t:term) (a a':gmargs), lcT t ->
     ccRTRAA RT RA a a' -> ccRTRAT RT RA (app t a) (app t a')
with ccRTRAA (RT:term->term->Prop) (RA:gmargs->gmargs->Prop) : gmargs -> gmargs -> Prop :=    (* in gmargs *)

 | ccTA_baseA : forall (a a':gmargs),
     RA a a' -> ccRTRAA RT RA a a' (* here we are assuming that (RA a a') -> lcA a /\ lcA a',
                                which has to be proved for the other rules *)
 (* the alternative definition is
 | ccTA_baseA : forall (a a':gmargs), lcA a -> lcA a' -> RA a a' -> ccRTRAA RT RA a a'   *)
 | ccTA_args1 : forall (u u':term) (l:alist) (c:cont), lcL l -> lcC c ->
     ccRTRAT RT RA u u' -> ccRTRAA RT RA (args u l c) (args u' l c)
 | ccTA_args2 : forall (u:term) (l l':alist) (c:cont), lcT u -> lcC c ->
     ccRTRAL RT RA l l' -> ccRTRAA RT RA (args u l c) (args u l' c)
 | ccTA_args3 : forall (u:term) (l:alist) (c c':cont), lcT u -> lcL l ->
     ccRTRAC RT RA c c' -> ccRTRAA RT RA (args u l c) (args u l c')
with ccRTRAL (RT:term->term->Prop) (RA:gmargs->gmargs->Prop) : alist -> alist -> Prop :=     (* in alist *)
 | ccTA_head : forall (u u':term) (l:alist), lcL l ->
     ccRTRAT RT RA u u' -> ccRTRAL RT RA (acons u l) (acons u' l)
 | ccTA_tail : forall (u :term) (l l':alist), lcT u ->
     ccRTRAL RT RA l l' -> ccRTRAL RT RA (acons u l) (acons u l')
with ccRTRAC (RT:term->term->Prop) (RA:gmargs->gmargs->Prop) : cont -> cont -> Prop :=        (* in cont *)
 | ccTA_cabs : forall (v v':term) (L:vars),
     (forall (x:var), x `notin` L -> ccRTRAT RT RA (v^x) (v'^x)) ->
     ccRTRAC RT RA (cabs v) (cabs v').

Scheme ccRTRAT_ind_4 := Induction for ccRTRAT Sort Prop
  with ccRTRAA_ind_4 := Induction for ccRTRAA Sort Prop
  with ccRTRAL_ind_4 := Induction for ccRTRAL Sort Prop
  with ccRTRAC_ind_4 := Induction for ccRTRAC Sort Prop.

Combined Scheme ccRTRA_mutind from
         ccRTRAT_ind_4, ccRTRAA_ind_4, ccRTRAL_ind_4, ccRTRAC_ind_4.

Definition ccBeta1 t t' := ccRTT beta1T t t'.
Definition ccBeta2 t t' := ccRTT beta2T t t'.
Definition ccBeta t t' := ccRTT betaT t t'.
Definition ccPi t t' := ccRTT piT t t'.
Definition ccBetaPi t t' := ccRTT betapiT t t'.
Definition ccMu t t' := ccRAT muA t t'.
Definition ccBetaPiMu t t' := ccRTRAT betapiT muA t t'.

Hint Constructors beta1T beta2T betaT piT betapiT muA.
Hint Constructors ccRTT ccRTA ccRTL ccRTC.
Hint Constructors ccRAT ccRAA ccRAL ccRAC.
Hint Constructors ccRTRAT ccRTRAA ccRTRAL ccRTRAC.

(*************************************************************************)
(** Associativity of append                                              *)
(*************************************************************************)

Definition pi_refcompCT := rcRTT (ccRTT piT).
Definition pi_refcompCA := rcRAA (ccRTA piT).
Definition pi_refcompCC := rcRCC (ccRTC piT).

Definition ccT_rc_pi := ccRTT (rcRTT piT).
Definition ccA_rc_pi := ccRTA (rcRTT piT).
Definition ccC_rc_pi := ccRTC (rcRTT piT).

Definition refccT_rc_pi := rcRTT (ccRTT (rcRTT piT)).
Definition refccA_rc_pi := rcRAA (ccRTA (rcRTT piT)).
Definition refccC_rc_pi := rcRCC (ccRTC (rcRTT piT)).

Lemma lcA_appA : forall a a', lcA a -> lcA a' -> lcA (app_args_args a a').
Proof.
  intros a a' H H0. destruct a. simpl. inversion_clear H. constructor; try assumption.
Admitted.

Lemma lcC_appCA : forall c a, lcC c -> lcA a -> lcC (app_cont_args c a).
Proof.
  intros c a H H0.
Admitted.

Lemma lc_appAA_appCA :
  (forall t:term, True) /\
  (forall a a', lcA a -> lcA a' -> lcA (app_args_args a a')) /\
  (forall l:alist, True) /\
  (forall c a, lcC c -> lcA a -> lcC (app_cont_args c a)).
Proof.
  apply (term_gmargs_alist_cont_mutind
  (fun t:term => True)
  (fun a => forall a', lcA a -> lcA a' -> lcA (app_args_args a a'))
  (fun l:alist => True)
  (fun c => forall a, lcC c -> lcA a -> lcC (app_cont_args c a))); try trivial.
  - (* gmargs *)
    intros u H l H0 c H1 a' H2 H3. inversion_clear H2. simpl. constructor; try assumption.
    apply H1; assumption.
  - (* cont *)
    intros v H a H0 H1. simpl. inversion_clear H0. constructor. intros x. destruct v eqn:vvv.
    + cbn. destruct (lt_eq_lt_dec n 0) eqn:test.
      * inversion s.
        -- simpl.
Admitted.

Lemma lcT_appT : forall t a a', lcT t -> lcA a -> lcA a' -> lcT (app t (app_args_args a a')).
Admitted.

Lemma lcA_appAA_appA : forall a a' a'', lcA a ->  lcA a' -> lcA a'' ->
                                  lcA (app_args_args (app_args_args a a') a'').
Admitted.

Lemma lcA_appA_appAA : forall a a' a'', lcA a ->  lcA a' -> lcA a'' ->
                                  lcA (app_args_args a (app_args_args a' a'')).
Admitted.

Lemma lcA_appC_appC : forall u l c a' a'', lcT u -> lcL l -> lcC c ->  lcA a' -> lcA a'' ->
                                      lcA (args u l (app_cont_args (app_cont_args c a') a'')).
Admitted.

Lemma lcC_appTx_appTx : forall v a a', lcT v  ->  lcA a -> lcA a' ->
                                    lcC (cabs (app_term_x_args (app_term_x_args v a) a')).
Admitted.

Lemma open_app : forall u t a, openT (app t a) u = app (openT t u) (openA a u).
Proof. reflexivity. Qed.

Lemma open_args : forall u t l c, openA (args t l c) u = args (openT t u) (openL l u) (openC c u).
Proof. reflexivity. Qed.

Lemma lc_open : forall u, lcT u ->
                     (forall t, lcT t -> lcT (openT t u)) /\
                     (forall a, lcA a -> lcA (openA a u)) /\
                     (forall l, lcL l -> lcL (openL l u)) /\
                     (forall c, lcC c -> lcC (openC c u)) .
Admitted. (*---AQUI---*)

Lemma  lcT_lcA_openA : forall t a, lcT t -> lcA a -> lcA (openA a t).
Proof.
  intros t a H H0.  apply lc_open in H. destruct H. destruct H1. apply H1. assumption.
Qed.

Lemma pi_lc : forall e1 e2, piT e1 e2 -> lcT e1.
Proof.
  intros e1 e2 H. inversion H; auto.
Qed.

Ltac lc_tac :=
   match goal with
   | [ |- lcT (app _ (app_args_args _ _ )) ] => apply lcT_appT; assumption

   | [ |- lcT (app _ (app_args_args (app_args_args _ _ ) _ ))] => constructor; [assumption | apply lcA_appAA_appA ; assumption ]

   | [ |- lcT (app _ (app_args_args _ (app_args_args _ _))) ] => constructor; [assumption | apply lcA_appA_appAA ; assumption ]

   | [ |- lcT (app (app _ _) _) ] => constructor; [constructor;assumption | assumption]
   end.

(*---------------------------------------------------------------------*)
(*
Lemma append_assoc : (forall t a a', lcT t -> lcA a -> lcA a' ->
                         (refccT_rc_pi (app_term_args (app_term_args t a) a')
                                       (app_term_args t (app_args_args a a'))) /\
                         (refccT_rc_pi (app_term_x_args (app_term_x_args t a) a')
                                       (app_term_x_args t (app_args_args a a'))) ) /\
                     (forall a a' a'', lcA a -> lcA a' -> lcA a'' ->
                                  refccA_rc_pi (app_args_args (app_args_args a a') a'')
                                               (app_args_args a (app_args_args a' a''))) /\
                     (forall l:alist, True) /\
                     (forall c a a', lcC c -> lcA a -> lcA a' ->
                                refccC_rc_pi (app_cont_args (app_cont_args c a) a')
                                             (app_cont_args c (app_args_args a a'))).
Proof.
  apply (term_gmargs_alist_cont_mutind
           (fun t => forall a a', lcT t -> lcA a -> lcA a' ->
                          (refccT_rc_pi (app_term_args (app_term_args t a) a')
                                        (app_term_args t (app_args_args a a'))) /\
                          (refccT_rc_pi (app_term_x_args (app_term_x_args t a) a')
                                        (app_term_x_args t (app_args_args a a'))) )
           (fun a => forall a' a'', lcA a -> lcA a' -> lcA a'' ->
                            refccA_rc_pi (app_args_args (app_args_args a a') a'')
                                         (app_args_args a (app_args_args a' a'')))
           (fun l => True)
           (fun c => forall a a', lcC c -> lcA a -> lcA a' ->
                          refccC_rc_pi (app_cont_args (app_cont_args c a) a')
                                       (app_cont_args c (app_args_args a a'))) ).
  - (* var_b *)
    intros n a a' H H0 H1. inversion H.
  - (* var_f *)
    intros x a a' H H0 H1; split.
    + simpl. unfold refccT_rc_pi. apply rc_reflT. apply lcT_appT; assumption.
    + simpl. unfold refccT_rc_pi. apply rc_baseT; try lc_tac.
      * apply cc_base; try lc_tac. apply rc_baseT; try lc_tac. constructor; assumption.
  - (* abs *)
    intros t H a a' H0 H1 H2. split.
    + simpl. unfold refccT_rc_pi. apply rc_reflT.lc_tac.
    + simpl. unfold refccT_rc_pi. constructor; try lc_tac. apply cc_base; try lc_tac.
      apply rc_baseT; try lc_tac. constructor; assumption.
  - (* app *)
    intros t H a H0 a0 a' H1 H2 H3.
    assert (Haux: (forall a a' : gmargs, lcT t -> lcA a -> lcA a' ->
      refccT_rc_pi (app_term_args (app_term_args t a) a') (app_term_args t (app_args_args a a')) /\
      refccT_rc_pi (app_term_x_args (app_term_x_args t a) a')
                   (app_term_x_args t (app_args_args a a'))) ->
                (forall a a' : gmargs, lcT t -> lcA a -> lcA a' ->
                                  refccT_rc_pi (app_term_args (app_term_args t a) a')
                                               (app_term_args t (app_args_args a a'))) /\
                (forall a a' : gmargs, lcT t -> lcA a -> lcA a' ->
                                  refccT_rc_pi (app_term_x_args (app_term_x_args t a) a')
                                               (app_term_x_args t (app_args_args a a'))) ).
    { intros H4; split;  intros a1 a'0 H5 H6 H7; apply H4; assumption. }
    apply Haux in H. destruct H. clear Haux. split.
    + simpl. inversion_clear H1. apply rc_baseT; try lc_tac. apply cc_app2.
      specialize (H0 a0 a' H6 H2 H3).

*)

(*---------------------------------------------------------------------*)

(*
Lemma append_assoc : (forall t a a', lcT t -> lcA a -> lcA a' ->
                         (ccT_rc_pi (app_term_args (app_term_args t a) a')
                                       (app_term_args t (app_args_args a a'))) /\
                         (ccT_rc_pi (app_term_x_args (app_term_x_args t a) a')
                                       (app_term_x_args t (app_args_args a a'))) ) /\
                     (forall a a' a'', lcA a -> lcA a' -> lcA a'' ->
                                  ccA_rc_pi (app_args_args (app_args_args a a') a'')
                                               (app_args_args a (app_args_args a' a''))) /\
                     (forall l:alist, True) /\
                     (forall c a a', lcC c -> lcA a -> lcA a' ->
                                ccC_rc_pi (app_cont_args (app_cont_args c a) a')
                                             (app_cont_args c (app_args_args a a'))).
Proof.
  apply (term_gmargs_alist_cont_mutind
           (fun t => forall a a', lcT t -> lcA a -> lcA a' ->
                          (ccT_rc_pi (app_term_args (app_term_args t a) a')
                                        (app_term_args t (app_args_args a a'))) /\
                          (ccT_rc_pi (app_term_x_args (app_term_x_args t a) a')
                                        (app_term_x_args t (app_args_args a a'))) )
           (fun a => forall a' a'', lcA a -> lcA a' -> lcA a'' ->
                            ccA_rc_pi (app_args_args (app_args_args a a') a'')
                                         (app_args_args a (app_args_args a' a'')))
           (fun l => True)
           (fun c => forall a a', lcC c -> lcA a -> lcA a' ->
                          ccC_rc_pi (app_cont_args (app_cont_args c a) a')
                                       (app_cont_args c (app_args_args a a'))) ).
  - (* var_b *)
    intros n a a' H H0 H1. inversion H.
  - (* var_f *)
    intros x a a' H H0 H1; split.
    + simpl. unfold ccT_rc_pi. apply cc_base; try lc_tac. apply rc_reflT; lc_tac.
    + simpl. unfold ccT_rc_pi. apply cc_base; try lc_tac. constructor; try lc_tac.
      constructor; assumption.
  - (* abs *)
    intros t H a a' H0 H1 H2. split.
    + simpl. apply cc_base; try lc_tac. apply rc_reflT; lc_tac.
    + simpl. unfold ccT_rc_pi. apply cc_base; try lc_tac. apply rc_baseT; try lc_tac.
      constructor; assumption.
  - (* app *)
    intros t H a H0 a0 a' H1 H2 H3.
    assert (Haux: (forall a a' : gmargs, lcT t -> lcA a -> lcA a' ->
      ccT_rc_pi (app_term_args (app_term_args t a) a') (app_term_args t (app_args_args a a')) /\
      ccT_rc_pi (app_term_x_args (app_term_x_args t a) a')
                   (app_term_x_args t (app_args_args a a'))) ->
                (forall a a' : gmargs, lcT t -> lcA a -> lcA a' ->
                                  ccT_rc_pi (app_term_args (app_term_args t a) a')
                                               (app_term_args t (app_args_args a a'))) /\
                (forall a a' : gmargs, lcT t -> lcA a -> lcA a' ->
                                  ccT_rc_pi (app_term_x_args (app_term_x_args t a) a')
                                               (app_term_x_args t (app_args_args a a'))) ).
    { intros H4; split;  intros a1 a'0 H5 H6 H7; apply H4; assumption. }
    apply Haux in H. destruct H. clear Haux. split.
    + simpl. inversion_clear H1. unfold ccT_rc_pi. apply cc_app2. apply H0; assumption.
    + inversion_clear H1. simpl. destruct t eqn:ttt.
      * inversion H5.
      * simpl.

*)

(* ------------------------------------------------- *)

Lemma append_assoc : (forall t a a', lcT t -> lcA a -> lcA a' ->
                         (pi_refcompCT (app_term_args (app_term_args t a) a')
                                       (app_term_args t (app_args_args a a'))) /\
                         (pi_refcompCT (app_term_x_args (app_term_x_args t a) a')
                                       (app_term_x_args t (app_args_args a a'))) ) /\
                     (forall a a' a'', lcA a -> lcA a' -> lcA a'' ->
                                  pi_refcompCA (app_args_args (app_args_args a a') a'')
                                               (app_args_args a (app_args_args a' a''))) /\
                     (forall l:alist, True) /\
                     (forall c a a', lcC c -> lcA a -> lcA a' ->
                                pi_refcompCC (app_cont_args (app_cont_args c a) a')
                                             (app_cont_args c (app_args_args a a'))).
Proof.
  apply (term_gmargs_alist_cont_mutind
           (fun t => forall a a', lcT t -> lcA a -> lcA a' ->
                          (pi_refcompCT (app_term_args (app_term_args t a) a')
                                        (app_term_args t (app_args_args a a'))) /\
                          (pi_refcompCT (app_term_x_args (app_term_x_args t a) a')
                                        (app_term_x_args t (app_args_args a a'))) )
           (fun a => forall a' a'', lcA a -> lcA a' -> lcA a'' ->
                            pi_refcompCA (app_args_args (app_args_args a a') a'')
                                         (app_args_args a (app_args_args a' a'')))
           (fun l => True)
           (fun c => forall a a', lcC c -> lcA a -> lcA a' ->
                          pi_refcompCC (app_cont_args (app_cont_args c a) a')
                                       (app_cont_args c (app_args_args a a'))) ).
  - (* var_b *)
    intros n a a' H H0 H1. inversion H.
  - (* var_f *)
    intros x a a' H H0 H1; split.
    + simpl. unfold pi_refcompCT. apply rc_reflT. lc_tac.
    + simpl. unfold pi_refcompCT. constructor; try lc_tac.
      * constructor; try lc_tac. constructor; assumption.
  - (* abs *)
    intros t H a a' H0 H1 H2. split.
    + simpl. apply rc_reflT. lc_tac.
    + simpl. unfold pi_refcompCT. constructor; try lc_tac.
      * apply cc_base; try lc_tac. constructor; assumption.
  - (* app *)
    intros t H a H0 a0 a' H1 H2 H3.
    assert (Haux: (forall a a' : gmargs, lcT t -> lcA a -> lcA a' ->
      pi_refcompCT (app_term_args (app_term_args t a) a') (app_term_args t (app_args_args a a')) /\
      pi_refcompCT (app_term_x_args (app_term_x_args t a) a')
                   (app_term_x_args t (app_args_args a a'))) ->
                (forall a a' : gmargs, lcT t -> lcA a -> lcA a' ->
                                  pi_refcompCT (app_term_args (app_term_args t a) a')
                                               (app_term_args t (app_args_args a a'))) /\
                (forall a a' : gmargs, lcT t -> lcA a -> lcA a' ->
                                  pi_refcompCT (app_term_x_args (app_term_x_args t a) a')
                                               (app_term_x_args t (app_args_args a a'))) ).
    { intros H4; split;  intros a1 a'0 H5 H6 H7; apply H4; assumption. }
    apply Haux in H. destruct H. clear Haux. split.
 (*   + simpl. inversion_clear H1. unfold pi_refcompCT. constructor; try lc_tac.
      apply cc_app2. unfold pi_refcompCA in H0. apply (H0 a0 a' H6 H2) in H3.
      inversion_clear H3.
      * assumption.
      *
*)
    (*----- alternativa -----*)
    (*
    + simpl. unfold pi_refcompCT. constructor.
      * inversion_clear H1. lc_tac.
      * inversion_clear H1. lc_tac.
      * inversion_clear H1. apply cc_app2. admit.
    + simpl. destruct t eqn:ttt.
      * destruct n eqn:nnn; inversion H1.
        -- destruct (testINargs_rec 0 a); inversion H6. admit. admit.
        -- inversion H6. admit.
      * simpl. inversion_clear H1. unfold pi_refcompCT. apply rc_baseT. constructor.
        -- constructor; [constructor;assumption | assumption].
        -- assumption.
        -- constructor; [constructor;assumption | apply lcA_appA; assumption].
        -- apply cc_base.
           ++ constructor. constructor; [constructor;assumption | assumption]. assumption.
           ++ constructor; [constructor; assumption | apply lcA_appA; assumption].
           ++ constructor; [constructor; assumption | assumption | assumption].
      * simpl. unfold pi_refcompCT. inversion_clear H1. apply rc_baseT.
        -- admit.
        -- admit.
        -- apply cc_base.
           ++ admit.
           ++ admit.
           ++ constructor; [constructor; assumption | assumption | assumption].
      * simpl. unfold pi_refcompCT. inversion_clear H1. apply rc_baseT.
          (* tem que se usar a indução !!! *)
           admit. admit. admit.
  - (* args *)
    intros u H l H0 c H1 a' a'' H2 H3 H4. simpl. inversion_clear H2. constructor.
    + apply lcA_appC_appC; assumption.
    + apply cc_args3. unfold pi_refcompCC in H1. destruct (H1 a' a''); try assumption. admit.
  - (* anil *) trivial.
  - (* acons *) trivial.
  - (* cabs *)
    intros v H a a' H0 H1 H2. simpl. constructor.
    + inversion H0. destruct v.
      * simpl. destruct n.
        -- destruct (testINargs_rec 0 a) eqn:zzz.
           ++ constructor. intro x. rewrite -> open_app. constructor.
              ** rewrite -> open_app. cbn. constructor.
                 --- constructor.
                 --- apply lcT_lcA_openA; [constructor|assumption].
                ** apply lcT_lcA_openA; [constructor|assumption].
           ++ constructor. intro x. rewrite -> open_app. constructor.
              ** cbn. constructor.
              **  apply lcT_lcA_openA.
                  --- constructor.
                  --- apply lcA_appA; assumption.
        -- constructor. intro x. rewrite -> open_app. constructor.
           ++ rewrite -> open_app. constructor.
              ** apply H4.
              ** apply lcT_lcA_openA; [constructor|assumption].
           ++ apply lcT_lcA_openA; [constructor|assumption].
      * simpl. constructor. intro x0. rewrite -> open_app. constructor.
        -- rewrite -> open_app. constructor.
           ++ cbn. constructor.
           ++ apply lcT_lcA_openA; [constructor|assumption].
        -- apply lcT_lcA_openA; [constructor|assumption].
      * simpl. constructor. intro x. rewrite -> open_app. constructor.
        -- rewrite -> open_app. constructor. apply H4.
           apply lcT_lcA_openA; [constructor|assumption].
        -- apply lcT_lcA_openA; [constructor|assumption].
      * admit. (* apply pi_lc. *)
    + constructor. admit. (* apply H. *)

*)
Admitted.

Definition ccBeta1T := ccRTT beta1T.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable equilateral_ : Universe -> Universe -> Universe -> Prop.
Variable cut_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable proposition_01_1 : (forall A B : Universe, (exists X : Universe, (A <> B -> (equilateral_ A B X /\ triangle_ A B X)))).
Variable deftriangle_2 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_3 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable defequilateral_4 : (forall A B C : Universe, (equilateral_ A B C -> (cong_ A B B C /\ cong_ B C C A))).
Variable defequilateral2_5 : (forall A B C : Universe, ((cong_ A B B C /\ cong_ B C C A) -> equilateral_ A B C)).
Variable lemma_doublereverse_6 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable lemma_congruenceflip_7 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable defcollinear_8 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_9 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_10 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_11 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_12 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_13 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_14 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_15 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_extension_16 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable axiom_betweennesssymmetry_17 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_betweennotequal_18 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_inequalitysymmetric_19 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_20 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable postulate_Pasch_inner_21 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B Q C /\ ~(col_ A C B))) -> (betS_ A X Q /\ betS_ B X P)))).
Variable lemma_congruencesymmetric_22 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruencetransitive_23 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable cn_equalityreverse_24 : (forall A B : Universe, cong_ A B B A).
Variable axiom_5_line_25 : (forall A B C D E F G H : Universe, ((betS_ A B C /\ (betS_ E F G /\ (cong_ B C F G /\ (cong_ A D E H /\ (cong_ B D F H /\ cong_ A B E F))))) -> cong_ D C H G)).
Variable cn_congruencereflexive_26 : (forall A B : Universe, cong_ A B A B).
Variable deflessthan_27 : (forall A B C D : Universe, (exists X : Universe, (lt_ A B C D -> (betS_ C X D /\ cong_ C X A B)))).
Variable deflessthan2_28 : (forall A B C D X : Universe, ((betS_ C X D /\ cong_ C X A B) -> lt_ A B C D)).
Variable proposition_03_29 : (forall A B C D E F : Universe, (exists X : Universe, ((lt_ C D A B /\ cong_ E F A B) -> (betS_ E X F /\ cong_ E X C D)))).
Variable lemma_differenceofparts_30 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (betS_ A B C /\ betS_ Xa Xb Xc))) -> cong_ B C Xb Xc)).
Variable lemma_interior5_31 : (forall A B C D Xa Xb Xc Xd : Universe, ((betS_ A B C /\ (betS_ Xa Xb Xc /\ (cong_ A B Xa Xb /\ (cong_ B C Xb Xc /\ (cong_ A D Xa Xd /\ cong_ C D Xc Xd))))) -> cong_ B D Xb Xd)).
Variable lemma_betweennesspreserved_32 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (cong_ B C Xb Xc /\ betS_ A B C))) -> betS_ Xa Xb Xc)).
Variable defcut_33 : (forall A B C D E : Universe, (cut_ A B C D E -> (betS_ A E B /\ (betS_ C E D /\ (~(col_ A B C) /\ ~(col_ A B D)))))).
Variable defcut2_34 : (forall A B C D E : Universe, ((betS_ A E B /\ (betS_ C E D /\ (~(col_ A B C) /\ ~(col_ A B D)))) -> cut_ A B C D E)).
Variable lemma_twolines_35 : (forall A B C D E F : Universe, ((cut_ A B C D E /\ (cut_ A B C D F /\ ~(col_ B C D))) -> E = F)).

Theorem proposition_10_36 : (forall A B : Universe, (exists X : Universe, (A <> B -> (betS_ A X B /\ cong_ X A X B)))).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import HoTT.
Require Import HoTT.Categories.
Require Import HoTT.Categories.Functor.Prod.Core.
Require Import HoTT.Categories.Category.Objects.
Require Import HoTT.Categories.NaturalTransformation.Paths.

Open Scope morphism.

Theorem qwe
`{Funext}
(C : PreCategory)
(F : Functor C set_cat)
(A : C)
(w : F A):
(F _1 1)%morphism w = w.
Proof.
  simple refine (@happly _ _ _ _ _ _).
  exact (@identity_of C set_cat F A).
Defined.

Section eqpro.
Context `{Funext} (C : Category) (A : C). (*H : Funext*)
Definition hA  := induced_snd (hom_functor C) A.

Section calc.
Context (X : C) (f: @morphism C A X).
Definition hAf := @morphism_of _ _ hA _ _ f.
Theorem fuho : hAf (identity A) = f.
Proof.
 unfold hAf.
 simpl.
 refine (@concat _ _ _ _ _ _ ).
 refine (@right_identity C A X (f o 1)).
 refine (@right_identity C A X f).
Defined.
End calc.

Section YonProo.
Context (F : Functor C set_cat).
Theorem u_to_T : F A -> NaturalTransformation hA F.
Proof.
  intro u.
  simple refine (@Build_NaturalTransformation _ _ _ _ _ _ ).
  - simpl.
    intro X.
    intro f.
    exact ((@Core.morphism_of _ _ F _ _ f) u).
  - simpl.
    intros s d m.
    simple refine (@path_forall _ _ _ _ _ _).
    intro j.
    simple refine (@concat _ _ _ _ _ _).  (*here*)
    + exact ((@morphism_of _ _ F _ _ (m o j)) u).
    + revert u.
      simple refine (@happly _ _ _ _ _).
      simple refine (@ap _ _ _ _ _ _).
      exact (@right_identity C _ _ (m o j)).
    + simple refine (@concat _ _ _ _ _ _).
      * exact (((F _1 m) o (F _1 j)) u).
      * revert u.
        simple refine (@happly _ _ _ _ _).
        simple refine (@composition_of _ _ F _ _ _ _ _).
      * reflexivity.
Defined.

Theorem T_to_u : NaturalTransformation hA F -> F A .
Proof.
  intro T.
  exact ((components_of T A) (@identity C A) ).
Defined.

Theorem Yoneda : Equiv (NaturalTransformation hA F) (F A).
Proof.
  simple refine (@BuildEquiv _ _ _ _).
  * exact T_to_u. (* F A <- Nat hA F *)
  * simple refine (@BuildIsEquiv _ _ _ _ _ _ _).
  simpl.
    + exact u_to_T. (* F A -> Nat hA F *)
    + simpl. (* Section -> *)
      intro u.
      simpl.
      refine (@qwe H C F A u). (*strange behaviour here*)
    + simpl. (* Section <- *)
      intro T.
      simple refine (@path_natural_transformation _ _ _ _ _ _ _ _ ).
      simpl.
      intro X .
      Check Core.components_of T X.
      simple refine (@path_forall _ _ _ _ _ _).
      intro f.
      unfold T_to_u.
      Check Core.components_of T X f.
      simple refine (@concat _ _ _ _ _ _).
      - exact (((F _1 f) o (T A)) 1).
      - reflexivity.
      - simple refine (@concat _ _ _ _ _ _).
        ** exact ((T X o hA _1 f) 1).
        ** simple refine ((@happly _ _ _ _ _) 1).
           exact (@commutes _ _ _ _ T A X f)^.
        ** simple refine (@concat _ _ _ _ _ _).
           ++ exact (T X (hA _1 f 1)).
           ++ reflexivity.
           ++ simple refine ((@ap _ _ _ _ _ _)).
              refine (@fuho _ _).
    + simpl.
      intro T.
      unfold qwe.
      refine (@path_contr _ _ _ _).
      simple refine (@BuildContr _ _ _ ).
      - simple refine (@qwe _ _ _ _ _).
      - intro y.
        refine (@path_ishprop _ _ _ _).
Defined.
End YonProo.
End eqpro.


From Complexity.Complexity Require Export Definitions EncodableP.
From Undecidability.L.Complexity Require Export LTD_def.
From Undecidability.L.Tactics Require Import LTactics.

From Undecidability.L.Datatypes Require Import LProd LOptions LTerm LUnit.
From Undecidability.L Require Export Functions.Decoding.

(** inspired by Papadimitriou *)

(** ** NP *)

Section NP_certificate_fix.
  Variable X Y : Type.

  Context `{Reg__X : encodable X}.
  Context `{RegY : encodable Y}.

  Definition inTimePoly {X} `{encodable X} `(P: X -> Prop):=
    exists f, inhabited (decInTime P f) /\ inOPoly f /\ monotonic f.

  Record polyCertRel (P: X -> Prop) (R: X -> Y -> Prop) : Type :=
    polyBoundedWitness_introSpec
      {
        p__pCR : nat -> nat;
        sound__pCR : forall x y, R x y -> P x;
        complete__pCR : forall x, P x -> exists (y:Y), R x y /\ size (enc y) <= p__pCR (size (enc x));
        poly__pCR : inOPoly p__pCR ;
        mono__pCR : monotonic p__pCR;
      }.

  Lemma polyCertRel_compPoly (P:X -> Prop) R:
    polyCertRel P R -> exists H : polyCertRel P R , inhabited (polyTimeComputable (p__pCR H)).
  Proof.
    intros R__spec.  destruct (inOPoly_computable (poly__pCR R__spec)) as (p'&?&Hbounds&?&?).
    unshelve eexists.
    exists p'.
    3-5:assumption.
    now apply sound__pCR.
    intros ? H'. edestruct (complete__pCR R__spec H') as (y&?&H'').
    do 2 esplit. easy.
    rewrite H'',Hbounds. easy.
  Qed.

  Lemma inTimePoly_compTime  (P:X -> Prop):
    inTimePoly P -> exists f, inhabited (polyTimeComputable f) /\ inhabited (decInTime P f) /\ inOPoly f /\ monotonic f.
  Proof.
    intros (time&[P__dec]&t__poly&t__mono).
    destruct (inOPoly_computable t__poly) as (p'&?&Hbounds&?&?).
    exists p'. repeat apply conj. 1,3,4:easy.
    split.
    eexists. 2:exact (correct__decInTime P__dec).
    eexists. eapply computesTime_timeLeq. 2:now apply extTCorrect.
    repeat intro;cbn [fst snd]. now rewrite Hbounds.
  Qed.

  (*
  Lemma polyCertRel_equiv {vX : X -> Prop} (P P' : X -> Prop) R :
    (forall x, P x <-> P' x)
    -> polyCertRel P R -> polyCertRel P' R.
  Proof.
    intros H. split;intros[].
    all:eexists;try eassumption;intros x. all:specialize (H x).
    all:firstorder.
  Qed.*)

End NP_certificate_fix.
Smpl Add 10 (simple apply poly__pCR) : inO.
Smpl Add 10 (simple apply mono__pCR) : inO.

Local Set Warnings "-cannot-define-projection".
Record inNP {X} `{encodable X} (P : X -> Prop) : Prop :=
  inNP_introSpec
    {
      R_NP : X  -> term -> Prop; (* certificate fixed to term for simplicity *)
      R_NP__comp : inTimePoly (fun '(x,y) => R_NP x y);
      R_NP__correct : polyCertRel P R_NP (*TODO: What if moved to spec__R(better: move condition externally)? and only require that some small certificate satisfies condition? It seems that we might want that every certificate is valid, but there must exist a small one? *)
    }.

Lemma inNP_intro {X Y} `{_:encodable X} `{encodable Y} `{@encInj Y _} {_:decodable Y} `(P:X -> Prop) (R : _ -> Y -> Prop):
  polyTimeComputable (decode Y)
  -> inTimePoly (fun '(x,y) => R x y)
  -> polyCertRel P R
  -> inNP P.
Proof.
  cbn.
  intros decode__comp R__comp R__bound.
  eexists (fun x y => exists y', y = enc y' /\ R x y').
  2:{
      exists (fun x => p__pCR R__bound x * c__termsize).
      3,4:solve [smpl_inO].
      -intros x y' (y&->&Hy). now eapply sound__pCR.
      -intros x ?. edestruct (complete__pCR R__bound) as (y&?&?). easy.
       exists (enc y);split. easy.
       rewrite size_term_enc. unfold c__termsize, c__natsizeS. lia.
  }
  { (*TODO: simplify*)
    destruct R__comp as (t__f&[R__comp]&?&mono_t__f).
    pose (f' (x:X*term) :=
            let '(x,y):= x in
            match decode Y y with
              None => false
            | Some y => (f__decInTime R__comp) (x,y)
            end).
    evar (t__f' : nat -> nat). [t__f']:intro.
    exists t__f'. repeat eapply conj.
    -split. exists f'.
     +unfold f'. extract.
      solverec.
      all:rewrite !size_prod. all:cbn [fst snd].
      *eapply decode_correct2 in H3 as <-.
       remember (size (enc a) + size (enc (enc y)) + 4) as n eqn:eqn.
       rewrite (mono_t__f _ n). 2:subst n;rewrite <- size_term_enc_r;lia.
       rewrite (mono__polyTC _ (x':=n)). 2:lia.
       unfold t__f';reflexivity.
      *rewrite (mono__polyTC _ (x':=(size (enc a) + size (enc b) + 4))). 2:lia.
       unfold t__f'. lia.
     +unfold f'. intros [x]. cbn.
      destruct decode  as [y| ] eqn:H'.
      *etransitivity. 2:unshelve eapply correct__decInTime;easy. cbn.
       eapply decode_correct2 in H'. symmetry in H'.
       split;[intros (y'&?&?)|intros ?].
       --cbn. enough (y = y') by congruence. eapply inj_enc. congruence.
       --eauto.
      *split.  2:eauto.
       intros (?&->&?). rewrite decode_correct in H'.  easy.
    -unfold t__f'. smpl_inO.
    -unfold t__f'. smpl_inO.
  }
Qed.

(* P *)
Definition inP (X : Type) `{_: encodable X}  (P : X -> Prop) := inTimePoly P.

(* P <<= NP *)

Lemma P_NP_incl (X : Type) `{encodable X}  (P : X -> Prop) :
  inP P -> inNP P.
Proof.
  intros H1. unfold inP in H1.
  eapply (inNP_intro (Y:= unit)) with (R := fun x _ => P x).
  - eapply linDec_polyTimeComputable.
  - destruct H1 as (f & H1 & H2 & H3). evar (f' : nat -> nat). exists f'.
    split.
    { destruct H1 as [H1]. destruct H1.
      constructor. exists (fun (p : X * unit) => let (x , _) := p in f__decInTime x).
      + extract. solverec. unfold monotonic in H3.
        rewrite H3 with (x' := size (enc (a, tt))). 2: { rewrite size_prod; cbn; lia. }
        [f']: intros n. subst f'. cbn.
        generalize (size (enc (a, tt))). intros; reflexivity.
      + intros [x ?]. cbn. apply correct__decInTime.
    }
    split; subst f'; smpl_inO.
  - exists (fun n => size (enc tt)).
    3, 4: smpl_inO.
    + intros x _. easy.
    + intros x H2. exists tt. easy.
Qed.

(** ** Poly Time Reduction*)

Generalizable Variable vY.
Record reducesPolyMO X Y `{encodable X} `{encodable Y} `(P : X -> Prop) `(Q : Y -> Prop) :Prop :=
  reducesPolyMO_intro {
      f : X -> Y;
      f__comp : polyTimeComputable f;
      f__correct : forall x, P x <-> Q (f x)
    }.

Notation "P ⪯p Q" := (reducesPolyMO P Q) (at level 50).

From Complexity.L.Datatypes Require Import LDepPair.

Lemma reducesPolyMO_elim X Y `{RX: encodable X} `{RY:encodable Y} `(P : X -> Prop) `(Q : Y -> Prop):
  P ⪯p Q ->
  exists f, inhabited (polyTimeComputable f)
  /\ (forall x , P x <-> Q (f x)).
Proof.
  intros [f ? ?]. eexists;split. all:easy.
Qed.

Lemma reducesPolyMO_reflexive X {regX : encodable X} (P : X -> Prop) : P ⪯p P.
Proof.
  eapply reducesPolyMO_intro with (f := fun x => x). 2:easy.
  exists (fun _ => 1). 4:exists (fun x => x).
  2,3,5,6:solve [ smpl_inO].
  -extract. solverec.
  -reflexivity.
Qed.

Lemma reducesPolyMO_transitive X Y Z {regX : encodable X} {regY : encodable Y} {regZ : encodable Z}
  (P : X -> Prop) (Q : Y -> Prop) (R : Z -> Prop) :
  P ⪯p Q -> Q ⪯p R -> P ⪯p R.
Proof.
  intros [f f__c  Hf] [g g__c Hg ].
  eapply reducesPolyMO_intro with (f:= fun x =>g (f x)).
  2:{intros ?. now rewrite Hf,Hg. }
  (*destruct Cf as [t__f ? ? f__mono (sizef&H__sizef&?&?)] , Cg as [t__g ? ? g__mono (size__g&?&?&?)]. *)
  exists (fun x => time__polyTC f__c x + time__polyTC g__c (resSize__rSP f__c x) + 1).
  -extract. solverec.
   erewrite (mono__polyTC g__c). 2:now apply bounds__rSP . reflexivity.
  -smpl_inO.  eapply inOPoly_comp. all:smpl_inO.
  -smpl_inO.
  -exists (fun x => resSize__rSP g__c (resSize__rSP f__c x)).
   +intros. rewrite (bounds__rSP g__c), (mono__rSP g__c). 2:apply (bounds__rSP f__c). easy.
   +eapply inOPoly_comp. all:smpl_inO.
   +eapply monotonic_comp. all:smpl_inO.
Qed.

Lemma red_inNP X Y `{regX : encodable X} `{regY : encodable Y} (P : X -> Prop) `(Q : Y -> Prop) :
  P ⪯p Q -> inNP Q -> inNP P.
Proof.
  intros [f f__comp f__correct] [R polyR certR].
  exists (fun x z => R (f x) z).
  -(* destruct (polyRes__polyTC f__comp) as (size__f&Hsize__f&?&mono__sizef). *)
   destruct polyR as (time__R&[R__comp]&inO__timeR&mono__timeR).
   evar (time : nat -> nat). [time]:intros n.
   exists time. split.
   (*eexists (fun n => cnst n (*)polyTimeC__t n*) + time__R (time__polyTC f__comp (size__f n + n)) + 7). split.*)
   +split. exists (fun '(x,z)=> f__decInTime R__comp (f x,z)).
    *extract. solverec.
     all:rewrite !LProd.size_prod. all:cbn [fst snd]. set (n0:=size (enc a) + size (enc b) + 4).
     rewrite (mono__polyTC _ (x':=n0)). 2:subst n0;nia.
     erewrite (mono__timeR _ _).
     2:{ rewrite (bounds__rSP f__comp), (mono__rSP f__comp (x':=n0)). 2:unfold n0;lia. instantiate (1:=resSize__rSP f__comp n0 + n0). unfold n0;try lia. }
     unfold time. reflexivity.
    *intros [x c]. cbn. rewrite <- correct__decInTime;cbn. easy.
   +unfold time;split;smpl_inO.
    { eapply inOPoly_comp. all:smpl_inO. }
  -clear - certR f__correct f__comp.
   exists (fun x =>  p__pCR certR (resSize__rSP f__comp x)).
   +intros ? ? ?%(sound__pCR certR);cbn. now apply f__correct.
   +intros x Hx;cbn. apply f__correct in Hx. edestruct (complete__pCR certR) as (?&?&?). eauto. eexists;split. easy.
    rewrite H0. cbn. apply mono__pCR. apply bounds__rSP.
   +apply inOPoly_comp;smpl_inO.
   +smpl_inO.
Qed.

(** ** NP Hardness and Completeness *)
Definition NPhard X `{encodable X} (P : X -> Prop) :=
  forall Y `(encodableP Y) (Q:Y -> Prop),
    inNP Q -> Q ⪯p P.

Lemma red_NPhard X Y `{encodable X} `{encodable Y} (P : X -> Prop) `(Q:Y -> Prop)
  : P ⪯p Q -> NPhard P -> NPhard Q.
Proof.
  intros R hard.
  intros ? ? ? Q' H'. apply hard in H'. 2:easy.
  eapply reducesPolyMO_transitive  with (1:=H'). all:eassumption.
Qed.

Corollary NPhard_sig X `{encodable X} vX `(P : X -> Prop):
  NPhard (fun (x:{x | vX x}) => P (proj1_sig x)) -> NPhard P.
Proof.
  eapply red_NPhard.
  eapply reducesPolyMO_intro with (f := fun x => proj1_sig x). 2:easy.
  exists (fun _ => 2). 4:exists (fun x => x).
  2,3,5,6:solve [ smpl_inO].
  -extract. solverec.
  -reflexivity.
Qed.

Definition NPcomplete X `{encodable X} (P : X -> Prop) :=
  NPhard P /\ inNP P.

#[export]
Hint Unfold NPcomplete : core.


(*
 * SPDX-License-Identifier: MIT
 *
 *)
Inductive label {A} : Type :=
  Silent : label
| Action : A -> label
.

Inductive type : Set :=
| Access
| Bool
| Nat
| Unit
| TPair (t1 t2 : type)
.

Module Type GRANT_ACCESS.
  Parameter access : Set.
End GRANT_ACCESS.

Module Messages (GA : GRANT_ACCESS).

  Inductive message : type -> Type :=
  | Permission (acc : GA.access) : message Access
  | Content (n : nat) : message Nat
  | MsgPair {t1 t2} (m1 : message t1) (m2 : message t2) : message (TPair t1 t2)
  .

  Fixpoint typeDenote (t : type) :=
    match t with
    | Access => GA.access
    | Bool => bool
    | Nat => nat
    | Unit => unit
    | TPair t1 t2 => (typeDenote t1 * typeDenote t2)%type
    end
  .

  Definition extractContent (msg : message Nat) : nat :=
    match msg with
    | Content t => t
    end.

  Definition extractPermission (msg : message Access) : GA.access :=
    match msg with
    | Permission a => a
    end.

  Definition msgFst {t1 t2} (msg : message (TPair t1 t2)) : (message t1) :=
    match msg with
    | MsgPair m1 _ => m1
    end.

  Definition msgSnd {t1 t2} (msg : message (TPair t1 t2)) : (message t2) :=
    match msg with
    | MsgPair _ m2 => m2
    end.

End Messages.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                      SF_Closed.v                                   *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.
Require Import IntensionalLib.Wave_as_SF.SF_reduction.
Require Import IntensionalLib.Wave_as_SF.SF_Normal.

(* closed terms *)

Fixpoint maxvar (M: SF) :=
match M with
| Ref i => S i
| Op o  => 0
| App M1 M2 => max (maxvar M1) (maxvar M2)
end.

Lemma maxvar_app : forall M N, maxvar (App M N) = max (maxvar M) (maxvar N).
Proof. split_all. Qed.

Definition decreases  (rank: SF  -> nat) (red:termred):=
forall M N, red M N -> rank M >= rank N.

Lemma decreases_multi_step:
forall rank red, decreases rank red -> decreases rank (multi_step red).
Proof.
red. intros rank red D M N R;  induction R; split_all.
assert(rank M >= rank N) by eapply2 D.
assert(rank N >= rank P) by eapply2 IHR.
omega.
Qed.

Lemma left_component_preserves_maxvar : forall M, compound M ->
maxvar(left_component M) <= maxvar M.
Proof.
split_all.
inversion H; split_all; try omega; eapply2 max_is_max.
Qed.

Lemma right_component_preserves_maxvar : forall M, compound M ->
maxvar(right_component M) <= maxvar M.
Proof. split_all. inversion H; split_all; try omega; eapply2 max_is_max.
Qed.

Ltac max_l :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= m) by eapply2 max_is_max;
cut(m >= p); split_all; try omega
end.
Ltac max_r :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= n) by eapply2 max_is_max;
cut(n >= p); split_all; try omega
end.

Lemma closed_implies_passive : forall M, maxvar M = 0 -> status M = Passive.
Proof.
rank_tac. induction p; intros.
match goal with | H: 0>= rank ?M |- _ =>
assert(rank M >0) by eapply2 rank_positive; noway end .
induction M; split_all. discriminate.
generalize IHM1 H H0; clear IHM1 H H0; case M1; intros; try (auto; omega).
simpl in *. gen_case H0 (maxvar M2); omega.
(* 1 *)
rewrite IHM1.
gen2_case H H0 s; split_all. gen2_case H H0  s1; split_all.
 case o; split_all. apply IHp. omega. max_out. max_out.
simpl in *. omega. simpl in *;  max_out.
Qed.

Lemma decreases_maxvar_sf_seqred1: decreases maxvar sf_seqred1.
(*
forall M N, lamF_red1 M N -> maxvar N <= maxvar M.
*)
Proof.
cut(forall M N, sf_seqred1 M N -> maxvar N <= maxvar M).
split_all; red.

intros M N R; induction R; split_all; eauto; try (repeat (eapply2 max_monotonic); fail);
try omega; repeat (eapply2 max_max2); try (max_r; fail); try (repeat max_l; fail).
(* 5 *)
assert(max(maxvar M) (maxvar N) >= maxvar N) by max_r.
assert(max (max (maxvar M) (maxvar N)) (maxvar P) >= (max (maxvar M) (maxvar N))) by max_l.
omega.
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l. omega.
(* 2 *)
max_l. max_l. max_r.
Qed.

Lemma decreases_maxvar_lamF_red : decreases maxvar sf_seqred.
Proof. eapply2 decreases_multi_step. eapply2 decreases_maxvar_sf_seqred1. Qed.

Definition program M := normal M /\ maxvar M = 0.

Lemma components_monotonic:
forall M N, program M -> program N ->
left_component M = left_component N ->
right_component M = right_component N -> M = N.
Proof.
induction M; unfold program; split_all.
(* 3 *)
inversion H; noway.  inversion H0.
gen4_case H3 H4 H1 H2 N; try discriminate.
(* 2 *)
subst.   inversion H3. simpl in *. discriminate.
inversion H7.
(* 1 *)
subst.
gen2_case H H0 N. inversion H0; noway.
inversion H. inversion H1; simpl in *.
discriminate.  inversion H7.
Qed.

Definition factorable M := (exists o, M = Op o) \/ compound M.

Theorem programs_are_factorable : forall M, program M  -> factorable M.
Proof.
unfold program, factorable; induction M;  split_all; eauto.
right. inversion H; omega.
assert((exists o : operator, M1 = Op o) \/ compound M1). eapply2 IHM1.
inversion H; simpl in *.  split; split_all. inversion H0; auto.
max_out.
(* 1 *)
inversion H0; split_all; subst; eauto.
inversion H1; try inv1 compound; subst.
inversion H. inversion H2. simpl in *; discriminate. auto.
(* 1 *)
inversion H. inversion H2.
inversion H1; subst; simpl in *; try discriminate.
assert(status M = Passive). eapply2 closed_implies_passive.
max_out. max_out.
rewrite H4 in H8; discriminate. auto.
Qed.


Require Export tactic_notations.
Require Export unproven_lemmas.
Require Export mto_arith.
Require Export low_equivalence_properties.

Lemma lemmaone :
  forall t1 t2,
  (traceequiv t1 t2) -> ((tracelen t1) = (tracelen t2)).
Proof.
  intros t1 t2 H.

  trace_equiv_cases (induction H) Case;
  try (reflexivity).

  Case "refl_equiv".
    symmetry. apply IHtraceequiv.

  Case "assoc_equiv".
    simpl.  rewrite plus_assoc.  reflexivity.

  Case "trans_equiv".
    rewrite  <- IHtraceequiv2.  apply IHtraceequiv1.

  Case "epsilon_ident_equivr".
    simpl.  rewrite plus_0_r. reflexivity.

  Case "concat_decomp_equiv".
    simpl.
    rewrite IHtraceequiv1.
    rewrite IHtraceequiv2.
    reflexivity.
Qed.

Lemma lemmatwo_1 :
  forall t i,
  ((tracelen t)=0) -> (ithelement t i = epsilon).
Proof.
  intros t i.
  intros H.
  induction ( t).
  Case "read". inversion H.
  Case "readarr". inversion H.
  Case "write". inversion H.
  Case "writearr". inversion H.
  Case "fetch". inversion H.
  Case "orambank". inversion H.
  Case "concat".
    simpl in H.
    apply plus_is_O in H.
    simpl.
    destruct i as [| i'].
    SCase "i = 0'".
      reflexivity.
    SCase "i = S i'".
      destruct i'.
      SSCase "i = 1".
      destruct H as [H1 H2].
      destruct t1.
      SSSCase "read". inversion H1.
      SSSCase "readarr". inversion H1.
      SSSCase "write". inversion H1.
      SSSCase "writearr". inversion H1.
      SSSCase "fetch". inversion H1.
      SSSCase "orambank". inversion H1.
      SSSCase "concat".
        inversion H1.
        remember H1 as HH1.
        rewrite H1.
        simpl in H1.
        rewrite H1.
        apply IHt2.
        apply H2.
      SSSCase "epsilon".
        apply IHt2.
        apply H2.

      assert ((ble_nat (S (S i')) (tracelen t1)) = false).
        inversion H as [H1 H2].
        rewrite H1.
        simpl. reflexivity.

      rewrite H0.
      inversion H as [H1 H2].
      rewrite H1.
      simpl.
      apply IHt2.
      apply H2.

  Case "epsilon".
    simpl.
    destruct i.
    SCase "i = O".
      reflexivity.
    SCase "i = S n".
      destruct i.
      SSCase "i = 1". reflexivity.
      SSCase " i > 1". reflexivity.
Qed.

Lemma lemmatwo_2 :
  forall t, ithelement t 0 = epsilon.
Proof.
  intros t.
  trace_cases (induction t) Case;
  try(simpl; reflexivity).
Qed.

Lemma lemmatwo_3 :
  forall t n,
  (tracelen t = S (S n)) -> (exists t1, exists t2, t = concat t1 t2).
Proof.
  intros t n.
  unfold tracelen.

  trace_cases (destruct t) Case;
  try(intros H; inversion H).

  Case "concat".
    exists t1.
    exists t2.
    reflexivity.
Qed.

(*
A standard library version of plusright
  and cancel minus may exist.
*)

Lemma lemma_plusright : forall a b, a<=a+b.
Proof.
  induction a.
  apply le_O_n.
  intros b.
  rewrite plus_Sn_m.
  apply le_n_S.
  apply IHa.
Qed.

Lemma cancelminus : forall a b, (a<=b) -> (b-a+a=b).
Proof.
  intros a b H.
  rewrite plus_comm.
  symmetry.
  apply le_plus_minus.
  apply H.
Qed.

Lemma lemmatwo :
  forall i t,
  (ithelement t i <> epsilon) <-> ((le 1 i) /\ (le i (tracelen t))).
Proof.
  intros i t.
  remember (tracelen t).
  generalize Heqn.
  generalize t i.
  apply strongind with (P:=(fun n => forall t0 i0, n=tracelen t0 -> (ithelement t0 i0 <> epsilon <-> 1<= i0 <=n))).
  intros t0 i0.
  intros FOO.

  split.

  intros HFOO.
  remember lemmatwo_1.
  symmetry in Heqn.
  assert (ithelement t0 i0 = epsilon).
  apply e.
  symmetry.
  apply FOO.
  rewrite H in HFOO.
  unfold not in HFOO.
  assert (epsilon = epsilon).
  reflexivity.
  apply HFOO in H0.
  inversion H0.
  intros H.
  inversion H as [H1 H2].
  assert (1 <=0).
  generalize H1 H2.
  apply le_trans.
  inversion H0.

  intros n0.
  intros Hyp.
  intros HH.
  destruct n0.
  split.
  intros HHH.
  assert (i0=1).
  assert (epsilon= epsilon).
  reflexivity.
  destruct i0.
  rewrite lemmatwo_2 in HHH.
  apply HHH in H0.
  inversion H0.
  destruct i0.
  reflexivity.
  assert(forall t0 n0, ((S O) = tracelen t0) ->(ithelement t0 (S (S n0)) = epsilon)).
  intros t0 n0.
  intros HHHH.
  induction t0.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  simpl in HHHH.
  simpl.
  destruct (tracelen t0_1).
  simpl in HHHH.
  apply IHt0_2.
  apply HHHH.
  assert (tracelen t0_2 = 0).
  rewrite plus_Sn_m in HHHH.
  inversion  HHHH.
  symmetry in H2.
  apply plus_is_O in H2.
  apply H2.
  rewrite H1 in HHHH.
  rewrite  plus_0_r in HHHH.
  inversion HHHH.
  apply lemmatwo_1.
  apply H1.
  simpl.
  reflexivity.
  apply HHH in H1.
  inversion H1.
  apply H.
  rewrite H0.
  split.
  apply le_refl.
  apply le_refl.
  intros HHH.
  assert (i0=1).
  inversion HHH as [HHH1 HHH2].
  apply le_antisym.
  apply HHH2.
  apply HHH1.
  rewrite H0.
  assert (forall t, (tracelen t = 1) -> (ithelement t 1 <> epsilon)).
  intros t0.
  intros HHHH.
  induction t0.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl in  HHHH.
  remember (tracelen t0_1).
  simpl.
  destruct (n0).
  simpl in HHHH.
  simpl.
  destruct t0_1.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  simpl.
  intros HHHHH.
  inversion HHHHH.
  rewrite <- Heqn0.
  apply IHt0_2.
  apply HHHH.
  simpl.
  apply IHt0_2.
  apply HHHH.
  assert (n0 = 0).
  destruct (tracelen t0_2).
  rewrite plus_0_r in HHHH.
  inversion HHHH.
  reflexivity.
  rewrite plus_Sn_m in HHHH.
  inversion HHHH.
  rewrite <- plus_n_Sm in H2.
  inversion H2.
  rewrite H1 in Heqn0.
  rewrite <- Heqn0.
  apply IHt0_1.
  rewrite <- H1.
  reflexivity.
  simpl in HHHH.
  inversion HHHH.
  apply H1.
  symmetry.
  apply H.

  (* base case done*)

  remember lemmatwo_3.
  intros i0.
  intros HFOO.
  remember HFOO as HHH.
  clear HeqHHH.
  symmetry in HFOO.
  rewrite -> HHH.
  clear Heqe.
  remember (tracelen HH).
  rewrite Heqn1.
  rewrite Heqn1 in HFOO.
  induction HH.
  apply e in HFOO.
  inversion HFOO.
  inversion H.
  clear H HFOO.
  inversion H0.
  apply e in HFOO.
  inversion HFOO.
  inversion H.
  clear H HFOO.
  inversion H0.
  apply e in HFOO.
  inversion HFOO.
  inversion H.
  clear H HFOO.
  inversion H0.
  apply e in HFOO.
  inversion HFOO.
  inversion H.
  clear H HFOO.
  inversion H0.
  apply e in HFOO.
  inversion HFOO.
  inversion H.
  clear H HFOO.
  inversion H0.
  apply e in HFOO.
  inversion HFOO.
  inversion H.
  clear H HFOO.
  inversion H0.
  apply e in HFOO.
  inversion HFOO.
  inversion H.
  clear H HFOO.

  simpl.
  destruct i0.
  split.
  intros H1.
  assert (epsilon = epsilon).
  reflexivity.
  apply H1 in H.
  inversion H.
  intros H1.
  inversion H1.
  inversion H.

  remember (tracelen x) as trlnx.
  remember (tracelen HH1) as trlnHH1.

  rewrite HeqtrlnHH1 in IHHH1.
  rewrite HeqtrlnHH1.

  destruct i0.
  simpl in Heqn.
  simpl in Hyp.
  simpl in HHH.
  inversion H0.
  rewrite H1 in *.
  rewrite H2 in *.
  assert ((tracelen x0 = O) ->(exists t1 : trace, exists t2 : trace, x=concat t1 t2)).
  intros H3.
  rewrite Heqn1 in HHH.
  simpl in HHH.
  rewrite H3 in HHH.
  rewrite <- plus_n_O in HHH.
  apply lemmatwo_3 with n0.
  symmetry.
  apply HHH.

  simpl in Heqn1.
  rewrite <- Heqtrlnx.
  rewrite <- Heqtrlnx in Heqn1.
  rewrite <- Heqtrlnx in IHHH1.
  destruct (trlnx).
  simpl in Heqn1.
  apply IHHH2.
  apply Heqn1.
  rewrite HHH.
  symmetry.
  apply Heqn1.
  (**apply Hyp.
  simpl in HHH.
  apply lemmatwo_3 with n0.
  symmetry.
  apply HHH.**)
  destruct (tracelen x0).
  rewrite <- plus_n_O.
  apply IHHH1.
  rewrite <- plus_n_O in Heqn1.
  apply Heqn1.
  rewrite Heqn1 in HHH.
  rewrite <- plus_n_O in HHH.
  symmetry.
  apply HHH.
  assert (trlnHH1 <= S n0) as HlengHH1.
  simpl in  Heqn1.
  rewrite Heqn1 in HHH.
  inversion HHH.
  rewrite <- plus_n_Sm in H4.
  rewrite <- plus_Sn_m in H4.
  rewrite Heqtrlnx in H4.
  rewrite <- HeqtrlnHH1 in H4.
  rewrite H4.
  apply lemma_plusright.
  assert (ithelement x 1 <> epsilon <-> 1<= 1<= (tracelen x)).
  apply Hyp.
  rewrite Heqn1 in HHH.
  rewrite <- plus_n_Sm in HHH.
  rewrite <- Heqtrlnx.
  inversion HHH.
  apply le_n_S.
  apply lemma_plusright.
  reflexivity.
  split.
  intros HH4.
  apply H3 in HH4.

  inversion HH4.
  split.
  apply le_refl.
  assert (tracelen x <= S (S n0)).
  rewrite HHH.
  rewrite Heqn1.
  rewrite Heqtrlnx.
  apply lemma_plusright.
  apply le_n_S.
  apply le_O_n.
  intros HH4.
  apply H3.
  rewrite <- Heqtrlnx.
  split.
  apply le_refl.
  apply le_n_S.
  apply le_O_n.

  remember (ble_nat (S (S i0)) (tracelen HH1)).
  destruct b.

  remember (tracelen HH2) as trlnHH2.
  destruct (trlnHH2).
  rewrite <- plus_n_O.
  apply IHHH1.
  simpl in Heqn1.
  rewrite <- HeqtrlnHH2 in Heqn1.
  rewrite <- plus_n_O in Heqn1.
  apply Heqn1.
  simpl in Heqn1.
  rewrite <- HeqtrlnHH2 in Heqn1.
  rewrite <- plus_n_O in Heqn1.
  rewrite Heqn1 in HHH.
  symmetry.
  apply HHH.

  split.
  intros HH4.
  split.
  apply le_n_S.
  apply le_O_n.
  assert (S (S i0) <= tracelen HH1).
  apply ble_nat_true.
  symmetry.
  apply Heqb.
  assert ( tracelen HH1 <=  tracelen HH1+  S trlnHH2).
  apply lemma_plusright.
  apply le_trans with  (tracelen HH1).
  apply H.
  apply H1.
  intros HH4.
  inversion HH4.
  assert (S (S i0) <= tracelen HH1).
  apply ble_nat_true.
  symmetry.
  apply Heqb.
  assert (1<= S (S i0) <= tracelen HH1).
  split.
  apply H.
  apply H2.

  assert ((ithelement HH1 (S (S i0)) <> epsilon) <-> (1<= S (S i0) <= tracelen HH1)).
  apply Hyp.
  rewrite Heqn1 in HHH.
  simpl in HHH.
  rewrite <- HeqtrlnHH2 in HHH.
  rewrite <- plus_n_Sm in HHH.
  inversion HHH.
  rewrite H5.
  apply lemma_plusright.
  reflexivity.
  apply H4 in H3.
  apply H3.
  destruct trlnHH1.
  rewrite <- HeqtrlnHH1.
  rewrite  plus_O_n.
  rewrite <- minus_n_O.
  apply IHHH2.
  simpl in Heqn1.
  rewrite <- HeqtrlnHH1 in Heqn1.
  rewrite plus_O_n in Heqn1.
  apply Heqn1.
  simpl in Heqn1.
  rewrite <- HeqtrlnHH1 in Heqn1.
  rewrite plus_O_n in Heqn1.
  rewrite Heqn1 in HHH.
  symmetry.
  apply HHH.

  remember (S i0 - tracelen HH1) as FOO.
  assert (FOO + tracelen HH1 = S i0).

  assert (tracelen HH1 <= S i0).
  symmetry in Heqb.
  apply ble_nat_false in Heqb.
  apply not_le in Heqb.
  unfold gt in Heqb.
  apply lt_n_Sm_le in Heqb.
  apply Heqb.
  rewrite HeqFOO.
  apply cancelminus.
  apply H.
  rewrite <- H.

  assert (ithelement HH2 (S FOO) <> epsilon <-> 1<= S FOO <= tracelen HH2).
  apply Hyp.
  simpl in Heqn1.
  rewrite <- HeqtrlnHH1 in Heqn1.
  rewrite plus_Sn_m in Heqn1.
  rewrite Heqn1 in HHH.
  inversion HHH.
  rewrite plus_comm in H2.
  rewrite H2.
  apply lemma_plusright.
  reflexivity.
  assert (S FOO + tracelen HH1 - tracelen HH1 = S FOO).
  rewrite plus_comm.
  apply minus_plus.
  assert ((1<=  S FOO <= tracelen HH2) <-> (1<= S FOO + tracelen HH1 <= tracelen HH1 + tracelen HH2)).
  split.
  intros H4.
  split.
  rewrite <- HeqtrlnHH1.
  rewrite <- plus_n_Sm.
  apply le_n_S.
  apply le_O_n.
  inversion H4.
  rewrite plus_comm.
  apply plus_le_compat_l.
  apply H5.
  intros H4.
  split.
  inversion H4.

  apply le_n_S.
  apply le_O_n.
  inversion H4.
  rewrite -> plus_comm in H5.
  assert (forall a b c, (a+b<=a+c)-> (b<=c)).
  intros a b c.
  induction a.
  rewrite plus_O_n.
  rewrite plus_O_n.
  intros Hsub.
  apply Hsub.
  intros Hsub.
  rewrite plus_Sn_m in Hsub.
  rewrite plus_Sn_m in Hsub.
  inversion Hsub.
  apply IHa.
  rewrite H7.
  apply le_refl.
  apply IHa.
  assert (a+b <= S (a+b)).
  apply le_n_Sn.
  apply le_trans with (S (a+b)).
  apply H8.
  apply H7.
  apply H6 with (tracelen HH1).
  apply H5.
  rewrite <- plus_Sn_m.

  rewrite H2.
  apply iff_trans with (1<= S FOO <= tracelen HH2).
  apply H1.
  apply H3.
  simpl in HFOO.
  inversion HFOO.
Qed.

Lemma combo_six_seven :
  forall gamma e l T M1 M2 t1 t2 n1 n2,
  (exprTyping gamma e (lnat l) T) ->
  (gammavalid gamma M1) ->
  (gammavalid gamma M2) ->
  (exprSem M1 e t1 n1) ->
  (exprSem M2 e t2 n2) -> (t1 = t2).
Proof.
  intros gamma e l.
  destruct l.
  intros T M1 M2 t1 t2 n1 n2 HH1 HH2 HH3 HH4 HH5.
  assert (t1 = t2 /\ n1 = n2).
  apply lemmasix with gamma e T M1 M2; assumption.
  apply H.
  apply lemmaseven.
Qed.

Lemma sameExpr_sameStuff : forall M1 e, forall t1 t2 n1 n2,
  (exprSem M1 e t1 n1) -> (exprSem M1 e t2 n2) ->
  (t1 = t2 /\ n1 = n2).
Proof.
  intros M1 e.
  induction e.
  intros t1 t2 n1 n2.
  intros H1 H2.
  inversion H1.
  inversion H2.
  rewrite H8 in H0.
  inversion H0.
  rewrite H14 in *.
  rewrite H15 in *.
  rewrite <- H4 in H10.
  rewrite H10.
  split;
  reflexivity.
  intros t1 t2 n1 n2.
  intros H1 H2.
  inversion H1.
  inversion H2.
  assert (t0 = t4 /\ n0 = n4).
  apply IHe1;
  assumption.
  assert (t3 = t5 /\ n3 = n5).
  apply IHe2;
  assumption.
  rewrite H9.
  rewrite H18.
  inversion H19.
  inversion H20.
  rewrite H21.
  rewrite H22.
  rewrite H23.
  rewrite H24.
  split.
  reflexivity.
  reflexivity.
  intros t1 t2 n1 n2.
  intros H1 H2.
  inversion H1.
  inversion H2.
  rewrite H13 in H4.
  inversion H4.
  rewrite H20 in *.
  assert (t = t3 /\ n = n3).
  apply IHe.
  assumption.
  assumption.
  inversion H19.
  rewrite H22 in *.
  rewrite H23 in *.

  assert (n1 = n2).
  rewrite H15.
  rewrite H6.
  reflexivity.
  assert (t0 = t4).
  rewrite H18.
  rewrite H9.
  rewrite H24.
  rewrite H21.
  reflexivity.
  rewrite H25.
  split.
  reflexivity.
  apply H24.
  intros t1 t2 n1 n2 H1 H2.
  inversion H1.
  inversion H2.
  rewrite <- H8.
  rewrite <- H4.
  split;
  reflexivity.
Qed.

Lemma nonzerolength_prog : forall  p M1 M2 t ,
  (progSem M1 p t M2) -> ( 0 <> tracelen_withepsilon t).
Proof.
  intros p.
  induction p.
  intros  M1 M2 t.
  destruct l.
  intros H.
  destruct s.
  inversion H.
  intros HH.
  simpl in HH.
  inversion HH.
  inversion H.
  intros HH.
  simpl in HH.
  inversion HH.
  inversion H.
  intros HH.
  simpl in HH.
  inversion HH.
  inversion H.
  intros HH.
  simpl in HH.
  inversion HH.
  inversion H.
  intros HH.
  simpl in HH.
  inversion HH.
  intros t M1 M2.
  intros H.
  inversion H.
  intros HH.
  simpl in HH.
  symmetry in HH.
  apply plus_is_O in HH.
  inversion HH.
  apply IHp1 in H3.
  symmetry in H7.
  apply H3 in H7.
  inversion H7.
Qed.

Lemma nonzerolength_expr :
  forall M e t n,
  (exprSem M e t n) -> (0<> tracelen_withepsilon t).
Proof.
  intros M e.
  induction e.
  intros t n.
  intros H.
  inversion H.
  rewrite H3.
  destruct l.
  simpl.
  trivial.
  simpl.
  trivial.
  intros t n H.
  inversion H.
  intros HH.
  simpl in HH.
  symmetry in HH.
  apply plus_is_O in HH.
  inversion HH.
  apply IHe1 in H4.
  symmetry in H9.
  apply H4 in H9.
  inversion H9.
  intros t n H.
  inversion H.
  intros HH.
  simpl in HH.
  symmetry in HH.
  apply plus_is_O in HH.
  inversion HH.
  apply IHe in H2.
  symmetry in H9.
  apply H2 in H9.
  inversion H9.
  intros t n H.
  inversion H.
  simpl.
  trivial.
Qed.

Lemma atleastone : forall S2, 1 <= num_statements S2 .
Proof.
  intros S2.
  induction S2.
  destruct l.
  destruct s.
  simpl.
  apply le_refl.
  simpl.
  apply le_refl.
  simpl.
  apply le_refl.
  simpl.
  apply le_n_S.
  apply le_O_n.
  apply le_n_S.
  apply le_O_n.
  simpl.
  apply le_plus_trans.
  apply IHS2_1.
Qed.

Lemma whilecase :
  forall  n p p0 e t1 t2 M1 M1' M2 M2' l T gamma,
    tracelen_withepsilon t1 <= n ->
    tracelen_withepsilon t2 <= n ->
    (lowEquivalentMem M1 M2) ->
    (stmtSem M1 (labline p (stwhile e p0)) t1 M1') ->
    (stmtSem M2 (labline p (stwhile e p0)) t2 M2') ->
    (statementTyping gamma l (labline p (stwhile e p0)) T) ->
    (gammavalid gamma M1) ->
    (gammavalid gamma M2) ->
    (memTraceObliv gamma p0) ->

        ( traceequiv t1 t2 /\ lowEquivalentMem M1' M2' ).
Proof.
  intros n.
  apply strongind with
  (P:=(fun n:nat =>forall p p0 e t1 t2 M1 M1' M2 M2' l T gamma,
   tracelen_withepsilon t1 <= n->
   tracelen_withepsilon t2 <= n->
   (lowEquivalentMem M1 M2) ->
   (stmtSem M1 (labline p (stwhile e p0)) t1 M1') ->
   (stmtSem M2 (labline p (stwhile e p0)) t2 M2') ->
   (statementTyping gamma l (labline p (stwhile e p0)) T) ->
   (gammavalid gamma M1) ->
   (gammavalid gamma M2) ->
   (memTraceObliv gamma p0) ->
  (
  traceequiv t1 t2 /\ lowEquivalentMem M1' M2'
  ))).
  intros p p0 e t1 t2 M1 M1' M2 M2' l T gamma HH1 HH2 HH3 HH4 HH5 HH6 HH7 HH9.
  inversion HH4.
  rewrite <- H4 in HH1.
  simpl in HH1.
  inversion HH1.
  rewrite <- H1 in HH1.
  simpl in HH1.
  inversion HH1.
  (* for S n instead of n in base case *)
  (**
  rewrite <- H4 in HH1.
  simpl in HH1.
  inversion HH1.
  apply nonzerolength_expr in H3.
  apply plus_is_O in H9.
  inversion H9.
  symmetry in H8.
  apply H3 in H8.
  inversion H8.
  rewrite <- H1 in HH1.
  simpl in HH1.
  inversion HH1.
  symmetry in H7.
  apply nonzerolength_expr in H5.
  apply H5 in H7.
  inversion H7.
  **)
  intros n0.
  intros mm.
  intros p p0 e t1 t2 M1 M1' M2 M2' l T gamma HH1 HH2 HH3 HH4 HH5 HH6 HH7 HH8 HH9.

  inversion HH4.
  inversion HH5.
  inversion H7.
  inversion H16.
  assert (t = t3).
  inversion HH6.
  apply combo_six_seven with gamma e l0 T1 M1 M2 n1 n2;assumption.

  assert (traceequiv t5 t7 /\ lowEquivalentMem M6 M9).
  unfold memTraceObliv in HH9.
  apply HH9 with M1 M2;assumption.
  inversion H32.

  inversion H23.
  inversion H30.

  assert (traceequiv t9 t10 /\ lowEquivalentMem M1' M2').
  apply mm with (max (tracelen_withepsilon t9) (tracelen_withepsilon t10)) p p0 e M6 M9 l T gamma.
  assert ( (tracelen_withepsilon t9) =
  max (tracelen_withepsilon t9) (tracelen_withepsilon t10)\/
  (tracelen_withepsilon t10) =
   max (tracelen_withepsilon t9) (tracelen_withepsilon t10)).
  apply le_max_or.
  inversion H47.
  rewrite <- H48.
  rewrite <- H4 in HH1.
  apply nonzerolength_expr in H3.
  simpl in HH1.
  apply le_S_n in HH1.
  apply le_trans with (tracelen_withepsilon t + tracelen_withepsilon t0).
  destruct (tracelen_withepsilon t).
  assert (0=0).
  reflexivity.
  simpl.
  apply H3 in H49.
  inversion H49.
  rewrite <- H21.
  rewrite <- H37.
  simpl.
  rewrite plus_assoc.
  rewrite <- plus_Sn_m.
  rewrite <- plus_n_Sm.
  rewrite <- plus_Sn_m.
  apply le_plus_r.
  assumption.
  rewrite <- H48.
  rewrite <- H13 in HH2.
  apply nonzerolength_expr in H12.
  simpl in HH2.
  apply le_S_n in HH2.
  apply le_trans with (tracelen_withepsilon t3 + tracelen_withepsilon t4).
  destruct (tracelen_withepsilon t3).
  assert (0=0).
  reflexivity.
  simpl.
  apply H12 in H49.
  inversion H49.
  rewrite <- H28.
  rewrite <- H43.
  simpl.
  rewrite plus_assoc.
  rewrite <- plus_Sn_m.
  rewrite <- plus_n_Sm.
  rewrite <- plus_Sn_m.
  apply le_plus_r.
  assumption.
  apply le_max_l.
  apply le_max_r.

  assumption.
  assumption.
  assumption.
  assumption.
  apply stayvalid with M1 p0 t5.
  assumption.
  assumption.
  apply stayvalid with M2 p0 t7.
  assumption.
  assumption.
  assumption.
  split.
  apply concat_decomp_equiv.
  apply equal_equiv.
  apply concat_decomp_equiv.
  assert (t = t3).
  inversion HH6.
  apply combo_six_seven with gamma e l0 T1 M1 M2 n1 n2;
  assumption.
  rewrite H48.
  apply equal_equiv.
  apply concat_decomp_equiv.
  apply H33.
  apply concat_decomp_equiv.
  apply equal_equiv.
  inversion H47.
  assumption.
  inversion H47.
  assumption.
  assert ( t = t3 /\ n1 = 0).
  inversion HH6.
  destruct l0.
  apply lemmasix with gamma e T1 M1 M2.
  assumption.
  assumption.
  assumption.
  assumption.
  rewrite H13.
  assumption.
  inversion H23.
  inversion H15.
  apply H6 in H17.
  inversion H17.

  inversion HH5.
  assert ( t = t0 /\ 0 = n1).
  inversion HH6.
  destruct l0.
  apply lemmasix with gamma e T1 M1' M2.
  assumption.
  rewrite <- H4.
  assumption.
  assumption.
  assumption.
  assumption.
  inversion H23.
  inversion H15.
  symmetry in H17.
  apply H13 in H17.
  inversion H17.
  assert (t = t0).
  inversion HH6.
  apply combo_six_seven with gamma e l0 T1 M1' M2' 0 0.
  assumption.
  rewrite <- H4.
  assumption.
  rewrite <- H11.
  assumption.
  assumption.
  assumption.
  rewrite H13.
  rewrite <- H4.
  rewrite <- H11.
  split.
  apply equal_equiv.
  assumption.
Qed.

(* TracePattern analogs to trace lemmas  *)

Lemma lemma_one_tracepat :
  forall (T1 T2:TracePat),
  TracePatEquiv T1 T2 ->
  (tracepat_len T1) = (tracepat_len T2).
Proof.
  intros.

  trace_pattern_equiv_cases (induction H) Case;
  try (reflexivity).

  Case "Assoc_equiv".
  simpl. rewrite plus_assoc. reflexivity.

  Case "Trans_equiv".
    rewrite <- IHTracePatEquiv2. apply IHTracePatEquiv1.

  Case "Epsilon_ident_equivr".
    simpl. rewrite plus_0_r. reflexivity.

  Case "Concat_decomp_equiv".
    simpl.
    rewrite IHTracePatEquiv1.
    rewrite IHTracePatEquiv2.
    reflexivity.
Qed.

Lemma lemma_two_1_tracepat :
  forall (T:TracePat) (i:nat),
  ((tracepat_len T) = 0) ->
  (ithelement_tp T i = Epsilon).
Proof.
  intros.

  trace_pattern_cases (induction T) Case;
  try (inversion H).

  Case "Concat".
    destruct i.
    SCase "i = 0". reflexivity.

    SCase "i > 0".
      destruct i.

      SSCase "i = 1".

        trace_pattern_cases (destruct T1) SSSCase;
        try (intuition).

        SSSCase "Concat". intuition.
  Case "Epsilon".
    destruct i.
    SCase "i = 0". reflexivity.
    SCase "i > 0".
      destruct i.
      SSCase "i = 1". reflexivity.
      SSCase "i > 1". reflexivity.
Qed.

Lemma lemma_two_2_tracepat :
  forall (T:TracePat),
  ithelement_tp T 0 = Epsilon.
Proof.
  intros T.
  trace_pattern_cases (induction T) Case;
  try (simpl; reflexivity).
Qed.

Lemma lemma_two_3_tracepat :
  forall (T:TracePat) (n:nat),
  (tracepat_len T = S (S n)) ->
  (exists T1, exists T2, T = Concat T1 T2).
Proof.
  intros T n.
  unfold tracepat_len.

  trace_pattern_cases (destruct T) Case;
  try (intros H; inversion H).

  Case "Concat".
    exists T1.
    exists T2.
    reflexivity.
Qed.


Require Import HoTT.Basics Coq.Unicode.Utf8.

(* Can explore replacing U with i+1 everywhere, but probably difficult *)

(* Infinitary arguments/indices are hard. *)
(* Do we care that El ((a : A) -> B a) = (a : A) -> El (B a) ? *)

(* Is it actually worth splitting TySort and TyOp? *)

Module Sem.
  Record t@{i U | i < U} := {
    Ctx              : Type@{U};
    TySort (Γ : Ctx) : Type@{U};
    TyOp   (Γ : Ctx) : Type@{U};
    Data   (Γ : Ctx) : Type@{U};

    data_to_op {Γ} : Data Γ → TyOp Γ;

    Indices : Ctx → Type@{i}; (* a small set *)

    emp : Ctx;
    ext_sort (Γ : Ctx) (A : TySort Γ) : Ctx;
    ext_op   (Γ : Ctx) (A : TyOp   Γ) : Ctx;
    ext_data (Γ : Ctx) (A : Data   Γ) : Ctx := ext_op Γ (data_to_op A);

    inc        {Γ} (i : Indices Γ)                                  : Data   Γ;
    inf        {Γ} (A : Type@{i}) `{IsHSet A}    (B : A → Indices Γ): Data   Γ;

    u          {Γ}                                                  : TySort Γ;
    ind_ix     {Γ} (A : Data Γ) (B : TySort (ext_data Γ A))         : TySort Γ;
    nonind_ix  {Γ} (A : Type@{i}) `{IsTrunc 1 A} (B : A → TySort Γ) : TySort Γ;

    el         {Γ} (i : Indices Γ) := data_to_op (inc i)            : TyOp   Γ;
    ind_arg    {Γ} (A : Data Γ) (B : TyOp   (ext_data Γ A))         : TyOp   Γ;
    nonind_arg {Γ} (A : Type@{i}) `{IsHSet A}    (B : A → TyOp Γ)   : TyOp   Γ;

    (* We expect that:
    data_to_op (inf A f) = nonind_arg A (data_to_op o f)
    *)
  }.
End Sem.

Section specs.
Universes i U.
Constraint i < U.
Context (sem : Sem.t@{i U}).

(* Close Indices under external products *)
Inductive Data (Indices : Type@{i}) : Type@{i+1} :=
  | inc (i : Indices)
  | inf (A : Type@{i}) `{IsHSet A} (B : A → Indices)
.
Global Arguments inc {Indices} i.
Global Arguments inf {Indices} A {_} B.
Fixpoint ElData {Γ : sem.(Sem.Ctx)} (A : Data (sem.(Sem.Indices) Γ))
  : sem.(Sem.Data) Γ
  := match A with
     | inc i => sem.(Sem.inc) i
     | inf A _ B => sem.(Sem.inf) A B
     end.

(*TySort and TyOp use Γ as a large non-uniform parameter, but not essentially*)
Inductive TySort (Γ : sem.(Sem.Ctx)) : Type@{i+1} :=
  | u
  | ind_ix    (A : Data (sem.(Sem.Indices) Γ))
              (B : TySort (sem.(Sem.ext_data) Γ (ElData A)))
  | nonind_ix (A : Type@{i}) `{IsTrunc@{i} 1 A} (B : A → TySort Γ)
.
Global Arguments u {Γ}.
Global Arguments ind_ix {Γ} A B.
Global Arguments nonind_ix {Γ} A {_} B.
Fixpoint ElTySort {Γ} (A : TySort Γ) : sem.(Sem.TySort) Γ
  := match A with
     | u => sem.(Sem.u)
     | ind_ix A B => sem.(Sem.ind_ix) (ElData A) (ElTySort B)
     | nonind_ix A _ B => sem.(Sem.nonind_ix) A (ElTySort o B)
     end.

Inductive TyOp (Γ : sem.(Sem.Ctx)) : Type@{i+1} :=
  | el         (i : sem.(Sem.Indices) Γ)
  | ind_arg    (A : Data (sem.(Sem.Indices) Γ))
               (B : TyOp (sem.(Sem.ext_data) Γ (ElData A)))
  | nonind_arg (A : Type@{i}) `{IsHSet A} (B : A → TyOp Γ)
.
Global Arguments el {Γ} i.
Global Arguments ind_arg {Γ} A B.
Global Arguments nonind_arg {Γ} A {_} B.
Fixpoint ElTyOp {Γ} (A : TyOp Γ) : sem.(Sem.TyOp) Γ
  := match A with
     | el i => sem.(Sem.el) i
     | ind_arg A B => sem.(Sem.ind_arg) (ElData A) (ElTyOp B)
     | nonind_arg A _ B => sem.(Sem.nonind_arg) A (ElTyOp o B)
     end.

(* Data is a subset of TyOp *)
Fixpoint data_to_op {Γ} (A : Data (sem.(Sem.Indices) Γ)) : TyOp Γ
  := match A with
     | inc i => el i
     | inf A _ B => nonind_arg A (el o B)
     end.
(*
If the equations in the semantics hold definitionally then
ElTyOp o sem.(Sem.data_to_op) = data_to_op o ElData definitionally
on concrete specifications. (an outrageous coincidence)
Proving this internally requires function extensionality.
*)

(* Here we define Ctx as the inductive recursive:
data Ctx : Type@{j}
ElCtx : Ctx → sem.(Sem.Ctx)
data Ctx where
  emp : Ctx
  ext_sort : (Γ : Ctx) → TySort (ElCtx Γ) → Ctx
  ext_op   : (Γ : Ctx) → TyOp   (ElCtx Γ) → Ctx
ElCtx emp = sem.(Sem.emp)
ElCtx (ext_sort Γ A) = sem.(Sem.ext_sort) (ElCtx Γ) (ElTySort A)
ElCtx (ext_op   Γ A) = sem.(Sem.ext_op  ) (ElCtx Γ) (ElTyOp   A)

We don't include ext_data, expecting data_to_op to work by coincidence.
*)
(*
If sem.(Sem.Ctx) : Type@{i+1}, can take Ctx to be (indexing by final sem ctx)
data PreCtx : sem.(Sem.Ctx) → Type@{i+1} where
  pre_emp : PreCtx sem.(Sem.emp)
  pre_ext_sort { γ : sem.(Sem.Ctx) & PreCtx γ } (A : TySort γ)
  pre_ext_op   { γ : sem.(Sem.Ctx) & PreCtx γ } (A : TyOp   γ)
Ctx := { γ : sem.(Sem.Ctx) & PreCtx γ }

or in the reverse order (right-nested):
data PreCtx (γ : sem.(Sem.Ctx)) : Type@{i+1} where
  pre_end
  pre_push_sort (A : TySort γ) (Γ : PreCtx (sem.(Sem.ext_sort) γ A))
  pre_push_op   (A : TyOp   γ) (Γ : PreCtx (sem.(Sem.ext_op  ) γ A))
Ctx := PreCtx sem.(Sem.emp)

Both of these have the advantage that Ctx lands in Type@{i+1} not Type@{U > i}.

However, the first keeps semantic contexts around,
while the second has a bad induction principle.

Probably best is to do everything as an ornament,
exploiting the fact that we never branch on the semantics,
and that the extra information is small.
*)

Inductive PreCtx : Type@{i} :=
  | pre_emp
  | pre_ext_sort (Γ : PreCtx)
  | pre_ext_op   (Γ : PreCtx)
.
Record CtxPair := { GoodCtx : Type@{U} ; ElGoodCtx : GoodCtx → sem.(Sem.Ctx) }.
Fixpoint ElPreCtx (Γ : PreCtx) : CtxPair
  := match Γ with
     | pre_emp        => {| GoodCtx := Unit; ElGoodCtx _ := sem.(Sem.emp) |}
     | pre_ext_sort Γ => {|
         GoodCtx := { γ : _ & TySort ((ElPreCtx Γ).(ElGoodCtx) γ) };
         ElGoodCtx x := sem.(Sem.ext_sort) _ (ElTySort x.2);
       |}
     | pre_ext_op   Γ => {|
         GoodCtx := { γ : _ & TyOp ((ElPreCtx Γ).(ElGoodCtx) γ) };
         ElGoodCtx x := sem.(Sem.ext_op) _ (ElTyOp x.2);
       |}
     end.
Definition Ctx : Type@{U} := { Γ : PreCtx & (ElPreCtx Γ).(GoodCtx) }.
Definition ElCtx (Γ : Ctx) : sem.(Sem.Ctx) := (ElPreCtx Γ.1).(ElGoodCtx) Γ.2.
Definition emp : Ctx := (pre_emp ; tt).
Definition ext_sort (Γ : Ctx) (A : TySort (ElCtx Γ)) : Ctx
  := (pre_ext_sort Γ.1; Γ.2; A).
Definition ext_op (Γ : Ctx) (A : TyOp (ElCtx Γ)) : Ctx
  := (pre_ext_op Γ.1; Γ.2; A).

(* TODO: Define the recursion principle for Ctx *)
End specs.

(* inductive-inductive specifications are given by Ctx. *)