Require Import Tactics.
Require Import Equality.
Require Import Relation.
Require Import Syntax.
Require Import SimpSub.
Require Import Dynamic.

Section object.

Arguments operator {object}.
Arguments term {object}.
Arguments row {object}.

Arguments rw_cons {object i a}.

Variable object : Type.

(* mapped through compatibility *)

Inductive mcr (R : relation (@term object)) : forall {a}, relation (row a) :=
| mcr_nil :
    mcr R rw_nil rw_nil

| mcr_cons {i a m m' r r'} :
    R m m'
    -> mcr R r r'
    -> mcr R (@rw_cons _ i a m r) (@rw_cons _ i a m' r')
.

Inductive mc (R : relation term) : relation term :=
| mc_var {i} :
    mc R (var i) (var i)

| mc_oper {a} {t : operator a} {r r' : row a} :
    mcr R r r'
    -> mc R (oper a t r) (oper a t r')
.

Lemma mc_reverse :
  forall (R R' : @term object -> term -> Prop),
    (forall x y, R x y -> R' y x)
    -> forall x y, mc R x y -> mc R' y x.
Proof.
intros R R' Hrev x y Hxy.
cases Hxy.

(* var *)
{
intro; apply mc_var.
}

(* oper *)
{
intros a th r s H.
apply mc_oper.
induct H; auto using mcr_nil, mcr_cons.
}
Qed.

Lemma mc_mono :
  forall (R R' : @term object -> term -> Prop),
    (forall x y, R x y -> R' x y)
    -> forall x y, mc R x y -> mc R' x y.
Proof.
intros R R' Hmono x y Hxy.
apply (mc_reverse (fun x y => R y x)); auto.
apply (mc_reverse R); auto.
Qed.

Lemma mc_refl :
  forall (R : @term object -> term -> Prop),
    reflexive _ R
    -> reflexive _ (mc R).
Proof.
intros R Hrefl x.
cases x; auto using mc_var.
intros a th r.
apply mc_oper.
induct r; auto using mcr_nil, mcr_cons.
Qed.

Lemma mc_trans :
  forall (R : @term object -> term -> Prop),
    transitive _ R
    -> transitive _ (mc R).
Proof.
intros R Htrans x y z Hxy Hyz.
revert z Hyz.
cases Hxy.

(* var *)
{
intros i z Hyz.
invert Hyz.
intros <-.
apply mc_var.
}

(* oper *)
{
intros a th r s Hrs z Hyz.
invert Hyz.
intros t Hst <-.
apply mc_oper.
clear Hyz.
revert t Hst.
clear th.
induct Hrs; auto using mcr_nil.
intros i a m n r s Hmn _ IH tt Htt.
invert Htt.
intros p t Hnp Hst <-.
apply mcr_cons; auto.
eapply Htrans; eauto.
}
Qed.

Lemma star_mc_impl_mc_star :
  forall (R : @term object -> term -> Prop),
    forall m n,
      star (mc R) m n
      -> mc (star R) m n.
Proof.
intros R m n H.
induct H.

(* refl *)
{
intro x.
apply mc_refl.
intro; apply star_refl.
}

(* step *)
{
intros x y z Hxy _ Hyz.
eapply mc_trans; eauto.
  {
  intro.
  apply star_trans.
  }

  {
  apply (mc_mono R); auto.
  intros; apply star_one; auto.
  }
}
Qed.

Lemma star_mc_impl_mc :
  forall (R : @term object -> term -> Prop),
    reflexive _ R
    -> transitive _ R
    -> forall m n,
         star (mc R) m n
         -> mc R m n.
Proof.
intros R Hrefl Htrans m n Hmn.
so (star_mc_impl_mc_star _#3 Hmn) as H.
apply (mc_mono (star R)); eauto.
eapply star_of_refl_trans; eauto.
Qed.

Lemma mc_value :
  forall R v m,
    mc R v m
    -> value v
    -> value m.
Proof.
intros R v m Hmc Hval.
invertc Hmc.
  {
  intros i <- <-.
  invert Hval; done.
  }

  {
  intros a t r r' _ <- <-.
  invert Hval; [].
  intro Hcanon.
  apply value_i; auto.
  }
Qed.

Lemma mcr_refl :
  forall (P : relation term),
    (forall m, P m m)
    -> forall a (r : row a), mcr P r r.
Proof.
intros P Hrefl a r.
induct r; eauto using mcr.
Qed.

Lemma mc_app :
  forall (P : relation term) m m' n n',
    P m m'
    -> P n n'
    -> mc P (app m n) (app m' n').
Proof.
intros.
apply mc_oper.
eauto using mcr.
Qed.

Lemma mc_lam :
  forall (P : relation term) m m',
    P m m'
    -> mc P (lam m) (lam m').
Proof.
intros.
apply mc_oper.
eauto using mcr.
Qed.

Lemma mc_next :
  forall (P : relation term) m m',
    P m m'
    -> mc P (next m) (next m').
Proof.
intros.
apply mc_oper.
eauto using mcr.
Qed.

Lemma mc_prev :
  forall (P : relation term) m m',
    P m m'
    -> mc P (prev m) (prev m').
Proof.
intros.
apply mc_oper.
eauto using mcr.
Qed.

Lemma mc_bite :
  forall (P : relation term) m m' n n' p p',
    P m m'
    -> P n n'
    -> P p p'
    -> mc P (bite m n p) (bite m' n' p').
Proof.
intros.
apply mc_oper.
eauto using mcr.
Qed.

Lemma mc_ppair :
  forall (P : relation term) m m' n n',
    P m m'
    -> P n n'
    -> mc P (ppair m n) (ppair m' n').
Proof.
intros.
apply mc_oper.
eauto using mcr.
Qed.

Lemma mc_ppi1 :
  forall (P : relation term) m m',
    P m m'
    -> mc P (ppi1 m) (ppi1 m').
Proof.
intros.
apply mc_oper.
eauto using mcr.
Qed.

Lemma mc_ppi2 :
  forall (P : relation term) m m',
    P m m'
    -> mc P (ppi2 m) (ppi2 m').
Proof.
intros.
apply mc_oper.
eauto using mcr.
Qed.

Lemma star_mcr :
  forall R a (r s : @row object a),
    star (mcr R) r s
    -> mcr (star R) r s.
Proof.
intros R a r s Hrs.
induct Hrs.

(* refl *)
{
intros r.
apply mcr_refl.
intro m.
apply star_refl.
}

(* step *)
{
intros r s t Hrs _ IH.
revert t IH.
induct Hrs.
  {
  intros t H.
  invert H.
  intros <-.
  apply mcr_nil.
  }

  {
  intros i a m n r s Hmn _ IH tt Htt.
  invert Htt.
  intros p t Hnp Hst <-.
  so (IH t Hst) as Hrt.
  apply mcr_cons; auto.
  eapply star_step; eauto.
  }
}
Qed.

Inductive reduce : @term object -> @term object -> Prop :=
| reduce_var {i} :
    reduce (var i) (var i)

| reduce_oper {a th r s} :
    reducer r s
    -> reduce (oper a th r) (oper a th s)

| reduce_app_beta {m m' n n'} :
    reduce m m'
    -> reduce n n'
    -> reduce (app (lam m) n) (subst1 n' m')

| reduce_prev_beta {m m'} :
    reduce m m'
    -> reduce (prev (next m)) m'

| reduce_bite_beta1 {n n' p} :
    reduce n n'
    -> reduce (bite btrue n p) n'

| reduce_bite_beta2 {p p' n} :
    reduce p p'
    -> reduce (bite bfalse n p) p'

| reduce_ppi1_beta {m m' n} :
    reduce m m'
    -> reduce (ppi1 (ppair m n)) m'

| reduce_ppi2_beta {n n' m} :
    reduce n n'
    -> reduce (ppi2 (ppair m n)) n'

with reducer : forall {a}, row a -> row a -> Prop :=
| reducer_nil :
    reducer rw_nil rw_nil

| reducer_cons {i a m n r s} :
    reduce m n
    -> reducer r s
    -> reducer (@rw_cons _ i a m r) (@rw_cons _ i a n s)
.

Scheme reduce_mut_ind := Minimality for reduce Sort Prop
with   reducer_mut_ind := Minimality for reducer Sort Prop.

Lemma mcr_reducer :
  forall a (r s : row a),
    mcr reduce r s
    -> reducer r s.
Proof.
intros a r s H.
induct H; eauto using reducer_nil, reducer_cons.
Qed.

Lemma reducer_mcr :
  forall a (r s : row a),
    reducer r s
    -> mcr reduce r s.
Proof.
intros a r s H.
induct H; eauto using mcr_nil, mcr_cons.
Qed.

Lemma reduce_id : forall {m}, reduce m m.
Proof.
intro m.
induct m using
  (fun z => term_mut_ind _ z (fun a r => reducer r r)); eauto using reduce, reducer_nil, reducer_cons.
Qed.

Lemma reduce_compat :
  forall m n,
    mc reduce m n
    -> reduce m n.
Proof.
intros m n H.
induct H; eauto using reduce_id, reduce_oper, mcr_reducer.
Qed.

Lemma reducer_id :
  forall a (r : row a),
    reducer r r.
Proof.
intros a r.
apply mcr_reducer.
apply mcr_refl.
intro; apply reduce_id.
Qed.

Lemma reduce_value_impl :
  forall m n,
    reduce m n
    -> value m
    -> mc reduce m n.
Proof.
intros m n Hreduce Hvalue.
revert Hvalue.
cases Hreduce;
try (intros;
     invert Hvalue;
     intros;
     match goal with
     | H : canon _ _ |- _ => invert H; done
     end).
(* oper *)
intros a th r s H Hvalue.
apply mc_oper.
apply reducer_mcr; auto.
Qed.

Lemma reduces_value_impl :
  forall m n,
    star reduce m n
    -> value m
    -> mc (star reduce) m n.
Proof.
intros m n Hreduce.
induct Hreduce.

(* refl *)
{
intros m _.
apply mc_refl.
intro; apply star_refl.
}

(* trans *)
{
intros m n p Hmn _ IH Hvalm.
so (reduce_value_impl _#2 Hmn Hvalm) as Hmn'.
so (mc_value _#3 Hmn' Hvalm) as Hvaln.
so (IH Hvaln) as Hnp'.
eapply mc_trans; eauto.
  {
  intro; intros.
  eapply star_trans; eauto.
  }

  {
  apply (mc_mono reduce); auto.
  intros x y H.
  apply star_one; auto.
  }
}
Qed.

Lemma step_reduce :
  forall m n,
    step m n
    -> reduce m n.
Proof.
intros m n H.
induct H.

(* app1 *)
{
intros m1 m1' m2 _ IH.
apply reduce_compat.
apply mc_app; auto using reduce_id.
}

(* app2 *)
{
intros m1 m2.
apply reduce_app_beta; auto using reduce_id.
}

(* prev1 *)
{
intros.
apply reduce_compat.
apply mc_prev; auto.
}

(* prev2 *)
{
intros.
apply reduce_prev_beta; auto using reduce_id.
}

(* bite1 *)
{
intros m1 m1' m2 m3 _ IH.
apply reduce_compat.
apply mc_bite; auto using reduce_id.
}

(* bite2 *)
{
intros m1 m2.
apply reduce_bite_beta1.
apply reduce_id.
}

(* bite3 *)
{
intros m1 m2.
apply reduce_bite_beta2.
apply reduce_id.
}

(* ppi11 *)
{
intros.
apply reduce_compat.
apply mc_ppi1; auto.
}

(* ppi12 *)
{
intros.
apply reduce_ppi1_beta.
apply reduce_id.
}

(* ppi21 *)
{
intros.
apply reduce_compat.
apply mc_ppi2; auto.
}

(* ppi22 *)
{
intros.
apply reduce_ppi2_beta.
apply reduce_id.
}
Qed.

Lemma row_1_invert :
  forall i (r : @row object (cons i nil)),
    exists m,
      r = rw_cons m rw_nil.
Proof.
intros i r.
so (row_cons_invert _#3 r) as (m & r1 & ->).
so (row_nil_invert _ r1); subst r1.
eauto.
Qed.

Lemma row_2_invert :
  forall i j (r : @row object (cons i (cons j nil))),
    exists m n,
      r = rw_cons m (rw_cons n rw_nil).
Proof.
intros i j r.
so (row_cons_invert _#3 r) as (m & r1 & ->).
so (row_cons_invert _#3 r1) as (n & r2 & ->).
so (row_nil_invert _ r2); subst r2.
eauto.
Qed.

Lemma reduce_subst :
  forall s m m',
    reduce m m'
    -> reduce (subst s m) (subst s m').
Proof.
intros s m n H.
revert s.
induct H
  using (fun z => reduce_mut_ind z
           (fun a r t =>
              forall s,
                reducer (substr s r) (substr s t))).

(* var *)
{
intros i s.
apply reduce_id.
}

(* oper *)
{
intros a th r t _ IH s.
simpsub.
apply reduce_oper; auto.
}

(* app_beta *)
{
intros m m' n n' _ IH1 _ IH2 s.
simpsub.
relquest.
  {
  eapply reduce_app_beta; eauto.
  }
simpsub.
reflexivity.
}

(* prev_beta *)
{
intros m m' _ IH s.
simpsub.
apply reduce_prev_beta; auto.
}

(* bite_beta1 *)
{
intros n n' p _ IH s.
simpsub.
eapply reduce_bite_beta1; eauto.
}

(* bite_beta2 *)
{
intros n n' p _ IH s.
simpsub.
eapply reduce_bite_beta2; eauto.
}

(* ppi1_beta *)
{
intros.
simpsub.
eapply reduce_ppi1_beta; auto.
}

(* ppi1_beta *)
{
intros.
simpsub.
eapply reduce_ppi2_beta; auto.
}

(* nil *)
{
intros s.
apply reducer_nil.
}

(* cons *)
{
intros i a m m' r r' _ IH1 _ IH2 s.
simpsub.
apply reducer_cons; auto.
}
Qed.

Lemma reduces_subst :
  forall s m m',
    star reduce m m'
    -> star reduce (subst s m) (subst s m').
Proof.
intros s m m' Hreduces.
eapply star_map'; eauto.
intros; eapply reduce_subst; eauto.
Qed.

Combined Scheme reduce_reducer_ind from reduce_mut_ind, reducer_mut_ind.

Lemma reduce_reducer_funct1_under :
  forall n n',
    reduce n n'
    -> (forall i m m',
          reduce m m'
          -> reduce (subst (under i (dot n id)) m) (subst (under i (dot n' id)) m'))
       /\
       (forall i a (r r' : row a),
          reducer r r'
          -> reducer (substr (under i (dot n id)) r) (substr (under i (dot n' id)) r')).
Proof.
intros n n' Hn.
exploit (reduce_reducer_ind
           (fun m m' => forall i, reduce (subst (under i (dot n id)) m) (subst (under i (dot n' id)) m'))
           (fun a r r' => forall i, reducer (substr (under i (dot n id)) r) (substr (under i (dot n' id)) r'))) as Hind; try (intros; simpsub; eauto using reduce, reducer_nil, reducer_cons; done).

(* var *)
{
intros i j.
simpsub.
so (lt_eq_lt_dec i j) as [[Hij | Heq] | Hji].
  {
  rewrite -> !project_under_lt; try omega.
  apply reduce_id.
  }

  {
  subst j.
  rewrite -> !project_under_eq.
  simpsub.
  apply reduce_subst; auto.
  }

  {
  rewrite -> !project_under_geq; try omega.
  replace (i - j) with (S (pred (i - j))) by omega.
  simpsub.
  apply reduce_id.
  }
}

(* app_beta *)
{
intros m m' p p' _ IH1 _ IH2 i.
simpsub.
relquest.
  {
  eapply reduce_app_beta; auto.
  rewrite <- under_succ.
  apply IH1.
  }
simpsub.
reflexivity.
}

(* wrapup *)
{
destruct Hind.
split; intros; eauto.
}
Qed.

Lemma reduce_funct1_under :
  forall i n n' m m',
    reduce n n'
    -> reduce m m'
    -> reduce (subst (under i (dot n id)) m) (subst (under i (dot n' id)) m').
Proof.
intros i n n' m m' Hn Hm.
revert i m m' Hm.
exact (reduce_reducer_funct1_under n n' Hn andel).
Qed.

Lemma reducer_funct1_under :
  forall i a n n' (r r' : row a),
    reduce n n'
    -> reducer r r'
    -> reducer (substr (under i (dot n id)) r) (substr (under i (dot n' id)) r').
Proof.
intros i a n n' m m' Hn Hm.
revert i a m m' Hm.
exact (reduce_reducer_funct1_under n n' Hn ander).
Qed.

Lemma reduce_funct1 :
  forall n n' m m',
    reduce n n'
    -> reduce m m'
    -> reduce (subst1 n m) (subst1 n' m').
Proof.
intros n n' m m' Hn Hm.
unfold subst1.
rewrite <- (under_zero _ (dot n id)).
rewrite <- (under_zero _ (dot n' id)).
apply reduce_funct1_under; auto.
Qed.

Lemma reducer_funct1 :
  forall a n n' (r r' : row a),
    reduce n n'
    -> reducer r r'
    -> reducer (substr (dot n id) r) (substr (dot n' id) r').
Proof.
intros a n n' m m' Hn Hm.
rewrite <- (under_zero _ (dot n id)).
rewrite <- (under_zero _ (dot n' id)).
apply reducer_funct1_under; auto.
Qed.

Lemma diamond :
  forall m n p,
    reduce m n
    -> reduce m p
    -> exists q,
         reduce n q
         /\ reduce p q.
Proof.
intros m n p Hmn Hmp.
revert p Hmp.
induct Hmn using
  (fun z => reduce_mut_ind z
     (fun a r s => forall t, reducer r t -> exists u, reducer s u /\ reducer t u)).

(* var *)
{
intros i p Hmp.
exists p.
split; auto using reduce_id.
}

(* oper *)
{
intros a th r s Hrs IH p Hmp.
invertc Hmp.
  {
  intros t Hrt <-.
  so (IH _ Hrt) as (u & Hsu & Htu).
  exists (oper a th u).
  split; auto using reduce_oper.
  }

  (* oper / app_beta *)
  {
  intros m m2 n n2 Hm2 Hn2 <- Heqth Heqr <-.
  so (eq_dep_impl_eq_snd _#5 Heqth); subst th.
  so (eq_dep_impl_eq_snd _#5 Heqr); subst r.
  clear Heqth Heqr.
  invertc Hrs.
  intros a r1 Ha Hr1 <-.
  invertc Hr1.
  intros n1 r2 Hn1 Hr2 <-.
  invertc Hr2.
  intros <-.
  invertc Ha.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros m1 r2 Hm1 Hr2 <-.
  invertc Hr2.
  intros <-.
  fold (lam m1) in *.
  fold (app (lam m1) n1) in *.
  so (IH _ (reducer_cons (reduce_compat _ _ (mc_lam _#3 Hm2)) (reducer_cons Hn2 reducer_nil))) as (u & Hsu & Htu).
  invertc Htu.
  intros a r1 Ha Hr1 <-.
  invertc Hr1.
  intros q r2 Hq2 Hr2 <-.
  invertc Hr2.
  intros <-.
  invertc Ha.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros p r2 Hp2 Hr2 <-.
  invertc Hr2.
  intros <-.
  fold (lam p) in Hsu.
  invertc Hsu.
  intros Ha Hr1.
  invertc Hr1.
  intros Hq1 _.
  invertc Ha.
  intros Hr1 _.
  invertc Hr1.
  intros Hp1 _.
  exists (subst1 q p).
  split.
    {
    apply reduce_app_beta; auto.
    }

    {
    apply reduce_funct1; auto.
    }
  }

  (* oper / prev_beta *)
  {
  intros m Hmp <- Heqth Heqr.
  so (eq_dep_impl_eq_snd _#5 Heqth); subst th.
  so (eq_dep_impl_eq_snd _#5 Heqr); subst r.
  clear Heqth Heqr.
  invertc Hrs.
  intros nn r1 Hnn Hr1 <-.
  invertc Hr1.
  intros <-.
  fold (prev nn).
  invertc Hnn.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros n r2 Hmn Hr2 <-.
  invertc Hr2.
  intros <-.
  fold (next n) in *.
  so (IH _ (reducer_cons (reduce_compat _ _ (mc_next _#3 Hmp)) reducer_nil)) as (u & Hsu & Htu).
  invertc Htu.
  intros qq r1 Hqq Hr <-.
  invertc Hr.
  intros <-.
  invertc Hqq.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros q r2 Hpq Hr2 <-.
  invertc Hr2.
  intros <-.
  fold (next q) in *.
  invertc Hsu.
  intros H _.
  invertc H.
  intros H _.
  invertc H.
  intros Hnq _.
  exists q.
  split; auto.
  apply reduce_prev_beta; auto.
  }

  (* oper / bite_beta1 *)
  {
  intros m2 m3 Hmp <- Heqth Heqr.
  injectionT Heqth.
  intros <-.
  injectionT Heqr.
  intros <-.
  invertc Hrs.
  intros n1 r1 Hn1 Hr1 <-.
  invertc Hr1.
  intros n2 r2 Hn2 Hr2 <-.
  invertc Hr2.
  intros n3 r3 Hn3 Hr3 <-.
  invertc Hr3.
  intros <-.
  fold (bite n1 n2 n3) in *.
  so (IH _ (reducer_cons reduce_id (reducer_cons Hmp (reducer_cons reduce_id reducer_nil)))) as (u & Hru & Hsu).
  invertc Hsu.
  intros q1 r1 _ Hr1 <-.
  invertc Hr1.
  intros q2 r2 Hmq2 Hr2 <-.
  invertc Hr2.
  intros q3 r3 Hmq3 Hr3 <-.
  invertc Hr3.
  intros <-.
  invertc Hn1.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros <-.
  fold (@btrue object) in *.
  invertc Hru.
  intros _ Hr2.
  invertc Hr2.
  intros Hnq2 _.
  exists q2.
  split; auto.
  apply reduce_bite_beta1; auto.
  }

  (* oper / bite_beta2 *)
  {
  intros m2 m3 Hmp <- Heqth Heqr.
  injectionT Heqth.
  intros <-.
  injectionT Heqr.
  intros <-.
  invertc Hrs.
  intros n1 r1 Hn1 Hr1 <-.
  invertc Hr1.
  intros n2 r2 Hn2 Hr2 <-.
  invertc Hr2.
  intros n3 r3 Hn3 Hr3 <-.
  invertc Hr3.
  intros <-.
  fold (bite n1 n2 n3) in *.
  so (IH _ (reducer_cons reduce_id (reducer_cons reduce_id (reducer_cons Hmp reducer_nil)))) as (u & Hru & Hsu).
  invertc Hsu.
  intros q1 r1 _ Hr1 <-.
  invertc Hr1.
  intros q2 r2 Hmq2 Hr2 <-.
  invertc Hr2.
  intros q3 r3 Hmq3 Hr3 <-.
  invertc Hr3.
  intros <-.
  invertc Hn1.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros <-.
  fold (@bfalse object) in *.
  invertc Hru.
  intros _ Hr2.
  invertc Hr2.
  intros _ Hr3.
  invertc Hr3.
  intros Hnq3 _.
  exists q3.
  split; auto.
  apply reduce_bite_beta2; auto.
  }

  (* oper / ppi1_beta *)
  {
  intros m n Hmp <- Heqth Heqr.
  injectionT Heqth.
  intros <-.
  injectionT Heqr.
  intros <-.
  invertc Hrs.
  intros mn r1 Hmn Hr1 <-.
  invertc Hr1.
  intros <-.
  fold (ppi1 mn).
  invertc Hmn.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros m' r2 Hm Hr2 <-.
  invertc Hr2.
  intros n' r3 Hn Hr3 <-.
  invertc Hr3.
  intros <-.
  fold (ppair m' n') in *.
  so (IH _ (reducer_cons (reduce_compat _ _ (mc_ppair _#5 Hmp reduce_id)) (reducer_id _ _))) as (u & Hru & Hsu).
  invertc Hsu.
  intros q r1 Hq Hr1 <-.
  invertc Hr1.
  intros <-.
  invertc Hq.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros q1 r2 Hp_q1 Hr2 <-.
  invertc Hr2.
  intros q2 r3 Hn_q2 Hr3 <-.
  invertc Hr3.
  intros <-.
  fold (ppair q1 q2) in *.
  invertc Hru.
  intros H _.
  invertc H.
  intros H _.
  invertc H.
  intros Hm'_q1 H.
  invertc H.
  intros Hn'_q2 _.
  exists q1.
  split; auto.
  apply reduce_ppi1_beta; auto.
  }

  (* oper / ppi2_beta *)
  {
  intros m n Hmp <- Heqth Heqr.
  injectionT Heqth.
  intros <-.
  injectionT Heqr.
  intros <-.
  invertc Hrs.
  intros mn r1 Hmn Hr1 <-.
  invertc Hr1.
  intros <-.
  fold (ppi1 mn).
  invertc Hmn.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros m' r2 Hm Hr2 <-.
  invertc Hr2.
  intros n' r3 Hn Hr3 <-.
  invertc Hr3.
  intros <-.
  fold (ppair m' n') in *.
  so (IH _ (reducer_cons (reduce_compat _ _ (mc_ppair _#5 reduce_id Hmp)) (reducer_id _ _))) as (u & Hru & Hsu).
  invertc Hsu.
  intros q r1 Hq Hr1 <-.
  invertc Hr1.
  intros <-.
  invertc Hq.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros q1 r2 Hp_q1 Hr2 <-.
  invertc Hr2.
  intros q2 r3 Hn_q2 Hr3 <-.
  invertc Hr3.
  intros <-.
  fold (ppair q1 q2) in *.
  invertc Hru.
  intros H _.
  invertc H.
  intros H _.
  invertc H.
  intros Hm'_q1 H.
  invertc H.
  intros Hn'_q2 _.
  exists q2.
  split; auto.
  apply reduce_ppi2_beta; auto.
  }
}

(* app_beta *)
{
intros m m1 n n1 Hm1 IH1 Hn1 IH2 p Hmp.
invertc Hmp.
  (* app_beta / oper *)
  {
  intros s Hs <-.
  invertc Hs.
  intros a r1 Ha Hr1 <-.
  invertc Hr1.
  intros n2 r2 Hn2 Hr2 <-.
  invertc Hr2.
  intros <-.
  invertc Ha.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros m2 r2 Hm2 Hr2 <-.
  invertc Hr2.
  intros <-.
  fold (lam m2).
  fold (app (lam m2) n2).
  so (IH1 _ Hm2) as (p & Hp1 & Hp2).
  so (IH2 _ Hn2) as (q & Hq1 & Hq2).
  exists (subst1 q p).
  split.
    {
    apply reduce_funct1; auto.
    }

    {
    apply reduce_app_beta; auto.
    }
  }

  (* app_beta / app_beta *)
  {
  intros m2 n2 Hm2 Hn2 <-.
  so (IH1 _ Hm2) as (p & Hp1 & Hp2).
  so (IH2 _ Hn2) as (q & Hq1 & Hq2).
  exists (subst1 q p).
  split; apply reduce_funct1; auto.
  }
}

(* prev_beta *)
{
intros m n _ IH t Hmt.
invertc Hmt.
  (* prev_beta / oper *)
  {
  intros r Hr <-.
  invertc Hr.
  intros t r1 Ht Hr1 <-.
  invertc Hr1.
  intros <-.
  invertc Ht.
  intros r1 Hr1 <-.
  invertc Hr1.
  intros p r2 Hmp Hr2 <-.
  invertc Hr2.
  intros <-.
  fold (next p).
  fold (prev (next p)).
  so (IH _ Hmp) as (q & Hmq & Hpq).
  exists q.
  split; auto.
  apply reduce_prev_beta; auto.
  }

  (* prev_beta / prev_beta *)
  {
  intros Hmt.
  so (IH _ Hmt) as (q & Hnq & Hpq).
  eauto.
  }
}

(* bite_beta1 *)
{
intros m m1 n Hm1 IH p Hmp.
invertc Hmp.
  (* bite_beta1 / oper *)
  {
  intros s Hs <-.
  invertc Hs.
  intros a r1 Ha Hr1 <-.
  invertc Hr1.
  intros b r2 Hb Hr2 <-.
  invertc Hr2.
  intros c r3 Hc Hr3 <-.
  invertc Hr3.
  intros <-.
  fold (bite a b c).
  invertc Ha.
  intros r Hr <-.
  invertc Hr.
  intros <-.
  fold (@btrue object).
  so (IH _ Hb) as (q & Hm1q & Hbq).
  exists q.
  split; auto.
  apply reduce_bite_beta1; auto.
  }

  (* bite_beta1 / bite_beta1 *)
  {
  intros Hmp.
  so (IH _ Hmp) as (q & Hm1q & Hpq).
  eauto.
  }
}

(* bite_beta2 *)
{
intros m m1 n Hm1 IH p Hmp.
invertc Hmp.
  (* bite_beta2 / oper *)
  {
  intros s Hs <-.
  invertc Hs.
  intros a r1 Ha Hr1 <-.
  invertc Hr1.
  intros b r2 Hb Hr2 <-.
  invertc Hr2.
  intros c r3 Hc Hr3 <-.
  invertc Hr3.
  intros <-.
  fold (bite a b c).
  invertc Ha.
  intros r Hr <-.
  invertc Hr.
  intros <-.
  fold (@btrue object).
  so (IH _ Hc) as (q & Hm1q & Hbq).
  exists q.
  split; auto.
  apply reduce_bite_beta2; auto.
  }

  (* bite_beta1 / bite_beta1 *)
  {
  intros Hmp.
  so (IH _ Hmp) as (q & Hm1q & Hpq).
  eauto.
  }
}

(* ppi1_beta *)
{
intros m m1 n Hm1 IH p Hmp.
invertc Hmp.
  {
  intros s Hs <-.
  invertc Hs.
  intros a r1 Ha Hr1 <-.
  invertc Hr1.
  intros <-.
  fold (ppi1 a).
  invertc Ha.
  intros s Hs <-.
  invertc Hs.
  intros b r1 Hb Hr1 <-.
  invertc Hr1.
  intros c r2 Hc Hr2 <-.
  invertc Hr2.
  intros <-.
  fold (ppair b c).
  so (IH _ Hb) as (q & Hm1q & Hbq).
  exists q.
  split; auto.
  apply reduce_ppi1_beta; auto.
  }

  {
  intros Hmp.
  so (IH _ Hmp) as (q & Hm1q & Hpq).
  eauto.
  }
}

(* ppi2_beta *)
{
intros m m1 n Hm1 IH p Hmp.
invertc Hmp.
  {
  intros s Hs <-.
  invertc Hs.
  intros a r1 Ha Hr1 <-.
  invertc Hr1.
  intros <-.
  fold (ppi1 a).
  invertc Ha.
  intros s Hs <-.
  invertc Hs.
  intros b r1 Hb Hr1 <-.
  invertc Hr1.
  intros c r2 Hc Hr2 <-.
  invertc Hr2.
  intros <-.
  fold (ppair b c).
  so (IH _ Hc) as (q & Hm1q & Hbq).
  exists q.
  split; auto.
  apply reduce_ppi2_beta; auto.
  }

  {
  intros Hmp.
  so (IH _ Hmp) as (q & Hm1q & Hpq).
  eauto.
  }
}

(* nil *)
{
intros t H.
invertc H.
intros <-.
exists rw_nil; split; apply reducer_nil.
}

(* cons *)
{
intros i a m m1 r r1 _ IH1 _ IH2 s Hs.
invertc Hs.
intros m2 r2 Hm2 Hr2 <-.
so (IH1 _ Hm2) as (p & Hp1 & Hp2).
so (IH2 _ Hr2) as (s & Hs1 & Hs2).
exists (rw_cons p s).
split; apply reducer_cons; auto.
}
Qed.

Lemma confluence :
  forall m n p,
    star reduce m n
    -> star reduce m p
    -> exists q,
         star reduce n q
         /\ star reduce p q.
Proof.
intros m n p Hmn Hmp.
revert p Hmp.
induct Hmn.

(* refl *)
{
intros m p Hmp.
exists p.
split; auto.
apply star_refl.
}

(* step *)
{
intros m q n Hmq Hqn IH p Hmp.
assert (exists r, reduce p r /\ star reduce q r) as (r & Hpr & Hqr).
  {
  clear n Hqn IH.
  revert q Hmq.
  induct Hmp.
    (* refl *)
    {
    intros m q Hmq.
    exists q.
    split; auto.
    apply star_refl.
    }

    (* step *)
    {
    intros m r p Hmr _ IH q Hmq.
    so (diamond _#3 Hmr Hmq) as (s & Hrs & Hqs).
    so (IH _ Hrs) as (t & Hpt & Hrt).
    exists t.
    split; auto.
    eapply star_step; eauto.
    }
  }
so (IH _ Hqr) as (s & Hns & Hps).
exists s.
split; auto.
eapply star_step; eauto.
}
Qed.

Lemma reduce_var_form :
  forall i m,
    reduce (var i) m
    -> m = var i.
Proof.
intros i m H.
invertc H.
auto.
Qed.

Lemma reduces_var_form :
  forall i m,
    star reduce (var i) m
    -> m = var i.
Proof.
intros i m H.
remember (var i) as n eqn:Heq.
revert Heq.
induct H; auto.
intros m1 m2 m3 H12 _ IH ->.
so (reduce_var_form _#2 H12); subst m2.
apply IH; auto.
Qed.

Lemma reduce_canon_form :
  forall a (th : @operator object a) r m,
    canon _ th
    -> reduce (oper a th r) m
    -> exists s, m = oper a th s /\ reducer r s.
Proof.
intros a th r m Hcanon Hreduce.
invert Hreduce.

(* oper *)
{
intros s Hrs <-.
exists s.
auto.
}

(* app_beta *)
{
intros _ _ _ _ _ _ <- Heq _ _.
injectionT Heq.
intros <-.
invert Hcanon.
}

(* prev_beta *)
{
intros _ _ <- Heq _.
injectionT Heq.
intros <-.
invert Hcanon.
}

(* bite_beta1 *)
{
intros _ _ _ <- Heq _.
injectionT Heq.
intros <-.
invert Hcanon.
}

(* bite_beta2 *)
{
intros _ _ _ <- Heq _.
injectionT Heq.
intros <-.
invert Hcanon.
}

(* ppi1_beta *)
{
intros _ _ _ <- Heq _.
injectionT Heq.
intros <-.
invert Hcanon.
}

(* ppi2_beta *)
{
intros _ _ _ <- Heq _.
injectionT Heq.
intros <-.
invert Hcanon.
}
Qed.

Lemma reduces_canon_form :
  forall a (th : @operator object a) r m,
    canon _ th
    -> star reduce (oper a th r) m
    -> exists s, m = oper a th s /\ star reducer r s.
Proof.
intros a th r m Hcanon Hreduces.
remember (oper a th r) as n eqn:Heq.
revert r Heq.
induct Hreduces.

(* refl *)
{
intros ? r ->.
exists r; auto using star_refl.
}

(* step *)
{
intros ? m n Hreduce _ IH r ->.
so (reduce_canon_form _#4 Hcanon Hreduce) as (s & -> & Hrs).
so (IH s (eq_refl _)) as (t & -> & Hst).
exists t.
split; auto.
eapply star_trans; eauto using star_one.
}
Qed.

Lemma reduces_lam_form :
  forall m n,
    star reduce (lam m) n
    -> exists m',
         n = lam m'
         /\ star reduce m m'.
Proof.
intros m n Hreduces.
so (reduces_canon_form _#4 (canon_lam _) Hreduces) as (r & -> & Hr).
so (star_mcr _#4 (star_mono _#3 (reducer_mcr _) _ _ Hr)) as H; clear Hr.
invertc H.
intros m' r1 Hm Hr1 <-.
invertc Hr1.
intros <-.
fold (lam m').
exists m'; auto.
Qed.

Lemma reduces_triv_form :
  forall (m : @term object),
    star reduce triv m
    -> m = triv.
Proof.
intros m Hred.
so (reduces_canon_form _#4 (canon_triv _) Hred) as (r & -> & Hr).
so (star_mcr _#4 (star_mono _#3 (reducer_mcr _) _ _ Hr)) as H; clear Hr.
invertc H.
intros <-.
reflexivity.
Qed.

Definition rigid (m : @term object) : Prop
  :=
  forall n,
    star reduce m n
    -> ((forall p, n <> lam p) /\ (forall p, n <> prev p)).

Lemma rigid_var :
  forall i, rigid (var i).
Proof.
intros i.
intros n Hreduce.
cut (n = var i).
  {
  intros ->.
  split; intros n Heq; discriminate Heq.
  }
remember (var i) as m eqn:Heq.
revert Heq.
induct Hreduce; auto.
intros m n p Hreduce _ IH ->.
invert Hreduce.
intros <-.
apply IH; auto.
Qed.

Lemma rigid_app :
  forall (m n : @term object),
    rigid m
    -> rigid (app m n).
Proof.
intros m n Hrigid.
intros p Hreduces.
remember (app m n) as mn eqn:Heq.
revert m n Hrigid Heq.
induct Hreduces.

(* refl *)
{
intros ? m n Hrigid ->.
split; intros ? Heq; discriminate Heq.
}

(* step *)
{
intros a b c Hab _ IH m1 n Hrigid ->.
invertc Hab.
2:{
  intros r _ _ _ _ <- _.
  exfalso.
  exact (Hrigid _ (star_refl _) andel _ (eq_refl _)).
  }
intros r Hreduce <-.
invertc Hreduce.
intros m2 r1 Hm12 Hr1 <-.
invertc Hr1.
intros n2 r2 Hn12 Hr2 <-.
invertc Hr2.
intros <-.
fold (app m2 n2) in IH.
apply (IH m2 n2); auto.
intros m3 Hm23.
apply Hrigid.
eapply star_step; eauto.
}
Qed.

Lemma reduce_rigid :
  forall (m n : @term object),
    reduce m n
    -> rigid m
    -> rigid n.
Proof.
intros m n Hreduce Hrigid.
intros p Hnp.
apply Hrigid; eauto using star_step.
Qed.

Lemma reduce_app_form :
  forall (m n p : @term object),
    rigid m
    -> reduce (app m n) p
    -> exists m' n', p = app m' n' /\ reduce m m' /\ reduce n n'.
Proof.
intros m n p Hrigid Hreduce.
invertc Hreduce.

(* oper *)
{
intros r Hreduce <-.
so (row_invert_auto _ _ r) as H; cbn in H.
destruct H as (m' & n' & ->).
fold (app m' n').
invertc Hreduce.
intros Hm Hreduce.
invertc Hreduce.
intros Hn _.
exists m', n'.
auto.
}

(* app_beta *)
{
intros m' _ _ _ _ <- _.
exfalso.
exact (Hrigid (lam m') (star_refl _) andel _ (eq_refl _)).
}
Qed.

Lemma reduces_app_form :
  forall (m n p : @term object),
    rigid m
    -> star reduce (app m n) p
    -> exists m' n', p = app m' n' /\ star reduce m m' /\ star reduce n n'.
Proof.
intros m n p Hrigid Hreduces.
remember (app m n) as mn eqn:Heq.
revert m n Hrigid Heq.
induct Hreduces.

(* refl *)
{
intros ? m n Hrigid ->.
exists m, n; auto using star_refl.
}

(* step *)
{
intros x b c Hreduce _ IH m n Hrigid ->.
so (reduce_app_form _#3 Hrigid Hreduce) as (m' & n' & -> & Hm & Hn).
so (IH _ _ (reduce_rigid _ _ Hm Hrigid) (eq_refl _)) as (m'' & n'' & -> & Hm' & Hn').
exists m'', n''.
do2 2 split; eauto using star_step.
}
Qed.

End object.

Arguments mcr {object}.
Arguments mc {object}.
Arguments mcr_nil {object}.
Arguments mcr_cons {object}.
Arguments mc_var {object}.
Arguments mc_oper {object}.
Arguments reduce {object}.
Arguments reducer {object a}.
Arguments reducer_nil {object}.
Arguments reducer_cons {object i a}.
Arguments rigid {object}.

Ltac invertc_mcr H :=
  revertnew
  (repeat (invertc H; []; intros ? ? ? H <-); invertc H; []; intros <-).

Ltac invertc_mc H :=
  let H' := fresh
  in
    invertc H; []; intros ? H'; invertc_mcr H'.


Require Import Arith List Finite_sets_facts Recdef Wf_nat Omega.

Lemma Forall_map : forall X Y (P : Y -> Prop) (f : X -> Y) l,
  Forall P (map f l) <-> Forall (fun x => P (f x)) l.
Proof.
  intros X Y P f l.
  split; intros H.
  - apply Forall_forall.
    intros x HListIn.
    eapply Forall_forall in H.
    apply H.
    apply in_map; auto.

  - induction l as [| x l'];
      simpl;
      inversion H;
      constructor;
      auto.
Qed.

Lemma Exists_map : forall X Y (P : Y -> Prop) (f : X -> Y) l,
  Exists P (map f l) <-> Exists (fun x => P (f x)) l.
Proof.
  intros X Y P f l.
  split.
  - intros HExists.
    apply Exists_exists in HExists.
    apply Exists_exists.
    destruct HExists as [x [HListIn HP]].
    apply in_map_iff in HListIn.
    destruct HListIn as [y [Heq HListIn]].
    exists y.
    subst; auto.

  - intros HExists.
    apply Exists_exists in HExists.
    apply Exists_exists.
    destruct HExists as [x [HListIn HP]].
    exists (f x).
    split; auto.
    apply in_map; auto.
Qed.

Lemma Exists_preserves_Finite : forall U family,
  Forall (Finite _) family ->
  Finite _ (fun x : U => Exists (fun s => s x) family).
Proof.
  intros U family Hall.
  induction family as [| s family'].
  - rewrite Extensionality_Ensembles with (B := Empty_set _).
      constructor.
      split; intros x H; inversion H.

  - inversion Hall.
    rewrite Extensionality_Ensembles
      with (B := Union _ s (fun x : U => Exists (fun s => s x) family')).
    + apply Union_preserves_Finite; auto.
    + split;
        intros y HIn;
        (inversion HIn; [ left | right ]);
        auto.
Qed.

Lemma Exists_app : forall X (P : X -> Prop) l1 l2,
  Exists P (l1 ++ l2) -> Exists P l1 \/ Exists P l2.
Proof.
  intros X P l1 l2 Hexists.
  induction l1.
  - auto.

  - inversion Hexists.
    + left. left. auto.

    + assert (IHl1':  Exists P l1 \/ Exists P l2).
      * apply IHl1.
        auto.
      * destruct IHl1' as [IHl1' | IHl1'].
        left. right. auto.
        right. auto.
Qed.

Lemma Forall_app : forall X (P : X -> Prop) l1 l2,
  Forall P (l1 ++ l2) ->
  Forall P l1 /\ Forall P l2.
Proof.
  intros X P l1 l2 HForall.
  induction l1.
  - split; auto.

  - inversion HForall.
    specialize (IHl1 H2).
    destruct IHl1.
    split.
    + constructor; auto.
    + auto.
Qed.

Module Types.
  Inductive t : Set :=
    | Base : t
    | Var : nat -> t
    | Fun : t -> t -> t.

  Fixpoint size t :=
    match t with
    | Fun t1 t2 => S (size t1 + size t2)
    | _ => 1
    end.

  Inductive In x : t -> Prop :=
    | In_Fun_dom : forall t1 t2,
        In x t1 ->
        In x (Fun t1 t2)
    | In_Fun_cod : forall t1 t2,
        In x t2 ->
        In x (Fun t1 t2)
    | In_Var : In x (Var x).

  Definition In_dec : forall x t, { In x t } + { ~In x t }.
  Proof.
    intros x.
    refine (fix In_dec (t0 : t) :=
      match t0 as t0' return { In x t0' } + { ~In x t0' } with
      | Base => right _
      | Var y =>
          match eq_nat_dec x y with
          | left H => left (eq_ind _ (fun y0 : nat => In x (Var y0)) (In_Var _) _ H)
          | _ => right _
          end
      | Fun t1 t2 =>
          match In_dec t1 with
          | left H => left (In_Fun_dom _ _ _ H)
          | right _ =>
              match In_dec t2 with
              | left H => left (In_Fun_cod _ _ _ H)
              | right _ => right _
              end
          end
      end); (intros H; inversion H; auto).
  Defined.

  Lemma notIn_Fun : forall x t1 t2, ~In x (Fun t1 t2) -> ~In x t1 /\ ~In x t2.
  Proof.
    intros x t1 t2 HnotIn.
    split; intros HIn; apply HnotIn; [ apply In_Fun_dom | apply In_Fun_cod ]; auto.
  Qed.

  Theorem FV_Finite : forall t, Finite _ (fun x => In x t).
  Proof.
    intros t.
    induction t as [ | x | t1 IHt1 t2 IHt2 ].
    - rewrite Extensionality_Ensembles with (B := Empty_set _).
      + constructor.
      + split; (intros x H; inversion H).
    - rewrite Extensionality_Ensembles with (B := Singleton _ x).
      + apply Singleton_is_finite.
      + split; (intros y H; inversion H; constructor).
    - rewrite Extensionality_Ensembles with
        (B := Union _ (fun x => In x t1) (fun x => In x t2)).
      + apply Union_preserves_Finite; assumption.
      + split; intros x H; inversion H;
          [ left | right | apply In_Fun_dom | apply In_Fun_cod ]; assumption.
  Qed.

  Fixpoint subst x t0 t :=
    match t with
    | Base => Base
    | Var y =>
        if eq_nat_dec x y then t0
        else t
    | Fun t1 t2 => Fun (subst x t0 t1) (subst x t0 t2)
    end.

  Theorem subst_In_occur : forall x t1 t2,
    In x (subst x t1 t2) -> In x t1.
  Proof.
    intros x t1 t2 HIn.
    induction t2 as [ | y | t21 IHt21 t22 IHt22 ]; simpl in * |- *.
    - inversion HIn.

    - destruct (eq_nat_dec x y).
        assumption.
        inversion HIn. congruence.

    - inversion HIn; auto.
  Qed.

  Theorem subst_notIn : forall x t1 t2,
    ~In x t2 -> subst x t1 t2 = t2.
  Proof.
    intros x t1 t2 HnotIn.
    induction t2 as [ | y | t21 IHt21 t22 IHt22 ]; simpl in * |- *.
    - reflexivity.

    - destruct (eq_nat_dec x y) as [ Heq | ].
      + rewrite Heq in HnotIn. exfalso. apply HnotIn. constructor.
      + auto.

    - destruct (notIn_Fun _ _ _ HnotIn) as [HnotIn21 HnotIn22].
      specialize (IHt21 HnotIn21).
      specialize (IHt22 HnotIn22).
      congruence.
  Qed.

  Theorem subst_In_or : forall x y t1 t2,
    In x (subst y t1 t2) -> In x t1 \/ In x t2.
  Proof.
    intros x y t1 t2 HIn.
    induction t2 as [ | x' | t21 IHt21 t22 IHt22 ]; simpl in * |- *.
    - inversion HIn.

    - destruct (eq_nat_dec y x') as [ Heq | ].
      + rewrite <- Heq. left. auto.
      + right. auto.

    - inversion HIn as [t21' t22' HIn' | t21' t22' HIn' |].
      + destruct (IHt21 HIn'); [ left | right; apply In_Fun_dom ]; auto.
      + destruct (IHt22 HIn'); [ left | right; apply In_Fun_cod ]; auto.
  Qed.

  Definition subst_list subs t1 :=
    fold_left (fun t1 (sub : nat * t) =>
      let (x, t0) := sub in
      subst x t0 t1) subs t1.

  Lemma subst_list_app : forall subs1 subs2 t,
    subst_list (subs1 ++ subs2) t = subst_list subs2 (subst_list subs1 t).
  Proof.
    apply fold_left_app.
  Qed.

  Lemma subst_list_Base : forall subs,
    subst_list subs Base = Base.
  Proof.
    intros.
    induction subs as [| [x t] subs' IHsubs'].
    - auto.
    - simpl. rewrite IHsubs'. auto.
  Qed.

  Lemma subst_list_Fun : forall subs t1 t2,
    subst_list subs (Fun t1 t2) = Fun (subst_list subs t1) (subst_list subs t2).
  Proof.
    intros subs.
    induction subs as [| [x t] subs']; intros t1 t2; simpl; eauto.
  Qed.

  Notation unifies subs t1 t2 :=
    (subst_list subs t1 = subst_list subs t2).

  Lemma subst_preserves_unifies : forall x t0 subs t,
    unifies subs (Var x) t0 ->
    unifies subs t (subst x t0 t).
  Proof.
    intros x t0 subs t Hunifies.
    induction t as [ | y | t1 IHt1 t2 IHt2 ]; simpl in * |- *.
    - auto.
    - destruct (eq_nat_dec x y); congruence.
    - repeat rewrite subst_list_Fun. f_equal; auto.
  Qed.

  Lemma unifies_occur : forall x t,
    Var x <> t -> In x t -> forall subs, ~unifies subs (Var x) t.
  Proof.
    intros x t Hneq Hoccur subs Hunifies.
    assert (size (subst_list subs (Var x)) >= size (subst_list subs t)).
    - rewrite Hunifies.
      constructor.
    - clear Hunifies.
      induction Hoccur as [ t1 t2 HIn IHHoccur | t1 t2 HIn IHHoccur | ].
      + rewrite subst_list_Fun in H.
        simpl in H.
        apply IHHoccur; [ intros Heq; rewrite Heq in H | ]; omega.

      + rewrite subst_list_Fun in H.
        simpl in H.
        apply IHHoccur; [ intros Heq; rewrite Heq in H | ]; omega.

      + auto.
  Qed.
End Types.

Module Constraint.
  Definition t := (Types.t * Types.t)%type.

  Definition size constraints :=
    fold_right plus 0
      (map (fun c : t =>
        let (t1, t2) := c in
        Types.size t1 + Types.size t2) constraints).

  Definition In x constraints :=
    Exists (fun c : t =>
      let (t1, t2) := c in
      Types.In x t1 \/ Types.In x t2) constraints.

  Lemma FV_Finite : forall constraints, Finite _ (fun x => In x constraints).
  Proof.
    intros constraints.
    unfold In.
    rewrite Extensionality_Ensembles with
      (B := fun x => Exists (fun s => s x) (map (fun c : t =>
        let (t1, t2) := c in
        Union _ (fun x => Types.In x t1) (fun x => Types.In x t2)) constraints)).
    - apply Exists_preserves_Finite.
      apply Forall_map.
      apply Forall_forall.
      intros [t1 t2] HIn.
      apply Union_preserves_Finite; apply Types.FV_Finite.

    - split;
      intros x HIn;
      [ apply Exists_map | apply Exists_map in HIn ];
      apply Exists_exists in HIn;
      apply Exists_exists;
      destruct HIn as [[t1 t2] [HListIn HIn]];
      exists (t1, t2);
      (split;
        [ auto
        | destruct HIn; [left | right]; auto ]).
  Qed.

  Definition subst x t0 constraints :=
    map (fun c : t =>
      let (t1, t2) := c in
      (Types.subst x t0 t1, Types.subst x t0 t2)) constraints.

  Theorem subst_In_occur : forall x t constraints,
    In x (subst x t constraints) -> Types.In x t.
  Proof.
    intros x t constraints HIn.
    induction constraints as [| [t1 t2] constraints' IHconstraints']; simpl in * |- *.
    - inversion HIn.

    - inversion HIn as [[t1' t2'] constraints'' Hor |]; subst.
      + destruct Hor as [HIn' | HIn'];
        eapply Types.subst_In_occur;
        apply HIn'.

      + apply IHconstraints'.
        auto.
  Qed.

  Theorem subst_In_or : forall x y t constraints,
    In x (subst y t constraints) -> Types.In x t \/ In x constraints.
  Proof.
    intros x y t constraints HIn.
    induction constraints as [| [t1 t2] constraints' IHconstraints']; simpl in * |- *.
    - inversion HIn.

    - inversion HIn as [[t1' t2'] constraints'' Hor | [t1' t2'] constraints'' HIn' ];
        subst.
      + destruct Hor as [HIn' | HIn'];
        (destruct (Types.subst_In_or _ _ _ _ HIn');
          [left | right; left]; auto).

      + destruct (IHconstraints' HIn'); [ left | right; right ]; auto.
  Qed.

  Notation subst_list subs constraints :=
    (map (fun p : t =>
      let (t1, t2) := p in
      (Types.subst_list subs t1, Types.subst_list subs t2)) constraints).

  Lemma subst_list_app : forall subs1 subs2 constraints,
      subst_list (subs1 ++ subs2) constraints =
      subst_list subs2 (subst_list subs1 constraints).
  Proof.
    intros subs1 subs2 constraints.
    rewrite map_map.
    apply map_ext.
    intros [t1 t2].
    f_equal; apply Types.subst_list_app.
  Qed.

  Notation unifies subs constraints :=
    (Forall (fun p : t =>
      let (t1, t2) := p in
      Types.unifies subs t1 t2) constraints).

  Theorem subst_preserves_unifies : forall x t0 subs constraints,
    Types.unifies subs (Types.Var x) t0 ->
    unifies subs constraints ->
    unifies subs (subst x t0 constraints).
  Proof.
    intros x t0 subs constraints Hunifies Hunifies'.
    unfold subst.
    apply Forall_map.
    eapply Forall_impl; [| apply Hunifies'].
    intros [t1 t2] Hunifies''.
    repeat rewrite <- (Types.subst_preserves_unifies _ _ _ _ Hunifies).
    auto.
  Qed.

  Lemma unify_sound_same : forall t subs constraints,
    unifies subs constraints ->
    unifies subs ((t, t) :: constraints).
  Proof.
    intros t subs constraints Hunifies.
    constructor; auto.
  Qed.

  Lemma unify_complete_same : forall t subs constraints,
    unifies subs ((t, t) :: constraints) ->
    unifies subs constraints.
  Proof.
    intros t subs constraints Hunifies.
    inversion Hunifies.
    auto.
  Qed.

  Lemma unify_sound_subst : forall x t l constraints,
    ~Types.In x t ->
    unifies l (subst x t constraints) ->
    unifies ((x, t) :: l) ((Types.Var x, t) :: constraints).
  Proof.
    intros x t l constraints Hoccur Hunifies.
    constructor.
    - simpl.
      destruct (eq_nat_dec x x).
      + rewrite Types.subst_notIn; auto.
      + exfalso. auto.

    - unfold subst in Hunifies.
      apply Forall_map in Hunifies.
      eapply Forall_impl; [| apply Hunifies ].
      intros [t0 t3] Heqsubst.
      simpl in Heqsubst.
      auto.
  Qed.

  Lemma unify_sound_comm : forall t1 t2 subs constraints,
    unifies subs ((t2, t1) :: constraints) ->
    unifies subs ((t1, t2) :: constraints).
  Proof.
    intros t1 t2 subs constraints Hunifies.
    inversion Hunifies.
    constructor; auto.
  Qed.

  Lemma unify_sound_fun : forall constraints t11 t12 t21 t22 subs,
    unifies subs ((t11, t21) :: (t12, t22) :: constraints) ->
    unifies subs ((Types.Fun t11 t12, Types.Fun t21 t22) :: constraints).
  Proof.
    intros constraints t11 t12 t21 t22 subs Hunifies.
    inversion Hunifies as [| x l Hunifies1 Hunifies'].
    inversion Hunifies'.
    constructor.
    - repeat rewrite Types.subst_list_Fun. f_equal; auto.
    - auto.
  Qed.

  Lemma unify_complete_fun : forall constraints t11 t12 t21 t22 subs,
    unifies subs ((Types.Fun t11 t12, Types.Fun t21 t22) :: constraints) ->
    unifies subs ((t11, t21) :: (t12, t22) :: constraints).
  Proof.
    intros constraints t11 t12 t21 t22 subs Hunifies.
    inversion Hunifies as [| [t1 t2] l Hunifies1 Hunifies'].
    repeat rewrite Types.subst_list_Fun in Hunifies1.
    inversion Hunifies1.
    repeat (constructor; auto).
  Qed.

  Definition lt constraints1 constraints2 :=
    forall n m,
    cardinal _ (fun x => In x constraints1) n ->
    cardinal _ (fun x => In x constraints2) m ->
    n <= m /\ (m <= n -> size constraints1 < size constraints2).

  Lemma lt_well_founded : well_founded lt.
  Proof.
    intros constraints1.
    destruct (finite_cardinal _ _ (FV_Finite constraints1)) as [n Hcardinal1].
    generalize dependent constraints1.
    induction n as [n IHn] using lt_wf_ind.
    intros constraints1 Hcardinal1.
    induction constraints1 as [constraints1 IHconstraints1] using (induction_ltof1 _ size).
    constructor.
    intros constraints2 Hlt.
    destruct (finite_cardinal _ _ (FV_Finite constraints2)) as [m Hcardinal2].
    destruct (Hlt _ _ Hcardinal2 Hcardinal1) as [Hcard Hsize].
    destruct (eq_nat_dec m n) as [Heq |].
    - rewrite Heq in * |- *.
      apply IHconstraints1; [ apply Hsize |]; auto.

    - apply IHn with (m := m).
      + omega.
      + auto.
  Qed.

  Lemma lt_subst : forall constraints x t t1 t2,
    ~Types.In x t ->
    (t1 = t /\ t2 = Types.Var x \/ t1 = Types.Var x /\ t2 = t) ->
    lt (subst x t constraints) ((t1, t2) :: constraints).
  Proof.
    intros constraints x t t1 t2 HnotIn HVar m n Hcardinal1 Hcardinal2.

    (* *** *)
    assert (Hinclst:
              Strict_Included _
                              (fun y => In y (subst x t constraints))
                              (fun y => In y ((t1, t2) :: constraints))).
    - split.
      (* Included の証明 *)
      + intros y HIn.
        apply subst_In_or in HIn.
        destruct HIn as [ HIn | HIn ].
        * left. destruct HVar as [[Ht1 Ht2] | [Ht1 Ht2]]; subst; auto.
        * right. auto.

        (*
  (fun y : nat => In y (subst x t constraints)) <>
  (fun y : nat => In y ((t1, t2) :: constraints))
         *)
      + intros Hcontra.
        assert (HnotIncluded: ~Included _
                               (fun y => In y ((t1, t2) :: constraints))
                               (fun y => In y (subst x t constraints))).
        * intros HIncluded.
          specialize (HIncluded x).
          assert (HIn: In x ((t1, t2) :: constraints)).
          destruct HVar as [[Ht1 Ht2] | [Ht1 Ht2]]; subst;
            left; [right | left]; constructor.
          specialize (HIncluded HIn).
          apply subst_In_occur in HIncluded.
          auto.
        * apply HnotIncluded.
          rewrite Hcontra.
          intros y H.
          auto.
      (* *** *)

    - Check  (incl_st_card_lt _ _ _ Hcardinal1 _ _ Hcardinal2 Hinclst).
      specialize (incl_st_card_lt _ _ _ Hcardinal1 _ _ Hcardinal2 Hinclst).
      intros.
      split.
      + omega.
      + intro Hc.
        omega.
  Qed.

  Lemma lt_fun : forall t11 t12 t21 t22 constraints,
      lt ((t11, t21) :: (t12, t22) :: constraints)
         ((Types.Fun t11 t12, Types.Fun t21 t22) :: constraints).
  Proof.
    intros t11 t12 t21 t22 constraints m n Hcardinal1 Hcardinal2.
    split.
    - apply (incl_card_le _ _ _ _ _ Hcardinal1 Hcardinal2).
      intros x HIn.
      inversion HIn as [[t11' t21'] constraints' Hor | [t11' t21'] constraints' HIn' ].
        left.
        destruct Hor; [left | right]; apply Types.In_Fun_dom; auto.

        inversion HIn' as [[t12' t22'] constraints'' Hor | ].
        + left.
          destruct Hor; [left | right]; apply Types.In_Fun_cod; auto.

        + right.
          auto.

    - intros.
      unfold size.
      simpl.
      omega.
  Qed.

  Lemma lt_cons : forall c constraints,
    lt constraints (c :: constraints).
  Proof.
    intros [t1 t2] constraints m n Hcardinal1 Hcardinal2.
    split.
    - apply (incl_card_le _ _ _ _ _ Hcardinal1 Hcardinal2).
      intros x HIn.
      right.
      auto.

    - intros.
      unfold size.
      simpl.
      assert (0 < Types.size t1).
      + induction t1; simpl; omega.
      + omega.
  Qed.

  Function unify constraints { wf lt constraints } :=
    match constraints with
    | nil => Some nil
    | (Types.Base, Types.Base) :: constraints' =>
        unify constraints'
    | (Types.Var x, Types.Var y) :: constraints'  =>
        if eq_nat_dec x y then unify constraints'
        else option_map (cons (x, Types.Var y)) (unify (subst x (Types.Var y) constraints'))
    | (Types.Var x, t2) :: constraints' =>
        if Types.In_dec x t2 then None
        else option_map (cons (x, t2)) (unify (subst x t2 constraints'))
    | (t1, Types.Var y) :: constraints' =>
        if Types.In_dec y t1 then None
        else option_map (cons (y, t1)) (unify (subst y t1 constraints'))
    | (Types.Fun t11 t12, Types.Fun t21 t22) :: constraints' =>
        unify ((t11, t21) :: (t12, t22) :: constraints')
    | _ => None
    end.
  Proof.
    - intros.
      apply lt_cons.

    - intros.
      apply lt_subst; auto.

    - intros.
      apply lt_subst; auto.

    - intros.
      apply lt_cons.

    - intros.
      apply lt_subst; auto.
      intros H.
      inversion H.
      auto.

    - intros.
      apply lt_subst; auto.

    - intros.
      apply lt_subst; auto.

    - intros.
      apply lt_fun.

    - apply lt_well_founded.
  Qed.

  Theorem unify_sound : forall constraints subs,
    unify constraints = Some subs -> unifies subs constraints.
  Proof.
    intros constraints.
    functional induction (unify constraints);
      intros subs Hunify;
      try solve [inversion Hunify];
      try (apply unify_sound_same; auto).

    - constructor.

    - destruct (unify (subst x (Types.Var y) constraints')); inversion Hunify.
      apply unify_sound_subst.
      * intros H. inversion H. auto.
      * auto.

    - destruct (unify (subst x t2 constraints')); inversion Hunify.
      apply unify_sound_subst; auto.

    - destruct (unify (subst y t1 constraints')); inversion Hunify.
      apply unify_sound_comm.
      apply unify_sound_subst; auto.

    - apply unify_sound_fun.
      auto.
  Qed.

  Notation moregen subs subs' :=
    (exists subs0, forall t,
          Types.subst_list subs' t = Types.subst_list subs0 (Types.subst_list subs t)).

  Lemma moregen_extend : forall subs x t subs',
    Types.unifies subs (Types.Var x) t ->
    moregen subs' subs ->
    moregen ((x, t) :: subs') subs.
  Proof.
    intros subs x t0 subs' Hunifies Hmoregen.
    destruct Hmoregen as [ subs0 Hmoregen' ].
    exists subs0.
    intros t1.
    simpl.
    rewrite <- Hmoregen'.
    rewrite <- Types.subst_preserves_unifies; auto.
  Qed.

  Lemma unify_complete_subst : forall x t subs constraints,
    ~Types.In x t ->
    (forall subs,
      unifies subs (subst x t constraints) ->
      exists subs',
        unify (subst x t constraints) = Some subs' /\ moregen subs' subs) ->
    unifies subs ((Types.Var x, t) :: constraints) ->
    exists subs',
      option_map (cons (x, t)) (unify (subst x t constraints)) = Some subs' /\
      moregen subs' subs.
  Proof.
    intros x t subs constraints Hoccur IH Hunifies.
    inversion Hunifies as [| [t1 t2] l' Hu Hunifies'].
    apply (subst_preserves_unifies _ _ _ _ Hu) in Hunifies'.
    specialize (IH _ Hunifies').
    destruct IH as [subs' [Heq Hmoregen]].
    rewrite Heq.
    exists ((x, t) :: subs').
    split.
    - reflexivity.
    - apply moregen_extend; auto.
  Qed.

  Theorem unify_complete : forall constraints subs,
    unifies subs constraints ->
    exists subs', unify constraints = Some subs' /\ moregen subs' subs.
  Proof.
    intros constraints.
    functional induction (unify constraints); intros subs Hunifies;
      try (apply unify_complete_same in Hunifies; auto).

    - exists nil.
      split.
      + auto.
      + exists subs. auto.

    - apply unify_complete_subst; auto.
      inversion Hunifies as [| [t1' t2'] constraints'' Hunifies'].
      intros Hcontra.
      inversion Hcontra.
      auto.

    - inversion Hunifies as [| [t1' t2'] constraints'' Hunifies'].
      exfalso.
      apply Types.unifies_occur with (subs := subs) (x := x) (t := t2); auto.
      destruct t2; inversion y; intros Hcontra; inversion Hcontra.

    - apply unify_complete_subst; auto.

    - inversion Hunifies as [| [t1' t2'] constraints'' Hunifies'].
      exfalso.
      apply Types.unifies_occur with (subs := subs) (x := y) (t := t1); auto.
      destruct t1; inversion y0; intros Hcontra; inversion Hcontra.

    - apply unify_sound_comm in Hunifies.
      apply unify_complete_subst; auto.

    - apply unify_complete_fun in Hunifies.
      auto.

    - destruct constraints as [| [t1 t2] ]; [ | destruct t1; destruct t2 ]; inversion y;
        inversion Hunifies as [| [t1 t2] l Hcontra];
        rewrite Types.subst_list_Fun in Hcontra;
        rewrite Types.subst_list_Base in Hcontra;
        inversion Hcontra.
  Qed.

  Definition unify' : forall constraints,
    { subs | unifies subs constraints } + { ~exists subs, unifies subs constraints }.
  Proof.
    intros constraints.
    remember (unify constraints) as o.
    destruct o as [ subs |].
    - left.
      exists subs.
      apply unify_sound. auto.

    - right.
      intros Hcontra.
      destruct Hcontra as [subs Hcontra].
      apply unify_complete in Hcontra.
      destruct Hcontra as [subs' [Hcontra]].
      congruence.
  Defined.
End Constraint.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import prelude.
Require Import syntax.containers.
Require Import syntax.hit_signature.
Require Import syntax.W_types.
Require Import setoids.base.
Require Import setoids.setoid_category.

Require Import algebra.set_algebra.

Local Open Scope container_scope.
Local Open Scope cat.

Definition dependent_sum_hrel
           (X : hSet)
           (Y : X → setoid)
  : hrel (∑ x : X, Y x).
Proof.
  intros x y.
  use make_hProp.
  - exact (∑ (p : pr1 x = pr1 y), transportf Y p (pr2 x) ≡ pr2 y).
  - abstract
      (use isaproptotal2 ;
       [ intro ; apply isaprop_setoid_eq
       | intros ; apply X ]).
Defined.

Definition dependent_sum_iseqrel
           (X : hSet)
           (Y : X → setoid)
  : iseqrel (dependent_sum_hrel X Y).
Proof.
  repeat split.
  - intros x₁ x₂ x₃ p q.
    induction x₁ as [x₁ y₁].
    induction x₂ as [x₂ y₂].
    induction x₃ as [x₃ y₃].
    induction p as [p₁ p₂].
    induction q as [q₁ q₂].
    simpl in *.
    induction p₁ ; induction q₁.
    cbn in *.
    exact (idpath _ ,, p₂ @ q₂)%setoid.
  - intro x.
    exact (idpath _ ,, id _)%setoid.
  - intros x₁ x₂ p.
    induction x₁ as [x₁ y₁].
    induction x₂ as [x₂ y₂].
    induction p as [p₁ p₂].
    simpl in *.
    induction p₁.
    exact (idpath _ ,, !p₂)%setoid.
Qed.

Definition dependent_sum_eq_rel
           (X : hSet)
           (Y : X → setoid)
  : eqrel (∑ x : X, Y x).
Proof.
  use make_eqrel.
  - exact (dependent_sum_hrel X Y).
  - exact (dependent_sum_iseqrel X Y).
Defined.

Definition dependent_sum_setoid
           (X : hSet)
           (Y : X → setoid)
  : setoid.
Proof.
  use make_setoid.
  - exact (∑ (x : X), Y x)%set.
  - exact (dependent_sum_eq_rel X Y).
Defined.

Definition interpret_container_setoid
           (C : container)
           (X : setoid)
  : setoid
  := dependent_sum_setoid
       (shapes C)
       (λ s, setoid_exp (path_setoid (positions C s)) X).

Notation "⦃ C ⦄ X" := (interpret_container_setoid C X) (at level 70) : container_scope.
(** \{{ and \}} *)

Definition interpret_container_setoid_morphism
           (C : container)
           {X Y : setoid}
           (f : setoid_morphism X Y)
  : setoid_morphism (⦃ C ⦄ X) (⦃ C ⦄ Y).
Proof.
  use make_setoid_morphism.
  - simpl.
    intro x.
    simple refine (pr1 x ,, _).
    use make_setoid_morphism.
    + intro s ; cbn in *.
      exact (f (pr2 x s)).
    + intros y₁ y₂ p ; cbn in *.
      exact (map_eq f (map_eq (pr2 x) p)).
  - simpl.
    intros x₁ x₂ p.
    induction x₁ as [x₁ y₁].
    induction x₂ as [x₂ y₂].
    induction p as [p₁ p₂].
    simpl in *.
    induction p₁.
    cbn in *.
    simple refine (idpath _ ,, _).
    intro x ; cbn.
    exact (map_eq f (p₂ x)).
Defined.

Definition container_to_setoid_functor_data
           (C : container)
  : functor_data setoid_cat setoid_cat.
Proof.
  use make_functor_data.
  - exact (λ X, ⦃ C ⦄ X).
  - exact (λ _ _ f, interpret_container_setoid_morphism C f).
Defined.

Definition container_to_setoid_is_functor
           (C : container)
  : is_functor (container_to_setoid_functor_data C).
Proof.
  split.
  - intro X.
    use setoid_morphism_eq ; cbn.
    intro x ; cbn.
    refine (maponpaths (λ z, pr1 x ,, z) _).
    unfold make_setoid_morphism.
    use subtypePath.
    {
      intro.
      do 3 (use impred ; intro).
      apply isaprop_setoid_eq.
    }
    apply idpath.
  - intros X Y Z f g.
    use setoid_morphism_eq ; cbn.
    intro x ; cbn.
    refine (maponpaths (λ z, pr1 x ,, z) _).
    unfold make_setoid_morphism.
    use subtypePath.
    {
      intro.
      do 3 (use impred ; intro).
      apply isaprop_setoid_eq.
    }
    apply idpath.
Qed.

Definition container_to_setoid_functor
           (C : container)
  : setoid_cat ⟶ setoid_cat.
Proof.
  use make_functor.
  - exact (container_to_setoid_functor_data C).
  - exact (container_to_setoid_is_functor C).
Defined.

(** Relevant builders *)
Definition shape_of_setoid
           {C : container}
           {X : setoid}
           (x : ⦃ C ⦄ X)
  : shapes C
  := pr1 x.

Definition position_of_setoid
           {C : container}
           {X : setoid}
           (x : ⦃ C ⦄ X)
  : positions C (shape_of_setoid x) → X
  := pr12 x.

Definition cpair_setoid
           {C : container}
           {X : setoid}
           (s : shapes C)
           (f : setoid_morphism
                  (path_setoid (positions C s))
                  X)
  : ⦃ C ⦄ X
  := s ,, f.

Definition container_to_setoid
           {C : container}
           {X : setoid}
           (z : ⟦ C ⟧ (pr1 X))
  : ⦃ C ⦄ X.
Proof.
  simple refine (pr1 z ,, _) ; simpl.
  use make_setoid_morphism.
  - exact (pr2 z).
  - abstract
      (simpl ;
       intros ? ? p ;
       induction p ;
       apply (id _)%setoid).
Defined.

Definition sem_endpoint_setoid
           {Σ : hit_signature}
           {X : setoid}
           (c : setoid_morphism (⦃ point_constr Σ ⦄ X) X)
           (i : path_index Σ)
           (var : path_arg Σ i → X)
           (x : W (point_constr Σ) (path_arg Σ i))
  : X
  := sem_endpoint (λ z, pr1 c (container_to_setoid z)) x var.
(*
Proof.
  refine ().
  intro z.
  refine (pr1 c (container_to_setoid z)).
  apply lol.
  exact z.
  simpl in z ; simpl.
  simple refine (_ ,, _).
  - exact (pr1 z).
  - simpl.
    use make_setoid_morphism.
    + exact (pr2 z).
    + abstract
        (simpl ;
         intros ? ? p ;
         induction p ;
         apply (id _)%setoid).
  (*
si      mpl.
  pose (pr1 c).
  cbn in p.
  exact (pr1 c).
  induction x as [ v | s p IHp ].
  - exact (var v).
  - simple refine (c (s ,, _)).
    use make_setoid_morphism ; cbn.
    + exact IHp.
    + intros x y q.
      induction q.
      exact (id _)%setoid.
   *)
Defined.
*)

Definition hit_setoid_prealgebra
           (Σ : hit_signature)
  : category
  := total_category
       (fun_algebra_disp_cat
          (container_to_setoid_functor (point_constr Σ))).

Section Accessors.
  Context {Σ : hit_signature}
          (X : hit_setoid_prealgebra Σ).

  Definition alg_carrier_setoid : setoid
    := pr1 X.

  Definition algebra_map_setoid
    : setoid_morphism
        (⦃ point_constr Σ ⦄ alg_carrier_setoid)
        alg_carrier_setoid
    := pr2 X.
End Accessors.

Definition make_hit_setoid_prealgebra
           {Σ : hit_signature}
           (X : setoid)
           (f : setoid_morphism (⦃ point_constr Σ ⦄ X) X)
  : hit_setoid_prealgebra Σ.
Proof.
  refine (X ,, _) ; cbn.
  exact f.
Defined.

Section AccessorsMor.
  Context {Σ : hit_signature}
          {X Y : hit_setoid_prealgebra Σ}
          (f : X --> Y).

  Definition alg_map_carrier_setoid
    : setoid_morphism
        (alg_carrier_setoid X)
        (alg_carrier_setoid Y)
    := pr1 f.

  Definition alg_map_commute_setoid
             (x : ⦃ point_constr Σ ⦄ (alg_carrier_setoid X))
    : alg_map_carrier_setoid (algebra_map_setoid X x)
      =
      algebra_map_setoid Y (interpret_container_setoid_morphism (point_constr Σ) (pr1 f) x).
  Proof.
    exact (maponpaths (λ h, pr1 h x) (pr2 f)).
  Qed.
End AccessorsMor.

Definition make_hit_setoid_prealgebra_mor
           {Σ : hit_signature}
           {X Y : hit_setoid_prealgebra Σ}
           (f : setoid_morphism (alg_carrier_setoid X) (alg_carrier_setoid Y))
           (p : ∏ (x : ⦃ point_constr Σ ⦄ (alg_carrier_setoid X)),
                f (algebra_map_setoid X x)
                =
                algebra_map_setoid
                  Y
                  (interpret_container_setoid_morphism (point_constr Σ) f x))
  : X --> Y.
Proof.
  simple refine (f ,, _) ; simpl.
  abstract
    (use setoid_morphism_eq ;
     intro x ;
     exact (p x)).
Defined.

Definition is_hit_setoid_algebra
           {Σ : hit_signature}
           (X : hit_setoid_prealgebra Σ)
  : UU
  := ∏ (i : path_index Σ)
       (p : path_arg Σ i → alg_carrier_setoid X),
     sem_endpoint_setoid (algebra_map_setoid X) i p (path_lhs Σ i)
     ≡
     sem_endpoint_setoid (algebra_map_setoid X) i p (path_rhs Σ i).

Definition hit_setoid_algebra_disp_cat
           (Σ : hit_signature)
  : disp_cat (hit_setoid_prealgebra Σ)
  := disp_full_sub _ is_hit_setoid_algebra.

Definition hit_setoid_algebra
           (Σ : hit_signature)
  : category
  := total_category (hit_setoid_algebra_disp_cat Σ).