From Coq Require Import Program.Equality.
From CasperCBC Require Import Lib.SsrExport Lib.Traces.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Core properties of possibly-infinite traces *)

(** The property encodings and many specific properties are adapted from the paper
#A Hoare logic for the coinductive trace-based big-step semantics of While#. *)

Section TraceProperties.

Context {A B : Type}.

Local Notation trace := (@trace A B).

(** We want to reason about trace properties that do not distinguish
bisimilar traces; these are called _setoid_ properties. *)

Definition setoidT (p : trace -> Prop) :=
forall tr0, p tr0 -> forall tr1, bisim tr0 tr1 -> p tr1.

Definition propT := { p : trace -> Prop | setoidT p }.

(** ** Infiniteness property *)

CoInductive infiniteT : trace -> Prop :=
| infiniteT_delay : forall a b tr,
   infiniteT tr ->
   infiniteT (Tcons a b tr).

Lemma infiniteT_setoidT : setoidT infiniteT.
Proof.
cofix CIH.
move => tr0 h0 tr1 h1.
invs h0. invs h1.
exact: (infiniteT_delay a b (CIH _ H _ H4)).
Qed.

Definition InfiniteT : propT :=
exist _ (fun tr => infiniteT tr) infiniteT_setoidT.

Lemma infiniteT_cons : forall a b tr,
 infiniteT (Tcons a b tr) -> infiniteT tr.
Proof.
move => a b tr Hinf.
by inversion Hinf.
Qed.

Lemma infiniteT_trace_append :
 forall tr, infiniteT tr -> forall tr', infiniteT (tr' +++ tr).
Proof.
cofix CIH.
move => tr Htr.
case => [a|a b tr']; first by rewrite trace_append_nil.
rewrite trace_append_cons.
apply infiniteT_delay.
by apply CIH.
Qed.

Lemma trace_append_infiniteT :
 forall tr, infiniteT tr -> forall tr', infiniteT (tr +++ tr').
Proof.
cofix CIH.
case => [a|a b tr0] Hinf; first by inversion Hinf.
inversion Hinf; subst => tr'.
rewrite trace_append_cons.
apply infiniteT_delay.
exact: CIH.
Qed.

(** ** Finiteness property *)

Inductive finiteT : trace -> Prop :=
| finiteT_nil : forall a,
   finiteT (Tnil a)
| finiteT_delay : forall (a : A) (b : B) tr,
   finiteT tr ->
   finiteT (Tcons a b tr).

Lemma finiteT_setoidT : setoidT finiteT.
Proof.
induction 1.
- move => tr0 h0. invs h0. apply finiteT_nil.
- move => tr0 h0. invs h0.
  exact (finiteT_delay a b (IHfiniteT _ H4)).
Qed.

Definition FiniteT : propT :=
exist _ (fun tr => finiteT tr) finiteT_setoidT.

Lemma invert_finiteT_delay (a : A) (b : B) (tr : trace)
 (h : finiteT (Tcons a b tr)) : finiteT tr.
Proof. by inversion h. Defined.

(** Equality coincides with bisimilarity for finite traces. *)

Lemma finiteT_bisim_eq : forall tr,
 finiteT tr -> forall tr', bisim tr tr' -> tr = tr'.
Proof.
move => tr.
elim; first by move => a tr' Hbis; inversion Hbis.
move => a b tr0 Hfin IH tr' Hbis.
invs Hbis.
apply IH in H3.
by rewrite H3.
Qed.

(** Basic connections between finiteness and infiniteness. *)

Lemma finiteT_infiniteT_not : forall tr,
 finiteT tr -> infiniteT tr -> False.
Proof.
move => tr; elim => [a Hinf|a b tr' Hfin]; first by inversion Hinf.
by move => IH Hinf; inversion Hinf.
Qed.

Lemma not_finiteT_infiniteT : forall tr,
 ~ finiteT tr -> infiniteT tr.
Proof.
cofix CIH.
case => [a|a b tr] Hfin; first by case: Hfin; apply finiteT_nil.
apply infiniteT_delay.
apply CIH => Hinf.
case: Hfin.
exact: finiteT_delay.
Qed.

(** ** Final element properties *)

Inductive finalTA : trace -> A -> Prop :=
| finalTA_nil : forall a,
   finalTA (Tnil a) a
| finalTA_delay : forall a b a' tr,
   finalTA tr a' ->
   finalTA (Tcons a b tr) a'.

Inductive finalTB : trace -> B -> Prop :=
| finalTB_nil : forall a b a',
   finalTB (Tcons a b (Tnil a')) b
| finalTB_delay : forall a b b' tr,
   finalTB tr b' ->
   finalTB (Tcons a b tr) b'.

Lemma finalTA_finiteT : forall tr a, finalTA tr a -> finiteT tr.
Proof.
refine (fix IH tr a h {struct h} := _).
case: tr h; first by move => a' Hfin; exact: finiteT_nil.
move => a' b tr Hfin; invs Hfin.
apply finiteT_delay.
exact: (IH _ _ H3).
Qed.

Lemma finalTB_finiteT : forall tr b, finalTB tr b -> finiteT tr.
Proof.
refine (fix IH tr b h {struct h} := _).
case: tr h; first by move => a Hfin; invs Hfin.
move => a b0 tr Hfin; invs Hfin.
- by apply finiteT_delay; apply finiteT_nil.
- by apply finiteT_delay; exact: (IH _ _ H3).
Qed.

Fixpoint finalA (tr : trace) (h : finiteT tr) {struct h} : A :=
match tr as tr' return (finiteT tr' -> A) with
| Tnil a => fun _ => a
| Tcons a b tr => fun h => finalA (invert_finiteT_delay h)
end h.

Lemma finiteT_finalTA : forall tr (h : finiteT tr),
 finalTA tr (finalA h).
Proof.
refine (fix IH tr h {struct h} := _).
case: tr h => [a|a b tr] h.
- by dependent inversion h => /=; apply finalTA_nil.
- by dependent inversion h => /=; apply finalTA_delay; apply IH.
Qed.

Lemma finalTA_hd_append_trace : forall tr0 a,
 finalTA tr0 a -> forall tr1, hd tr1 = a ->
 hd (tr0 +++ tr1) = hd tr0.
Proof.
refine (fix IH tr a h {struct h} := _).
case: tr h => [a0|a0 b tr1] Hfin tr2 Hhd; invs Hfin.
- by rewrite trace_append_nil.
- by rewrite trace_append_cons.
Qed.

(** ** Basic trace properties and connectives *)

Definition ttT : trace -> Prop := fun tr => True.

Lemma ttT_setoidT : setoidT ttT.
Proof. by []. Qed.

Definition TtT : propT :=
exist _ ttT ttT_setoidT.

Definition ffT : trace -> Prop := fun tr => False.

Lemma ffT_setoidT : setoidT ffT.
Proof. by []. Qed.

Definition FfT : propT :=
exist _ ffT ffT_setoidT.

Definition notT (p : trace -> Prop) : trace -> Prop := fun tr => ~ p tr.

Lemma notT_setoidT : forall p, setoidT p -> setoidT (notT p).
Proof.
move => p hp tr h1 tr' h2 h3.
have := hp _ h3 _ (bisim_sym h2).
exact: h1.
Qed.

Definition NotT (p : propT) : propT :=
let: exist f hf := p in
exist _ (notT f) (notT_setoidT hf).

Definition satisfyT (p : propT) : trace -> Prop :=
fun tr => let: exist f0 h0 := p in f0 tr.

Program Definition ExT {T: Type} (p: T -> propT) : propT :=
exist _ (fun tr => exists x, satisfyT (p x) tr) _.
Next Obligation.
move => tr0 [x h0] tr1 h1. exists x. destruct (p x) as [f0 h2].
simpl. simpl in h0. exact: h2 _ h0 _ h1.
Defined.

Lemma andT_setoidT : forall f0 f1,
 setoidT f0 -> setoidT f1 ->
 setoidT (fun tr => f0 tr /\ f1 tr).
Proof.
move => f0 f1 h0 h1 tr0 [h2 h3] tr1 h4. split.
- exact: (h0 _ h2 _ h4).
- exact: (h1 _ h3 _ h4).
Qed.

Definition AndT (p1 p2 : propT) : propT :=
let: exist f0 h0 := p1 in
let: exist f1 h1 := p2 in
exist _ (fun tr => f0 tr /\ f1 tr) (andT_setoidT h0 h1).

Local Infix "andT" := AndT (at level 60, right associativity).

Lemma orT_setoidT : forall f0 f1,
 setoidT f0 -> setoidT f1 ->
 setoidT (fun tr => f0 tr \/ f1 tr).
Proof.
move => f0 f1 h0 h1 tr0 [h2 | h2] tr1 h3.
- left. exact: h0 _ h2 _ h3.
- right. exact: h1 _ h2 _ h3.
Qed.

Definition OrT (p1 p2: propT) : propT :=
let: exist f0 h0 := p1 in
let: exist f1 h1 := p2 in
exist _ (fun tr => f0 tr \/ f1 tr) (orT_setoidT h0 h1).

Local Infix "orT" := OrT (at level 60, right associativity).

Definition propT_imp (p1 p2: propT) : Prop :=
forall tr, satisfyT p1 tr -> satisfyT p2 tr.

Local Infix "=>>" := propT_imp (at level 60, right associativity).

Lemma propT_imp_conseq_L: forall p0 p1 q, p0 =>> p1 -> p1 =>> q -> p0 =>> q.
Proof.
move => p0 p1 q. case: p0 => [p0 hp0].
case: p1 => [p1 hp1]. case: q => [q hq].
move => h0 h1 tr0. simpl. move => h2. apply h1. simpl.
by apply h0.
Qed.

Lemma propT_imp_conseq_R: forall p q0 q1,
 q0 =>> q1 -> p =>> q0 -> p =>> q1.
Proof.
move => p q0 q1. destruct p as [p hp].
destruct q0 as [q0 hq0]. destruct q1 as [q1 hq1].
move => h0 h1 tr0. simpl. move => h2. apply h0. simpl.
by apply h1.
Qed.

Lemma propT_imp_andT: forall p q0 q1,
 p =>> q0 -> p =>> q1 -> p =>> (q0 andT q1).
Proof.
move => [p hp] [q0 hq0] [q1 hq1] h0 h1 tr0 h2.
simpl in h2. simpl. split.
- by apply h0.
- by apply h1.
Qed.

Lemma propT_imp_refl : forall p, p =>> p.
Proof. by move => p tr0 h0. Qed.

Lemma satisfyT_cont : forall p0 p1,
 p0 =>> p1 -> forall tr, satisfyT p0 tr -> satisfyT p1 tr.
Proof.
move => [f0 h0] [f1 h1] h2 tr h3.
simpl. simpl in h3. exact: h2 _ h3.
Qed.

Lemma propT_imp_trans : forall p q r, p =>> q -> q =>> r -> p =>> r.
Proof.
move => p q r h0 h1 tr0 h2.
apply (satisfyT_cont h1).
by apply (satisfyT_cont h0 h2).
Qed.

Lemma OrT_left : forall p1 p2, p1 =>> (p1 orT p2).
Proof.
move => p1 p2 tr h1. simpl. destruct p1 as [f1 hf1].
destruct p2 as [f2 hf2]. simpl. simpl in h1. by left.
Qed.

Lemma OrT_right: forall p1 p2, p2 =>> (p1 orT p2).
Proof.
move => p1 p2 tr h1. simpl. destruct p1 as [f1 hf1].
destruct p2 as [f2 hf2]. simpl. simpl in h1. by right.
Qed.

(** ** Basic trace element properties and connectives *)

Definition propA := A -> Prop.

Definition ttA : propA := fun a => True.

Definition ffA : propA := fun a => False.

Definition propA_imp (u1 u2: propA) : Prop := forall a, u1 a -> u2 a.

Local Infix "->>" := propA_imp (at level 60, right associativity).

Definition andA (u1 u2: propA) : propA := fun a => u1 a /\ u2 a.

Local Infix "andA" := andA (at level 60, right associativity).

Definition exA {T : Type} (u: T -> propA) : propA :=
fun st => exists x, u x st.

(** ** Singleton property *)

Definition singletonT (u : propA) : trace -> Prop :=
fun tr => exists a, u a /\ bisim tr (Tnil a).

Lemma singletonT_setoidT : forall u, setoidT (singletonT u).
Proof.
move => u. move => tr0 h0 tr1 h1. move: h0 => [a [h0 h2]].
invs h2. invs h1. exists a. split => //.
by apply bisim_refl.
Qed.

Lemma singletonT_cont : forall u v, u ->> v ->
 forall tr, singletonT u tr -> singletonT v tr.
Proof.
move => u v huv tr0 h0. move: h0 => [a [h0 h1]]. invs h1.
exists a. split; [ have := huv _ h0; apply | apply bisim_refl].
Qed.

Lemma singletonT_nil: forall u a, singletonT u (Tnil a) -> u a.
Proof. move => u st [a [h0 h1]]. by invs h1. Qed.

Lemma nil_singletonT : forall (u : propA) a, u a -> singletonT u (Tnil a).
Proof. move => u st h0. exists st. split; [ done | apply bisim_refl]. Qed.

Definition SingletonT (u: propA) : propT :=
exist _ (singletonT u) (@singletonT_setoidT u).

Local Notation "[| p |]" := (SingletonT p) (at level 80).

Lemma SingletonT_cont: forall u v, u ->> v -> [|u|] =>> [|v|].
Proof.
move => u v h0 tr0 h1. move: h1 => [a [h1 h2]].
invs h2. exists a. split; [ apply (h0 _ h1) | apply bisim_refl].
Qed.

(** ** Duplicate element property *)

Definition dupT (u : propA) (b : B) : trace -> Prop :=
fun tr => exists a, u a /\ bisim tr (Tcons a b (Tnil a)).

Lemma dupT_cont: forall (u0 u1: propA) b,
 u0 ->> u1 -> forall tr, dupT u0 b tr -> dupT u1 b tr.
Proof.
move => u0 u1 b hu tr [a [h0 h1]]. invs h1. invs H1.
exists a. split; last by apply bisim_refl. exact: hu _ h0.
Qed.

Lemma dupT_setoidT : forall u b, setoidT (dupT u b).
Proof.
move => u b tr0 [a [h0 h1]] tr1 h2. invs h1. invs H1. invs h2. invs H3.
exists a; split => //.
exact: bisim_refl.
Qed.

Definition DupT (u : propA) (b : B) : propT :=
exist _ (dupT u b) (@dupT_setoidT u b).

Local Notation "<
>" := (DupT p b) (at level 80).

Lemma DupT_cont: forall u v b, u ->> v -> <> =>> <<v;b>>.
Proof.
move => u v b h0 tr0 /=.
exact: dupT_cont.
Qed.

(** ** Follows property *)

(** The follows property holds for two traces when the first is a
prefix of the second, and [p] holds for the suffix. *)

CoInductive followsT (p : trace -> Prop) : trace -> trace -> Prop :=
| followsT_nil : forall a tr,
   hd tr = a ->
   p tr ->
   followsT p (Tnil a) tr
| followsT_delay: forall a b tr tr',
   followsT p tr tr' ->
   followsT p (Tcons a b tr) (Tcons a b tr').

Lemma followsT_hd: forall p tr0 tr1, followsT p tr0 tr1 -> hd tr0 = hd tr1.
Proof. move => p tr0 tr1 h0. by invs h0. Qed.

Definition followsT_dec : forall p tr0 tr1 (h: followsT p tr0 tr1),
 { tr & { a | tr0 = Tnil a /\ hd tr = a /\ p tr } } +
 { tr & { tr' & { a & { b | tr0 = Tcons a b tr /\ tr1 = Tcons a b tr' /\ followsT p tr tr'} } } }.
Proof.
intros.
destruct tr0.
- left; exists tr1; exists a. by inversion h; subst.
- destruct tr1.
  * left; exists (Tnil a); exists a. by inversion h; subst.
  * right; exists tr0; exists tr1; exists a; exists b; by inversion h; subst.
Defined.

Lemma followsT_setoidT : forall (p : trace -> Prop) (hp: forall tr0, p tr0 -> forall tr1, bisim tr0 tr1 -> p tr1),
 forall tr0 tr1, followsT p tr0 tr1 ->
 forall tr2, bisim tr0 tr2 -> forall tr3, bisim tr1 tr3 ->
 followsT p tr2 tr3.
Proof.
move => p hp.
cofix CIH.
move => tr0 tr1 h0 tr2 h1 tr3 h2. invs h0.
- invs h1. have h0 := bisim_hd h2. symmetry in h0.
  by apply (followsT_nil h0 (hp _ H0 _ h2)).
- invs h2. invs h1.
  exact: (followsT_delay a b (CIH _ _ H _ H5 _ H4)).
Qed.

Lemma followsT_setoidT_L : forall p,
 forall tr0 tr1, followsT p tr0 tr1 ->
 forall tr2, bisim tr0 tr2 ->  followsT p tr2 tr1.
Proof.
move => p. cofix CIH. move =>  tr tr0 h0 tr1 h1. invs h0.
- invs h1. apply followsT_nil. reflexivity. apply H0.
- invs h1. exact: (followsT_delay a b (CIH _ _ H _ H4)).
Qed.

Lemma followsT_setoidT_R : forall (p: trace -> Prop)
 (hp: forall tr0, p tr0 -> forall tr1, bisim tr0 tr1 -> p tr1),
 forall tr tr0, followsT p tr tr0 ->
 forall tr1, bisim tr0 tr1 ->  followsT p tr tr1.
Proof.
move => p hp. cofix CIH.
move => tr tr0 h0 tr1 h1. invs h0.
- apply followsT_nil; first by symmetry; apply (bisim_hd h1).
  exact: (hp _ H0 _ h1).
- invs h1. exact: (followsT_delay a b (CIH _ _  H _ H4)).
Qed.

Lemma followsT_cont : forall (p q : trace -> Prop),
(forall tr, p tr -> q tr) ->
forall tr0 tr1, followsT p tr0 tr1 -> followsT q tr0 tr1.
Proof.
move => p q hpq. cofix CIH. move => tr0 tr1 h0. invs h0.
- apply followsT_nil => //. have := hpq _ H0; by apply.
- have := followsT_delay _ _ (CIH _ _ H). by apply.
Qed.

Lemma followsT_singletonT: forall u tr0 tr1,
 followsT (singletonT u) tr0 tr1 -> bisim tr0 tr1.
Proof.
move => u. cofix CIH. move => tr0 tr1 h0. invs h0.
- move: H0 => [a [h0 h1]]. invs h1. by simpl; apply bisim_refl.
- exact: (bisim_cons a b (CIH _ _ H)).
Qed.

Lemma followsT_singleton_andA_L: forall u0 u1 tr0,
 followsT (singletonT (u0 andA u1)) tr0 tr0 ->
 followsT (singletonT u0) tr0 tr0.
Proof.
move => u0 u1. cofix CIH. case.
- move => a h0. inversion h0. clear H1 H. simpl in H0.
  invs h0.
  move: H3 => [a' [h1 h2]]. invs h2. move: h1 => [h1 h2].
  apply followsT_nil => //. exists a'. split; [done | apply bisim_refl].
- move => a b tr0 h0. invs h0.
  exact: (followsT_delay a b (CIH _ H0)).
Qed.

Lemma followsT_singleton_andA_R: forall u0 u1 tr0,
 followsT (singletonT (u0 andA u1)) tr0 tr0 ->
 followsT (singletonT u1) tr0 tr0.
Proof.
move => u0 u1. cofix CIH. case.
- move => a h0. inversion h0. clear H1 H. simpl in H0.
  invs h0.
  move: H3 => [a' [h1 h2]]. invs h2. move: h1 => [h1 h2].
  apply followsT_nil => //. exists a'. split; [done | apply bisim_refl].
- move => a b tr0 h0. invs h0.
  exact: (followsT_delay a b (CIH _ H0)).
Qed.

Lemma singletonT_andA_followsT: forall u v tr,
 followsT (singletonT u) tr tr -> followsT (singletonT v) tr tr ->
 followsT (singletonT (u andA v)) tr tr.
Proof.
move => u v. cofix CIH. move => tr h0 h1. inversion h0; subst.
- apply followsT_nil => //. exists a. split; last by apply bisim_refl.
  clear H. inversion h1; subst. clear H1.
  have := singletonT_nil H0.
  have := singletonT_nil H2.
  by split.
- subst. invs h0. invs h1.
  exact: (followsT_delay a b (CIH _ H1 H2)).
Qed.

Lemma followsT_ttA : forall tr, followsT (singletonT ttA) tr tr.
Proof.
cofix CIH. case.
- move => a. apply followsT_nil => //. exists a. split => //.
  exact: bisim_refl.
- move => a b tr0. exact: (followsT_delay _ _ (CIH _)).
Qed.

(** ** Append property *)

(** The append property holds for a trace whenever it has
a prefix for which [p1] holds, and [p2] holds for the suffix. *)

Definition appendT (p1 p2: trace -> Prop) : trace -> Prop :=
fun tr => exists tr', p1 tr' /\ followsT p2 tr' tr.

Local Infix "*+*" := appendT (at level 60, right associativity).

Lemma appendT_cont : forall (p0 p1 q0 q1 : trace -> Prop),
 (forall tr, p0 tr -> p1 tr) ->
 (forall tr, q0 tr -> q1 tr) ->
 forall tr, appendT p0 q0 tr -> appendT p1 q1 tr.
Proof.
move => p0 p1 q0 q1 hp hq tr [tr0 [h0 h1]].
exists tr0. split. have := hp _ h0; apply. clear h0.
move: tr0 tr h1. cofix CIH.
move => tr0 tr1 h0. invs h0.
- apply followsT_nil => //. exact: (hq _ H0).
- exact: (followsT_delay a b (CIH _ _ H)).
Qed.

Lemma appendT_cont_L : forall (p0 p1 q: trace -> Prop),
 (forall tr, p0 tr -> p1 tr) ->
 forall tr, (appendT p0 q tr) -> (appendT p1 q tr).
Proof.
move => p0 p1 q hp. move => tr [tr0 [h0 h1]].
exists tr0. split. have := hp _ h0; apply. apply h1.
Qed.

Lemma appendT_cont_R: forall (p q0 q1: trace -> Prop),
(forall tr, q0 tr -> q1 tr) ->
forall tr, (appendT p q0 tr) -> (appendT p q1 tr).
Proof.
move => p q0 q1 hq. have := (@appendT_cont p p _ _ _ hq). apply => //.
Qed.

Lemma appendT_setoidT: forall (p0 p1: trace -> Prop),
 setoidT p1 -> setoidT (appendT p0 p1).
Proof.
move => p0 p1 hp1. move => tr0 h0 tr1 h1.
move: h0 => [tr2 [h0 h2]]. exists tr2. split; first by apply h0.
have := followsT_setoidT_R hp1 h2 h1. apply.
Qed.

Lemma followsT_followsT: forall p q tr0 tr1 tr2, followsT p tr0 tr1 ->
 followsT q tr1 tr2 -> followsT (p *+* q) tr0 tr2.
Proof.
move => p q. cofix CIH. case.
- move => a tr1 tr2 h0 h1. invs h0. have := followsT_hd h1 => h2.
  apply followsT_nil => //. exists tr1. split => //.
- move => a b tr0 tr1 tr2 h0 h1. invs h0. invs h1. apply followsT_delay.
  exact: (CIH _ _ _ H3 H4).
Qed.

Lemma appendT_assoc_L : forall p1 p2 p3 tr,
 (appendT (appendT p1 p2) p3) tr -> appendT p1 (appendT p2 p3) tr.
Proof.
move => p1 p2 p3 tr0 h1. move: h1 => [tr1 [h1 h2]]. move: h1 => [tr2 h1].
move: h1 => [h1 h3]. exists tr2. split; first done. clear h1.
move: tr2 tr0 tr1 h2 h3. cofix CIH. move => tr0 tr1 tr2 h1 h2. invs h2.
- have h2 := followsT_hd h1. symmetry in h2. have := followsT_nil h2.  apply.
  exists tr2. by split.
- invs h1. apply followsT_delay. exact: (CIH _ _ _ H4 H).
Qed.

Lemma appendT_finalTA: forall (p q : trace -> Prop) tr0 tr1,
 p tr0 -> q tr1 -> finalTA tr0 (hd tr1) ->
 (p *+* q) (tr0 +++ tr1).
Proof.
move => p q tr0 tr1 hp hq hfin. exists tr0. split => //.
clear hp. move: tr0 tr1 hq hfin. cofix CIH. case.
- move => a tr0 hq h1. rewrite trace_append_nil. invs h1.
  exact: followsT_nil.
- move => a b tr0 tr1 h0 h1.
  invs h1. rewrite [Tcons a b tr0 +++ tr1]trace_destr /=.
  apply followsT_delay. exact: (CIH _ _ h0 H3).
Qed.

Definition AppendT (p1 p2: propT) : propT :=
let: exist f0 h0 := p1 in
let: exist f1 h1 := p2 in
exist _ (appendT f0 f1) (appendT_setoidT h1).

Local Infix "***" := AppendT (at level 60, right associativity).

Lemma AppendT_assoc_L: forall p1 p2 p3, ((p1 *** p2) *** p3) =>> (p1 *** p2 *** p3).
Proof.
move => p1 p2 p3 tr0 h1. destruct p1 as [f1 hf1]. destruct p2 as [f2 hf2].
destruct p3 as [f3 hf3]. simpl. simpl in h1. have := appendT_assoc_L h1. apply.
Qed.

Lemma AppendT_cont : forall p1 p2 q1 q2, p1 =>> p2 -> q1 =>> q2 -> (p1 *** q1) =>> (p2 *** q2).
Proof.
move => p1 p2 q1 q2 h0 h1. destruct p1 as [p1 hp1]. destruct p2 as [p2 hp2].
destruct q1 as [q1 hq1]. destruct q2 as [q2 hq2].  move => tr0. simpl.
move => h2. have := appendT_cont _ _ h2. apply. apply h0. apply h1.
Qed.

Lemma AppendT_cont_L: forall p1 p2 q, p1 =>> p2 -> (p1 *** q) =>> (p2 *** q).
Proof.
move => p1 p2 q h0. destruct p1 as [p1 hp1]. destruct p2 as [p2 hp2].
destruct q as [q hq]. move => tr0. simpl.
have := appendT_cont_L h0.  apply.
Qed.

Lemma AppendT_cont_R : forall q p1 p2, p1 =>> p2 -> (q *** p1) =>> (q *** p2).
Proof.
move => q p1 p2 h0. destruct p1 as [p1 hp1]. destruct p2 as [p2 hp2].
destruct q as [q hq]. move => tr0. simpl. move => h1.
have := (@appendT_cont q q p1 p2). apply. done. apply h0.
exact h1.
Qed.

Lemma AppendT_ttA: forall p, p =>> (p *** [|ttA|]).
Proof.
move => [f hp] tr0 h0. simpl in h0. simpl. exists tr0.
split => //. clear h0 hp. move: tr0. cofix CIH.
case. move => a. apply followsT_nil => //.
by apply nil_singletonT. move => a b tr0.
exact: (followsT_delay _ _ (CIH _)).
Qed.

Lemma SingletonT_DupT_AppendT_andA_DupT : forall u v b, ([|u|] *** <<v;b>>) =>> <>.
Proof.
move => u v b tr0 [tr1 [h0 h1]]. simpl. destruct h0 as [a [h0 h2]]. invs h2.
invs h1. destruct H1 as [a [h1 h2]]. invs h2. invs H1. simpl in h0. exists a.
split; last by apply bisim_refl. by split.
Qed.

Lemma DupT_andA_AppendT_SingletonT_DupT : forall u v b, <> =>> ([|u|] *** <<v;b>>).
Proof.
move => u v b tr0 [a [[hu hv] h1]]. invs h1. invs H1. exists (Tnil a). split.
- exists a. by split; last apply bisim_refl.
- apply followsT_nil => //. exists a. by split; last apply bisim_refl.
Qed.

Lemma DupT_andA_AppendT_SingletonT : forall u v b, <> =>> <> *** [|v|].
Proof.
move => u v b tr0 [a [[hu hv] h0]]. invs h0. invs H1. exists (Tcons a b (Tnil a)).
split. exists a. by split; last apply bisim_refl. apply followsT_delay.
apply followsT_nil => //. exists a. by split; last apply bisim_refl.
Qed.

Lemma DupT_AppendT_SingletonT_andA_DupT : forall u v b, (<> *** [|v|]) =>> <>.
Proof.
move => u v b tr0 [tr1 [h0 h1]]. destruct h0 as [a [hu h0]]. invs h0. invs H1.
invs h1. invs H3. destruct H1 as [a [hv h0]]. invs h0. simpl in hu. simpl.
exists a. by split; last apply bisim_refl.
Qed.

Lemma AppendT_andA : forall u v, ([|u|] *** [|v|]) =>> [|u andA v|].
Proof.
move => u v tr0 [tr1 [h0 h1]]. destruct h0 as [a [hu h0]]. invs h0.
invs h1. destruct H1 as [a [hv h0]]. invs h0. simpl in hu. exists a.
by split; last apply bisim_refl.
Qed.

Lemma andA_AppendT: forall u v, [|u andA v|] =>> [|u|] *** [|v|].
Proof.
move => u v tr0 [a [[hu hv] h0]]. invs h0. exists (Tnil a).
split. exists a. by split; last apply bisim_refl. apply followsT_nil => //.
exists a. by split; last apply bisim_refl.
Qed.

Lemma SingletonT_AppendT: forall v p, ([|v|] *** p) =>> p.
Proof.
move => v [p hp] tr0. simpl. move => [tr1 [h0 h1]].
destruct h0 as [a [h0 h2]]. invs h2. by invs h1.
Qed.

Lemma ttA_AppendT_implies : forall p, ([|ttA|] *** p) =>> p.
Proof.
move => p.
exact: SingletonT_AppendT.
Qed.

Lemma implies_ttA_AppendT: forall p, p =>> [|ttA|] *** p.
Proof.
move => [p hp] tr0; simpl => htr0. exists (Tnil (hd tr0)). split.
exists (hd tr0). by split; last apply bisim_refl.
apply followsT_nil => //.
Qed.

Lemma appendT_singletonT: forall p (hp: setoidT p) u tr,
 appendT p (singletonT u) tr -> p tr.
Proof.
move => p hp u tr0 h1. move: h1 => [tr1 [h1 h2]].
have h3 := followsT_singletonT h2.
exact: hp _ h1 _ h3.
Qed.

Lemma AppendT_Singleton: forall p v, (p *** [|v|]) =>> p.
Proof.
move => [p hp] v tr0. simpl. by apply appendT_singletonT.
Qed.

Lemma AppendT_ttA_implies : forall p, (p *** [|ttA|]) =>> p.
Proof. move => p. by apply AppendT_Singleton. Qed.

Lemma implies_AppendT_ttA: forall p, p =>> p *** [|ttA|].
Proof. move => [p hp] tr0; simpl => htr0. exists tr0; split; first done.
clear hp htr0. move: tr0. cofix hcoind. case.
- move => a. apply followsT_nil => //. exists a. by split; last apply bisim_refl.
- move => a b tr0. exact: (followsT_delay _ _ (hcoind _)).
Qed.

Lemma TtT_AppendT_idem: (TtT *** TtT) =>> TtT.
Proof. by []. Qed.

Lemma AppendT_FiniteT_idem : (FiniteT *** FiniteT) =>> FiniteT.
Proof.
move => tr0 [tr1 [h0 h1]]. move: tr1 h0 tr0 h1. induction 1.
- move => tr0 h0. invs h0. done.
- move => tr0 h1. invs h1. have h1 := IHh0 _ H3.
  have := finiteT_delay _ _ h1. by apply.
Qed.

Lemma FiniteT_AppendT_idem : FiniteT =>> FiniteT *** FiniteT.
Proof.
move => tr0 h0. simpl. exists (Tnil (hd tr0)). split.
apply finiteT_nil. apply followsT_nil => //.
Qed.

Lemma FiniteT_SingletonT: forall u, (FiniteT *** [|u|]) =>> FiniteT.
Proof.
move => u tr h0. simpl in h0. simpl.
move: h0 => [tr1 [h0 h1]].
have h2 := followsT_singletonT h1 => {h1}.
exact: (finiteT_setoidT h0 h2).
Qed.

Lemma InfiniteT_implies_AppendT : InfiniteT =>> (TtT *** [|ffA|]).
Proof.
move => tr0 [a b tr1] hinfiniteT. simpl. exists (Tcons a b tr1). split => //. clear tr0.
move: a b tr1 hinfiniteT. cofix hcofix.
move => a b tr0 h. apply followsT_delay. inversion h. subst. apply hcofix. apply H.
Qed.

Lemma AppendT_implies_InfiniteT: (TtT *** [|ffA|]) =>> InfiniteT.
Proof.
move => tr0 [tr1 [_ h1]]. simpl. move: tr0 tr1 h1. cofix h0. move => tr0 tr1 h1.
inversion h1; subst; clear h1.
- destruct H0 as [a [h1 h2]]. inversion h1.
- apply infiniteT_delay. apply (h0 _ _ H).
Qed.

(** ** Iteration property *)

CoInductive iterT (p : trace -> Prop) : trace -> Prop :=
| iterT_stop : forall a,
   iterT p (Tnil a)
| iterT_loop : forall tr tr0,
   p tr ->
   followsT (iterT p) tr tr0 ->
   iterT p tr0.

Lemma iterT_setoidT : forall p (hp: setoidT p), setoidT (iterT p).
Proof.
move => p hp. cofix CIH.
have h0 : forall tr, setoidT (followsT (iterT p) tr).
- cofix CIH1. move => tr. move => tr0 h0 tr1 h1. invs h0.
  * apply followsT_nil. symmetry. apply: bisim_hd h1.
    exact: (CIH _ H0 _ h1).
  * invs h1.
    exact: followsT_delay _ _ _ (CIH1 _ _ H _ H4).
- move => tr0 h1 tr1 h2. invs h1.
  * invs h2. exact: iterT_stop.
  * exact: (iterT_loop H (h0 _ _ H0 _ h2)).
Qed.

Lemma iterT_cont: forall (p0 p1 : trace -> Prop),
 (forall tr, p0 tr -> p1 tr) ->
 forall tr, iterT p0 tr -> iterT p1 tr.
Proof.
move => p0 p1 hp. cofix CIH.
have h : forall tr0 tr1, followsT (iterT p0) tr0 tr1 -> followsT (iterT p1) tr0 tr1.
 cofix CIH0. move => tr0 tr1 h0. invs h0.
 - apply followsT_nil => //. exact: (CIH _ H0).
 - exact: (followsT_delay _ _ (CIH0 _ _ H)).
move => tr0 h0. invs h0.
- exact: iterT_stop.
- exact: (iterT_loop (hp _ H)  (h _ _ H0)).
Qed.

Lemma iterT_appendT_dupT: forall (u : propA) p b tr,
 u (hd tr) -> iterT (appendT p (dupT u b)) tr ->
 followsT (singletonT u) tr tr.
Proof.
move => u p b. cofix CIH. move => tr h0 h1. invs h1.
- simpl in h0. apply followsT_nil => //. exists a.
  by split => //; apply bisim_refl.
- move: H => [tr1 [h2 h1]]. clear h2 h0.
  move: tr tr1 tr0 h1 H0. cofix CIH1.
  move => tr0 tr1 tr2 h0 h1. invs h0.
  * move: H0 => [a [h0 h3]]. invs h3. invs H1.
    invs h1. invs H3. exact: (followsT_delay _ _ (CIH _ h0 H1)).
  - invs h1. exact: (followsT_delay _ _ (CIH1 _ _ _ H H4)).
Qed.

Definition IterT (p : propT) : propT :=
let: exist f0 h0 := p in
exist _ (iterT f0) (iterT_setoidT h0).

Lemma IterT_cont : forall p q, p =>> q -> (IterT p) =>> (IterT q).
Proof.
move => p q h0 tr0. destruct p as [p hp]. destruct q as [q hq].
simpl. apply iterT_cont. move => tr1. apply h0.
Qed.

Lemma iterT_split_1: forall p tr, iterT p tr -> (singletonT ttA tr) \/ (appendT p (iterT p) tr).
Proof.
move => p tr h0. invs h0.
- left. exists a. split => //. exact: bisim_refl.
- right. by exists tr0.
Qed.

Lemma IterT_unfold_0: forall p, IterT p =>> ([|ttA|] orT (p *** IterT p)).
Proof.
move => [p hp] tr0 /= => h0.
exact: (iterT_split_1 h0).
Qed.

Lemma iterT_split_2: forall tr p,
 (singletonT ttA tr) \/ (appendT p (iterT p) tr) -> iterT p tr.
Proof.
move => tr p h. invs h.
- move: H => [a [h0 h1]]. invs h1. exact: iterT_stop.
- move: H => [tr0 [h0 h1]]. exact: iterT_loop h0 h1.
Qed.

Lemma IterT_fold_0 : forall p, ([|ttA|] orT (p *** IterT p)) =>> IterT p.
Proof.
move => [p hp] tr0 /=.
exact: iterT_split_2.
Qed.

Lemma iterT_unfold_1 : forall p tr, (iterT p *+* p) tr -> iterT p tr.
Proof.
move => p tr [tr0 [h0 h1]].
move: tr0 tr h0 h1.
cofix CIH. move => tr0 tr1 h0 h1. invs h0.
- invs h1. apply: (iterT_loop H1). clear H1. move: tr1. cofix CIH0.
  case => a; first by apply followsT_nil => //; apply iterT_stop.
  move => b tr0. exact: (followsT_delay _ _ (CIH0 _)).
- apply: (iterT_loop H). clear H. move: tr tr0 tr1 H0 h1.
  cofix CIH0. move => tr0 tr1 tr2 h0 h1. invs h0.
  * rewrite (followsT_hd h1).
    apply followsT_nil => //.
    exact: (CIH _ _ H0 h1).
  * invs h1.
    exact: (followsT_delay _ _ (CIH0 _ _ _ H H4)).
Qed.

Lemma IterT_unfold_1 : forall p, (IterT p *** p) =>> IterT p.
Proof.
move => [p hp] tr h0 /=. simpl in h0.
exact: (iterT_unfold_1 h0).
Qed.

Lemma IterT_unfold_2: forall p, ([|ttA|] orT (IterT p *** p)) =>> IterT p.
Proof.
move => [p hp] tr0 /= h0. invs h0.
- destruct H as [a [_ h0]]. invs h0. exact: iterT_stop.
- exact: (iterT_unfold_1 H).
Qed.

Lemma stop_IterT : forall p, [|ttA|] =>> IterT p.
Proof.
move => [p hp] /= t0 h0. invs h0.
move: H => [_ h0]. invs h0. simpl.
exact: iterT_stop.
Qed.

Lemma IterT_fold_L : forall p, (p *** IterT p) =>> IterT p.
Proof.
move => [p hp] tr0. simpl. move => [tr1 [h0 h1]].
exact: (iterT_loop h0).
Qed.

Lemma iterT_iterT_2 : forall p tr, iterT p tr -> appendT (iterT p) (iterT p) tr.
Proof.
move => p tr0 h0. exists tr0. split => //. clear h0. move: tr0.
cofix CIH. case.
- move => a. apply followsT_nil => //. exact: iterT_stop.
- move => a b tr0. exact: (followsT_delay _ _ (CIH _)).
Qed.

Lemma IterT_IterT_2 : forall p, IterT p =>> (IterT p *** IterT p).
Proof.
move => [p hp] tr0 /=.
exact: iterT_iterT_2.
Qed.

Lemma iterT_iterT : forall p tr, appendT (iterT p) (iterT p) tr -> (iterT p) tr.
Proof.
move => p tr0 [tr1 [h0 h1]]. move: tr1 tr0 h0 h1.
cofix CIH.
move => tr0 tr1 h0. invs h0.
- move => h0. by invs h0.
- move => h0. apply: (iterT_loop H). clear H. move: tr tr0 tr1 H0 h0.
  cofix CIH2. move => tr0 tr1 tr2 h0. invs h0.
  * move => h0. rewrite (followsT_hd h0). apply: followsT_nil => //.
    exact: (CIH _ _ H0 h0).
  - move => h0. invs h0. apply followsT_delay. exact: (CIH2 _ _ _ H H4).
Qed.

Lemma IterT_IterT : forall p, (IterT p *** IterT p) =>> IterT p.
Proof. move => [p hp] tr /=. exact: iterT_iterT. Qed.

Lemma IterT_DupT : forall v b,
 ([|v|] *** (IterT (TtT *** <<v;b>>))) =>> (TtT *** [|v|]).
Proof.
move => v b tr0 [tr1 [h0 h1]]. move: h0 => [a [h0 h2]].
invs h2. invs h1. simpl.
exists tr0. split => //. move: tr0 h0 H1. cofix CIH.
move => tr0 h0 h1. invs h1.
- apply followsT_nil => //. simpl in h0. exists a. split => //.
  exact: bisim_nil.
- clear h0. move: H => [tr1 [_ h1]].
  move: tr1 tr tr0 h1 H0. cofix CIH0.
  move => tr0 tr1 tr2 h0 h1. invs h0.
  * move: H0 => [a [h0 h2]]. invs h2.
    invs H1. invs h1. invs H3.
    exact: (followsT_delay _ _ (CIH _ h0 H1)).
  * invs h1. exact: (followsT_delay _ _ (CIH0 _ _ _ H H4)).
Qed.

(** ** Last property *)

Definition lastA (p : trace -> Prop) : propA :=
fun a => exists tr, p tr /\ finalTA tr a.

Lemma lastA_cont: forall (p q : trace -> Prop),
 (forall tr, p tr -> q tr) ->
 lastA p ->> lastA q.
Proof.
move => p0 p1 hp. move => a [tr [h0 h1]].
exists tr. split. apply: hp _ h0. exact: h1.
Qed.

Definition LastA (p : propT) : propA :=
let: exist f0 h0 := p in lastA f0.

Lemma LastA_cont : forall p q, p =>> q -> LastA p ->> LastA q.
Proof.
destruct p as [f hf]. destruct q as [g hg]. simpl.
move => h0. apply lastA_cont. apply h0.
Qed.

Lemma LastA_SingletonT_fold : forall u, LastA ([|u|]) ->> u.
Proof.
move => u a h0.
destruct h0 as [tr0 [h1 h2]]. destruct h1 as [st1 [h1 h3]].
invs h3. invs h2. exact: h1.
Qed.

Lemma LastA_SingletonT_unfold : forall u, u ->> LastA ([|u|]).
Proof.
move => u a h0. exists (Tnil a). split.
- by exists a; split => //; apply bisim_nil.
- exact: finalTA_nil.
Qed.

Lemma lastA_appendA : forall p q a, lastA (appendT p q) a -> lastA q a.
Proof.
move => p q a [tr0 [h0 h1]].
move: h0 => [tr [h0 h2]]. clear h0.
move: tr0 a h1 tr h2. induction 1.
- move => tr0 h0. invs h0. exists (Tnil a).
  split => //. exact: finalTA_nil.
- move => tr0 h0. invs h0.
  * exists (Tcons a b tr). split => //. exact: finalTA_delay _ h1.
  * exact: IHh1 _ H1.
Qed.

Lemma LastA_AppendA : forall p v, LastA (p *** [|v|]) ->> v.
Proof.
move => [p hp] v. simpl. move => a [tr [[tr' [_ h0]] h1]].
move: tr a h1 tr' h0. induction 1.
- move => tr0 h0. invs h0. move: H0 => [a0 [h0 h1]]. by invs h1.
- move => tr0 h0. invs h0.
  * move: H0 => [a0 [_ h0]]. invs h0.
  * exact: IHh1 _ H1.
Qed.

Lemma LastA_andA : forall p u, ((LastA p) andA u) ->> LastA (p *** [|u|]).
Proof.
move => p u a [h0 h1]. destruct p as [p hp]. simpl in h0. simpl.
destruct h0 as [tr0 [h2 h3]].
exists tr0. split => //. exists tr0. split => //.
clear h2. move: tr0 a h3 h1.
cofix CIH. move => tr0 a h0. invs h0.
- move => h0. apply followsT_nil => //. exists a.
  split => //. exact: bisim_refl.
- move => h0. apply followsT_delay.
  exact: (CIH _ _ H h0).
Qed.

Lemma LastA_IterA : forall v b p,
 LastA ([|v|] *** (IterT (p *** <<v;b>>))) ->> v.
Proof.
move => v b p a h0.
have h1: p =>> TtT by [].
have := LastA_cont (AppendT_cont_R (IterT_cont (AppendT_cont_L h1))) h0. clear h0 h1. move => h0.
have := LastA_cont (@IterT_DupT v b) h0 => {h0}.
exact: LastA_AppendA.
Qed.

Lemma IterT_LastA_DupT : forall v b,
 (<<v;b>> *** (IterT (TtT *** <<v;b>>))) =>> (TtT *** [|v|]).
Proof.
move => v b tr0 [tr1 [h0 h1]].
move: h0 => [a [h0 h2]]. invs h2.
invs H1. invs h1. invs H3. simpl.
exists (Tcons (hd tr') b tr'). split => //.
apply followsT_delay => //. move: tr' h0 H1.
cofix CIH.
move => tr0 h0 h1. invs h1.
- apply followsT_nil => //. simpl in h0. exists a. split => //.
  exact: bisim_nil.
- clear h0. move: H => [tr1 [_ h1]].
  move: tr1 tr tr0 h1 H0. cofix CIH0.
  move => tr0 tr1 tr2 h0 h1. invs h0.
  * move: H0 => [a [h0 h2]]. invs h2.
    invs H1. invs h1. invs H3.
    exact: (followsT_delay _ _ (CIH _ h0 H1)).
  * invs h1. exact: (followsT_delay _ _ (CIH0 _ _ _ H H4)).
Qed.

Lemma LastA_LastA : forall p q,
 (LastA ([|LastA p|] *** q)) ->> (LastA (p *** q)).
Proof.
move => p q a. destruct p as [p hp]. destruct q as [q hq].
simpl. move => [tr1 [h0 h1]]. move: h0 => [tr0 [h0 h2]].
move: h0 => [tr2 [h0 h3]].
invs h3. invs h2. move: h0 => [tr2 [h0 h2]].
exists (tr2 +++ tr1). split.
- exists tr2. split => //. clear h1 h0.
  move: tr2 h2. cofix CIH. case.
  * move => a0 h0. rewrite trace_append_nil.
    apply followsT_nil => //. by invs h0.
  * move => a0 b tr0 h0. invs h0. rewrite trace_append_cons.
    apply followsT_delay. exact: (CIH _ H4).
- clear H1 h0. move h0: (hd tr1) => a0. rewrite h0 in h2.
  move: tr2 a0 h2 tr1 h0 h1. induction 1.
  * move => tr0 h0 h1. by rewrite trace_append_nil.
  * move => tr0 h0 h1. rewrite trace_append_cons.
    apply finalTA_delay.
    exact: (IHh2 _ h0 h1).
Qed.

Lemma SingletonT_andA_AppendT : forall u v,
 (v andA u) ->> LastA ([|v|] *** [|u|]).
Proof.
move => u v a [h0 h1]. exists (Tnil a). split.
- exists (Tnil a). split. exists a. split => //. apply bisim_refl.
  apply followsT_nil => //. exists a. split => //.
  apply bisim_refl.
- exact: finalTA_nil.
Qed.

CoFixpoint lastdup (tr : trace) (b : B) : trace :=
match tr with
| Tnil a => Tcons a b (Tnil a)
| Tcons a b' tr' => Tcons a b' (lastdup tr' b)
end.

Lemma lastdup_hd: forall tr b, hd tr = hd (lastdup tr b).
Proof.
by case => [a b|a b tr b0]; rewrite [lastdup _ _]trace_destr.
Qed.

Lemma followsT_dupT : forall u tr b,
 followsT (singletonT u) tr tr ->
 followsT (dupT u b) tr (lastdup tr b).
Proof.
move => u. cofix COINDHYP. move => tr0 b h0. inversion h0.
- clear H H1 H2 h0. rewrite [lastdup _ _]trace_destr /=.
  move: H0 => [a0 [h0 h1]]. invs h1.
  apply followsT_nil => //. exists a0.
  split => //. exact: bisim_refl.
- clear h0 H0 H. rewrite [lastdup _ _]trace_destr /=.
  exact: (followsT_delay _ _ (COINDHYP _ _ H1)).
Qed.

Lemma finalTA_lastdup : forall tr a b,
 finalTA tr a -> finalTA (lastdup tr b) a.
Proof.
induction 1.
- rewrite [lastdup _ _]trace_destr /=.
  apply finalTA_delay. exact: finalTA_nil.
- rewrite [lastdup _ _]trace_destr /=.
  exact: finalTA_delay.
Qed.

Lemma LastA_DupT : forall p u b,
 LastA (p *** [|u|]) ->> LastA (p *** <>).
Proof.
move => [p hp] u b a [tr0 [h0 h1]] . move: h0 => [tr1 [h0 h2]].
exists (lastdup tr0 b). split.
- have h3 := followsT_singletonT h2.
  have h4 := followsT_setoidT (@singletonT_setoidT _) h2 h3 (bisim_refl _) => {h2}.
  exists tr0. split. have := hp _ h0 _ h3. done.
  have := followsT_dupT b h4. done.
- exact: (finalTA_lastdup b h1).
Qed.

(** ** Midpoint property *)

(** This property identifies a trace that is both a suffix of [tr0] and a prefix of [tr1],
and is the stepping stone to showing the right associativity of the append property. *)

CoInductive midpointT (p0 p1: trace -> Prop) (tr0 tr1: trace) (h: followsT (appendT p0 p1) tr0 tr1) : trace -> Prop :=
| midpointT_nil : forall tr,
   tr0 = Tnil (hd tr1) ->
   p0 tr ->
   followsT p1 tr tr1 ->
   midpointT h tr
| midpointT_delay : forall tr2 tr3 (h1: followsT (appendT p0 p1) tr2 tr3) (a : A) (b: B) tr',
   tr0 = Tcons a b tr2 ->
   tr1 = Tcons a b tr3 ->
   @midpointT p0 p1 tr2 tr3 h1 tr' ->
   midpointT h (Tcons a b tr').

Lemma midpointT_before: forall p0 p1 tr0 tr1 (h: followsT (appendT p0 p1) tr0 tr1) tr',
 midpointT h tr' -> followsT p0 tr0 tr'.
Proof.
cofix COINDHYP. dependent inversion h. move => {tr H0}.
- move: tr1 a tr0 h e a0 H. case.
  * move => a a0 tr0 h1 h2 h3 h4. simpl in h2.
    move => tr' hm.
    invs hm; last by inversion H.
    destruct h3. destruct H2. inversion h1.
    subst. apply followsT_nil; last by [].
    by inversion H1.
  * move => a b tr0 a0 tr1 h1 h2 h3 h4. simpl in h2.
    move => tr' hm.
    invs hm; last by inversion H.
    destruct h3. destruct H2. inversion h1.
    subst. apply followsT_nil; last by []. by inversion H1.
- subst.
  move => tr0 hm.
  destruct tr0; first by inversion hm.
  invs hm; subst; first by inversion H.
  invs H2; subst.
  invs H3; subst.
  apply followsT_delay.
  exact: (COINDHYP _ _ _ _ h1).
Qed.

Lemma midpointT_after: forall p0 p1 tr0 tr1 (h: followsT (appendT p0 p1) tr0 tr1) tr',
 midpointT h tr' -> followsT p1 tr' tr1.
Proof.
cofix COINDHYP. dependent inversion h. move => {tr H0}.
- move: tr1 a tr0 h e a0 H. case.
  * move => a a0 tr0 h1 h2 h3 h4. simpl in h2. move => tr' hm.
    invs hm; last by inversion H. destruct tr'; last by inversion H. destruct h3. destruct H2. inversion H3. subst.
    apply followsT_nil; last by []. by inversion H1.
  * move => a b tr0 a0 tr1 h1 h2 h3 h4. simpl in h2.
    move => tr' hm. by invs hm; last by inversion H.
- subst.
  move => tr0 hm.
  destruct tr0; first by inversion hm.
  invs hm; subst; first by inversion H.
  invs H2; subst.
  invs H3; subst.
  apply followsT_delay.
  exact: (COINDHYP _ _ _ _ h1).
Qed.

End TraceProperties.

(** ** Trace property operators and notations *)

Infix "andT" := AndT (at level 60, right associativity).
Infix "orT" := OrT (at level 60, right associativity).
Infix "=>>" := propT_imp (at level 60, right associativity).
Infix "->>" := propA_imp (at level 60, right associativity).
Infix "andA" := andA (at level 60, right associativity).
Notation "[| p |]" := (@SingletonT _ _ p) (at level 80).
Infix "*+*" := appendT (at level 60, right associativity).
Infix "***" := AppendT (at level 60, right associativity).
Notation "<
>" := (@DupT _ _ p b) (at level 80).


(* Andrew W. Appel and Stephen Yi-Hsien Lin,
    May 2013, October 2013, March 2014 *)

Require Recdef.
Require Import Integers.
Add LoadPath "~/Desktop/Code/research/vst/compcert/lib".
Require Import Coqlib.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import List.

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

Transparent Int.repr.

Check skipn.
Print skipn.
Eval compute in skipn 2 [1, 2, 3, 4].

Lemma skipn_length:
  forall {A} n (al: list A),
    (length al >= n)%nat ->
    (length (skipn n al) = length al - n)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 apply IHn; omega.
Qed.

Lemma skipn_length_short:
  forall {A} n (al: list A),
    (length al < n)%nat ->
    (length (skipn n al) = 0)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 omega.
 apply IHn. omega.
Qed.

(* PREPROCESSING: CONVERTING STRINGS TO PADDED MESSAGE BLOCKS *)

Print string.
Print Z.of_N.

(*converting a string to a list of Z *)
Fixpoint str_to_Z (str : string) : list Z :=
  match str with
    |EmptyString => nil
    |String c s => Z.of_N (N_of_ascii c) :: str_to_Z s
    end.

Eval compute in str_to_Z "abc".

Print Int.repr.
Print Int.shl.

Transparent Int.repr Int.or Int.shl.

Definition Z_to_Int (a b c d : Z) : Int.int :=
  Int.or
    (Int.or (Int.or
               (Int.shl (Int.repr a) (Int.repr 24))
               (Int.shl (Int.repr b) (Int.repr 16))
            )
               (Int.shl (Int.repr c) (Int.repr 8))
    )
    (Int.repr d).

Transparent Z_to_Int.

Eval compute in Int.repr 24.
Eval compute in Int.or (Int.repr 24) (Int.repr 10).
Check Int.shl.
Eval compute in
      Int.or (Int.or (Int.or (Int.shl (Int.repr 0) (Int.repr 24)) (Int.shl (Int.repr 0) (Int.repr 16)))
            (Int.shl (Int.repr 0) (Int.repr 8))) (Int.repr 900).

Print Int.repr.
Print Int.Z_mod_modulus.
Print Int.wordsize. Print Wordsize_32.wordsize.
Print Int.P_mod_two_p.
Print positive.

Goal Int.repr 5 = Z_to_Int 2 0 0 0.
  unfold Z_to_Int.
  unfold Int.repr.
  simpl.
  unfold Int.or.
  simpl.
  unfold Int.repr.
  unfold Int.shl.
  simpl.                        (* this can eval Z_to_Int fine *)
Abort.

Fixpoint Zlist_to_intlist (nl: list Z) : list int :=
  match nl with
  | h1::h2::h3::h4::t => Z_to_Int h1 h2 h3 h4 :: Zlist_to_intlist t
  | _ => nil
  end.

Eval compute in Int.repr (2^24).
Eval compute in Int.intval (Int.repr (2^24)).

Definition generate_and_pad msg :=
  let n := Zlength msg in
   Zlist_to_intlist (msg ++ [128%Z] (* 10000000 *)
                ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0) (* 00...0 *)
           ++ [Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)].
 (* higher, lower order length (total 64-bit integer) *)
(* given n < 2^64 *)
(* spec_sha.v, two_p 64, Definition SHA256_spec *)

Print Int.repr.
SearchAbout Int.repr.
(* Int.unsigned_repr_eq *)
(* proof of difference? *)

(* Theorem diff_lens : forall (m1 m2 : list Z), *)
                      (* Zlength m1 <> Zlength m2 -> *)

Eval compute in generate_and_pad [1].
Check generate_and_pad.

Definition lenint (n : Z) : list int :=
   [Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)]
.

Eval compute in lenint 4.
Eval compute in map Int.unsigned (lenint 4).

Print Int.unsigned.
Print Int.intval.

Print Zpos.
Check Zpos 5.
Print Z.
(* Inductive Z : Set :=  Z0 : Z | Zpos : positive -> Z | Zneg : positive -> Z *)
Print nat_iter.
Check (1%positive).
Print positive.

Transparent Int.repr.

(* ------------- Lemma 2 *)

SearchAbout Zlength.

Lemma zlength_out : forall (l1 : list Z) (l2 : list Z),
                      Zlength (l1 ++ l2) = Zlength l1 + Zlength l2.
Proof.
  intros l1 l2.
  rewrite -> Zlength_correct.
  rewrite -> Zlength_correct.
  rewrite -> Zlength_correct.
  induction l1 as [ | x xs].
  (* l1 = nil *)
    simpl. reflexivity.
  (* l1 = x :: xs *)
    simpl.
    unfold Zlength.
    simpl.
    unfold Zlength in IHxs.
Admitted.                       (* TODO *)

Inductive InWords : list Z -> Prop :=
  | words_nil : InWords []
  | words_word : forall (a b c d : Z) (msg : list Z),
                   InWords msg -> InWords (a :: b :: c :: d :: msg).

Lemma pad_inwords :
  forall (msg : list Z),
    InWords (msg ++ [128]
                 ++ list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0).
Proof.
  intros msg.

Admitted.

Lemma zlength_intlist_zlist' :
  forall (msg1 : list Z) (msg2 : list Z) (pad : list Z),
    Zlength msg1 = Zlength msg2 ->
    Zlength (Zlist_to_intlist (msg1 ++ pad)) =
    Zlength (Zlist_to_intlist (msg2 ++ pad)).
Proof.
  intros msg1 msg2 pad Hlen.
(* length_Zlist_to_intlist, length to Zlength *)
  (* stuck *)

Admitted.

Print two_power_pos.

Goal 2^32 = 2^32.
  simpl.
  compute.

Goal two_p 32 = two_p 32.
  simpl.
  compute.

(* there are problems with Zlength too, especially the tail recursion *)

Lemma zlength_intlist_zlist :
  forall (msg1 : list Z) (msg2 : list Z) (pad : list Z),
    InWords (msg1 ++ pad) -> InWords (msg2 ++ pad) (* messy, fix *) ->
    Zlength msg1 = Zlength msg2 ->
    Zlength (Zlist_to_intlist (msg1 ++ pad)) =
    Zlength (Zlist_to_intlist (msg2 ++ pad)).
Proof.
  intros msg1 msg2 pad Hi1 Hi2 Hlen.
  generalize dependent msg2.
  induction Hi1.
    intros msg2 Hi2 Hlen. induction Hi2.
      reflexivity.
      simpl. unfold Zlength. simpl. admit. (* contradiction *)
    intros msg2 Hi2 Hlen. induction Hi2.
      simpl. unfold Zlength. simpl. admit. (* contra *)
      simpl.
      unfold Zlength. simpl. unfold Zlength in IHHi2. simpl in IHHi2.
(* ? *)

Admitted.

SearchAbout Zlength.
Print Zlength_aux.

Theorem length_equal_pad_length : forall (msg1 : list Z) (msg2 : list Z),
     Zlength msg1  = Zlength msg2 ->
     Zlength (generate_and_pad msg1) = Zlength (generate_and_pad msg2).
Proof.
  intros m1 m2 H.
  unfold generate_and_pad.
  rewrite -> H.

  (* But Zlist_to_intlist is in the way *)
Admitted.

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

(* Lemma 1 *)

Inductive Prefix {X : Type} : list X -> list X -> Prop :=
  | p_nil : forall (l : list X), Prefix [] l
  | p_self : forall (l : list X), Prefix l l
  | p_cons : forall (l1 l2 : list X) (x : X), Prefix l1 l2 -> Prefix (x :: l1) (x :: l2)
  | p_append : forall (l1 l2 : list X) (l3 : list X), Prefix l1 l2 -> Prefix l1 (l2 ++ l3)
  | p_trans : forall (l1 l2 l3 : list X), Prefix l1 l2 -> Prefix l2 l3 -> Prefix l1 l2.
                               (* might want to prove some of these -- too powerful *)

(* computational -- (++) is not a constructor *)

Theorem Zlist_to_intlist_dist : forall (l1 l2 : list Z),
     InWords l1
         -> Zlist_to_intlist (l1 ++ l2) = Zlist_to_intlist l1 ++ Zlist_to_intlist l2.
Proof.
  intros l1 l2 Ewords.
  induction Ewords.
  (* words_nil *)
    reflexivity.
  (* words_word *)
    simpl.
    rewrite -> IHEwords.
    reflexivity.
Qed.

Lemma Zlist_to_intlist_prefix : forall (l1 l2 : list Z),
                                  InWords l1 ->
                                  Prefix (Zlist_to_intlist l1) (Zlist_to_intlist (l1 ++ l2)).
Proof.
  intros l1 l2 Ewords.
  induction Ewords.
  (* words_nil *)
    simpl. apply p_nil.
  (* words_word *)
    simpl. apply p_cons. apply IHEwords.
Qed.

(* This is actually not necessarily true without InWords msg *)
Theorem message_prefix_padded : forall (msg : list Z),
                                  Prefix (Zlist_to_intlist msg) (generate_and_pad msg).
Proof.
  intro msg.
  unfold generate_and_pad.
  apply p_append.
  induction msg as [ | x xs].
  (* msg = [] *)
    apply p_nil.
  (* msg = x :: xs *)
    simpl.

Admitted.

(* TODO add case ltac *)
(* Main lemma proof *)
Theorem message_prefix_padded' : forall (msg : list Z),
              InWords msg -> Prefix (Zlist_to_intlist msg) (generate_and_pad msg).
Proof.
  intros msg Ewords.
  induction Ewords.             (* fix names *)
  (* words_nil *)
    simpl. apply p_nil.
  (* words_word *)
    unfold generate_and_pad.
    simpl.
    apply p_cons.
    apply p_append.
    apply Zlist_to_intlist_prefix.
    apply Ewords.
Qed.

(* TODO: separate generate_and_pad function to generate . pad -- see end of file*)

(* -------------- End of Lemma 1 *)

(*ROUND FUNCTION*)

(*hardcoding the constants, first 32 bits of the fractional parts of the cube roots of the first 64 prime numbers*)
Print Int.repr.
Print Int.int.

Definition K256 := map Int.repr
  [1116352408 , 1899447441, 3049323471, 3921009573,
   961987163   , 1508970993, 2453635748, 2870763221,
   3624381080, 310598401  , 607225278  , 1426881987,
   1925078388, 2162078206, 2614888103, 3248222580,
   3835390401, 4022224774, 264347078  , 604807628,
   770255983  , 1249150122, 1555081692, 1996064986,
   2554220882, 2821834349, 2952996808, 3210313671,
   3336571891, 3584528711, 113926993  , 338241895,
   666307205  , 773529912  , 1294757372, 1396182291,
   1695183700, 1986661051, 2177026350, 2456956037,
   2730485921, 2820302411, 3259730800, 3345764771,
   3516065817, 3600352804, 4094571909, 275423344,
   430227734  , 506948616  , 659060556  , 883997877,
   958139571  , 1322822218, 1537002063, 1747873779,
   1955562222, 2024104815, 2227730452, 2361852424,
   2428436474, 2756734187, 3204031479, 3329325298].

Eval compute in Int.repr 1116352408.

(*functions used for round function*)
Definition Ch (x y z : int) : int :=
  Int.xor (Int.and x y) (Int.and (Int.not x) z).

Definition Maj (x y z : int) : int :=
  Int.xor (Int.xor (Int.and x z) (Int.and y z) ) (Int.and x y).

Definition Rotr b x := Int.ror x (Int.repr b).
Definition Shr b x := Int.shru x (Int.repr b).

Definition Sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 2 x) (Rotr 13 x)) (Rotr 22 x).
Definition Sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 6 x) (Rotr 11 x)) (Rotr 25 x).
Definition sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 7 x) (Rotr 18 x)) (Shr 3 x).
Definition sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 17 x) (Rotr 19 x)) (Shr 10 x).

(* word function *)
Function W (M: Z -> int) (t: Z) {measure Z.to_nat t} : int :=
  if zlt t 16
  then M t
  else  (Int.add (Int.add (sigma_1 (W M (t-2))) (W M (t-7)))
               (Int.add (sigma_0 (W M (t-15))) (W M (t-16)))).
Proof.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
Qed.

(*registers that represent intermediate and final hash values*)
Definition registers := list int.

Fixpoint map2 {A B C: Type} (f: A -> B -> C) (al: list A) (bl: list B) : list C :=
 match al, bl with
  | a::al', b::bl' => f a b :: map2 f al' bl'
  | _, _ => nil
  end.

(*initializing the values of registers, first thirty-two bits of the fractional
    parts of the square roots of the first eight prime numbers*)
Definition init_registers : registers :=
  map Int.repr  [1779033703, 3144134277, 1013904242, 2773480762,
                        1359893119, 2600822924, 528734635, 1541459225].

Definition nthi (il: list int) (t: Z) := nth (Z.to_nat t) il Int.zero.

Definition rnd_function (x : registers) (k : int) (w : int) : registers:=
  match x with
  |  [a, b, c, d, e, f, g, h] =>
     let T1 := Int.add (Int.add (Int.add (Int.add h (Sigma_1 e)) (Ch e f g)) k) w in
     let T2 := Int.add (Sigma_0 a) (Maj a b c) in
       [Int.add T1 T2, a, b, c, Int.add d T1, e, f, g]
  | _ => nil  (* impossible *)
  end.

Function Round  (regs: registers) (M: Z ->int) (t: Z)
        {measure (fun t => Z.to_nat(t+1)) t} : registers :=
 if zlt t 0 then regs
 else rnd_function (Round regs M (t-1)) (nthi K256 t) (W M t).
Proof. intros; apply Z2Nat.inj_lt; omega.
Qed.

Definition hash_block (r: registers) (block: list int) : registers :=
      map2 Int.add r (Round r (nthi block) 63).

Function hash_blocks (r: registers) (msg: list int) {measure length msg} : registers :=
  match msg with
  | nil => r
  | _ => hash_blocks (hash_block r (firstn 16 msg)) (skipn 16 msg)
  end.
Proof. intros.
 destruct (lt_dec (length msg) 16).
 rewrite skipn_length_short. simpl; omega. rewrite <- teq; auto.
 rewrite skipn_length. simpl; omega. rewrite <- teq; omega.
Qed.

Fixpoint intlist_to_Zlist (l: list int) : list Z :=
 match l with
 | nil => nil
 | i::r =>
     Int.unsigned (Shr 24 i) ::
     Int.unsigned (Int.and (Shr 16 i) (Int.repr 255)) ::
     Int.unsigned (Int.and (Shr 8 i) (Int.repr 255)) ::
     Int.unsigned (Int.and i (Int.repr 255)) ::
     intlist_to_Zlist r
 end.

(* ---------- Lemma 1, cont. *)

Eval compute in intlist_to_Zlist [Int.repr 256].
Eval compute in intlist_to_Zlist [Int.repr 512].
Eval compute in intlist_to_Zlist [Int.repr 1024].
Eval compute in intlist_to_Zlist [Int.repr 2048].
Eval compute in intlist_to_Zlist [Int.repr 4096].

(* pasted *)
Definition g_a_p msg :=
  let n := Zlength msg in
   Zlist_to_intlist (msg ++ [128%Z]
                ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0)
           ++ [Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)].

Eval compute in length (g_a_p [1]). (* 16 32 bit ints * 32 = 512 bits = 2 blocks *)
Eval compute in map Int.unsigned (g_a_p [1]). (* 16 32 bit ints * 32 = 512 bits = 2 blocks *)

(* TODO types *)
(* Rewriting g_a_p *)
Definition pad (msg : list Z) : list Z :=
  let n := Zlength msg in
  msg ++ [128%Z]
      ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0
      ++ intlist_to_Zlist ([Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)]).

Definition g_a_p' (msg : list Z) : list int :=
  Zlist_to_intlist (pad msg).

Transparent Int.repr Int.or Int.shl Int.and.

SearchAbout app.                (* app_assoc, app_assoc_reverse *)

Lemma app_left : forall (a b c d : list Z),
   a ++ b ++ c ++ d = (a ++ b ++ c) ++ d.
Proof.
   intros a b c d.
   (* rewrite -> app_assoc.  do later*)
Admitted.

Definition fulllen (len : Z) :=
  len + 1%Z + (- (len + 9) mod 64).

Eval compute in fulllen 1.
Eval compute in fulllen 10.     (* + 8 = 64 *)
Eval compute in fulllen 100.    (* + 8 = 128 *)
Eval compute in fulllen 200.    (* + 8 = 256 *)
(* Zlist to intlist: each Z is a byte; 4 bytes = 32 bit integer *)

(* can prove InWords (intlist_to_Zlist l) probably *)
Lemma Z_int_id : forall (l : list int),
                   l = Zlist_to_intlist (intlist_to_Zlist l).
Proof.
  intros l.
  destruct l as [ | x xs].
  (* case nil *)
    reflexivity.
  (* case cons *)
    (* simpl. *) (* ? *)

Admitted.

Theorem gap_compose_equal : forall (msg : list Z),
                              g_a_p' msg = generate_and_pad msg.
Proof.
  intros msg.
  unfold g_a_p'. unfold pad.
  unfold generate_and_pad.
  (* simpl. *) (* TODO doesn't work *)
  f_equal.

  pose proof pad_inwords as pad_inwords.
  specialize (pad_inwords msg).
  remember (msg ++
                [128] ++
                list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0) as pad_nolen.
  rewrite -> app_left.
  rewrite <- Heqpad_nolen.
  induction pad_inwords.
    (* case none *)
    unfold intlist_to_Zlist.
    simpl.
    inversion Heqpad_nolen.     (* ? *)

(* x : list int

InWords (a ++ b ++ ... ++ c) ->

Zlist_to_intlist (a ++ b ++ ... ++ c ++ intlist_to_Zlist x)
= Zlist_to_intilst (a ++ b ++ ... ++ c) ++ x *)

(* see pad_inwords *)

Admitted.

(* Proof easy with pad definition *)
Theorem prefix : forall (msg : list Z),
                   Prefix msg (pad msg).
Proof.
  intros msg.
  unfold pad.
  apply p_append.
  apply p_self.
Qed.

(* --------- end of Lemma 1, pt 2 *)

Definition SHA_256 (str : list Z) : list Z :=
    intlist_to_Zlist (hash_blocks init_registers (generate_and_pad str)).


(** **** SNU 4190.310, 2016 Spring *)

(** Assignment 09 *)
(** Due: 2016/12/07 23:59 *)

(* Important:
   - Do NOT import other files.

   - You are NOT allowed to use the [admit] tactic.

   - You are ALLOWED to use any tactics including:
     [tauto], [intuition], [firstorder], [omega].

   - Just leave [exact FILL_IN_HERE] for those problems that you fail to prove.
*)

Require Export Coq.Arith.Arith.
Require Export Coq.Arith.EqNat.
Require Export Coq.omega.Omega.
Require Export Coq.Lists.List.
Require Export Coq.Logic.FunctionalExtensionality.
Import ListNotations.
Require Export Maps.
Require Export Imp.

Definition FILL_IN_HERE {T: Type} : T.  Admitted.

Inductive tm : Type :=
  | C : nat -> tm         (* Constant *)
  | P : tm -> tm -> tm.   (* Plus *)

Fixpoint evalF (t : tm) : nat :=
  match t with
  | C n => n
  | P a1 a2 => evalF a1 + evalF a2
  end.

Reserved Notation " t '\\' n " (at level 50, left associativity).

Inductive eval : tm -> nat -> Prop :=
  | E_Const : forall n,
      C n \\ n
  | E_Plus : forall t1 t2 n1 n2,
      t1 \\ n1 ->
      t2 \\ n2 ->
      P t1 t2 \\ (n1 + n2)

  where " t '\\' n " := (eval t n).

Reserved Notation " t '==>' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall n1 t2 t2',
      t2 ==> t2' ->
      P (C n1) t2 ==> P (C n1) t2'

  where " t '==>' t' " := (step t t').

Definition relation (X: Type) := X->X->Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl  : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation " t '==>*' t' " := (multi step t t') (at level 40).

Definition normal_form {X:Type} (R:relation X) (t:X) : Prop :=
  ~ exists t', R t t'.

Definition step_normal_form := normal_form step.

Definition normal_form_of (t t' : tm) :=
  (t ==>* t' /\ step_normal_form t').

Inductive value : tm -> Prop :=
  v_const : forall n, value (C n).

(* ################################################################# *)
(** * Concurrent Imp *)

(** Finally, to show the power of this definitional style, let's
    enrich Imp with a new form of command that runs two subcommands in
    parallel and terminates when both have terminated.  To reflect the
    unpredictability of scheduling, the actions of the subcommands may
    be interleaved in any order, but they share the same memory and
    can communicate by reading and writing the same variables. *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  (* New: *)
  | CPar : com -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' b 'THEN' c1 'ELSE' c2 'FI'" :=
  (CIf b c1 c2) (at level 80, right associativity).
Notation "'PAR' c1 'WITH' c2 'END'" :=
  (CPar c1 c2) (at level 80, right associativity).

Inductive aval : aexp -> Prop :=
  av_num : forall n, aval (ANum n).

Reserved Notation " t '/' st '==>a' t' " (at level 40, st at level 39).

Inductive astep : state -> aexp -> aexp -> Prop :=
  | AS_Id : forall st i,
      AId i / st ==>a ANum (st i)
  | AS_Plus : forall st n1 n2,
      APlus (ANum n1) (ANum n2) / st ==>a ANum (n1 + n2)
  | AS_Plus1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (APlus a1 a2) / st ==>a (APlus a1' a2)
  | AS_Plus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (APlus v1 a2) / st ==>a (APlus v1 a2')
  | AS_Minus : forall st n1 n2,
      (AMinus (ANum n1) (ANum n2)) / st ==>a (ANum (minus n1 n2))
  | AS_Minus1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (AMinus a1 a2) / st ==>a (AMinus a1' a2)
  | AS_Minus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (AMinus v1 a2) / st ==>a (AMinus v1 a2')
  | AS_Mult : forall st n1 n2,
      (AMult (ANum n1) (ANum n2)) / st ==>a (ANum (mult n1 n2))
  | AS_Mult1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (AMult (a1) (a2)) / st ==>a (AMult (a1') (a2))
  | AS_Mult2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (AMult v1 a2) / st ==>a (AMult v1 a2')

    where " t '/' st '==>a' t' " := (astep st t t').

  Reserved Notation " t '/' st '==>b' t' " (at level 40, st at level 39).

  Inductive bstep : state -> bexp -> bexp -> Prop :=
  | BS_Eq : forall st n1 n2,
      (BEq (ANum n1) (ANum n2)) / st ==>b
      (if (beq_nat n1 n2) then BTrue else BFalse)
  | BS_Eq1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (BEq a1 a2) / st ==>b (BEq a1' a2)
  | BS_Eq2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (BEq v1 a2) / st ==>b (BEq v1 a2')
  | BS_LtEq : forall st n1 n2,
      (BLe (ANum n1) (ANum n2)) / st ==>b
               (if (leb n1 n2) then BTrue else BFalse)
  | BS_LtEq1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (BLe a1 a2) / st ==>b (BLe a1' a2)
  | BS_LtEq2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (BLe v1 a2) / st ==>b (BLe v1 (a2'))
  | BS_NotTrue : forall st,
      (BNot BTrue) / st ==>b BFalse
  | BS_NotFalse : forall st,
      (BNot BFalse) / st ==>b BTrue
  | BS_NotStep : forall st b1 b1',
      b1 / st ==>b b1' ->
      (BNot b1) / st ==>b (BNot b1')
  | BS_AndTrueTrue : forall st,
      (BAnd BTrue BTrue) / st ==>b BTrue
  | BS_AndTrueFalse : forall st,
      (BAnd BTrue BFalse) / st ==>b BFalse
  | BS_AndFalse : forall st b2,
      (BAnd BFalse b2) / st ==>b BFalse
  | BS_AndTrueStep : forall st b2 b2',
      b2 / st ==>b b2' ->
      (BAnd BTrue b2) / st ==>b (BAnd BTrue b2')
  | BS_AndStep : forall st b1 b1' b2,
      b1 / st ==>b b1' ->
      (BAnd b1 b2) / st ==>b (BAnd b1' b2)

  where " t '/' st '==>b' t' " := (bstep st t t').

Reserved Notation " t '/' st '==>' t' '/' st' "
                  (at level 40, st at level 39, t' at level 39).

Inductive cstep : (com * state)  -> (com * state) -> Prop :=
    (* Old part *)
  | CS_AssStep : forall st i a a',
      a / st ==>a a' ->
      (i ::= a) / st ==> (i ::= a') / st
  | CS_Ass : forall st i n,
      (i ::= (ANum n)) / st ==> SKIP / (t_update st i n)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st ==> c1' / st' ->
      (c1 ;; c2) / st ==> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st ==> c2 / st
  | CS_IfTrue : forall st c1 c2,
      (IFB BTrue THEN c1 ELSE c2 FI) / st ==> c1 / st
  | CS_IfFalse : forall st c1 c2,
      (IFB BFalse THEN c1 ELSE c2 FI) / st ==> c2 / st
  | CS_IfStep : forall st b b' c1 c2,
      b /st ==>b b' ->
          (IFB b THEN c1 ELSE c2 FI) / st
      ==> (IFB b' THEN c1 ELSE c2 FI) / st
  | CS_While : forall st b c1,
          (WHILE b DO c1 END) / st
      ==> (IFB b THEN (c1;; (WHILE b DO c1 END)) ELSE SKIP FI) / st
    (* New part: *)
  | CS_Par1 : forall st c1 c1' c2 st',
      c1 / st ==> c1' / st' ->
      (PAR c1 WITH c2 END) / st ==> (PAR c1' WITH c2 END) / st'
  | CS_Par2 : forall st c1 c2 c2' st',
      c2 / st ==> c2' / st' ->
      (PAR c1 WITH c2 END) / st ==> (PAR c1 WITH c2' END) / st'
  | CS_ParDone : forall st,
      (PAR SKIP WITH SKIP END) / st ==> SKIP / st
  where " t '/' st '==>' t' '/' st' " := (cstep (t,st) (t',st')).

Definition cmultistep := multi cstep.

Notation " t '/' st '==>*' t' '/' st' " :=
   (multi cstep  (t,st) (t',st'))
   (at level 40, st at level 39, t' at level 39).

(** Among the many interesting properties of this language is the fact
    that the following program can terminate with the variable [X] set
    to any value. *)


Require Import MyTactics.
Require Import DCSyntax.
Require Import DCValues.

(* The syntactic subcategory of values is decidable. *)

Definition if_value_res {A} (t : term) (a1 a2 : A) : A :=
  match t with
  | Lam _ | Empty | Conflict | Const _ => a1
  | _ => a2
  end.

Definition is_value_res (t : term) :=
  if_value_res t True False.

Lemma is_value_res_subset_is_value:
  forall t,
  is_value_res t -> is_value t.
Proof.
  unfold is_value_res, is_value, if_value_res, if_value.
  intros; induction t; eauto.
Qed.

Global Hint Resolve is_value_res_subset_is_value : is_value obvious.

Global Hint Extern 1 (is_value_res _) => (simpl; tauto) : is_value_res obvious.

(* A term either is or is not a value. *)

Lemma value_or_nonvalue:
  forall t,
  is_value_res t \/ ~ is_value_res t.
Proof.
  destruct t; simpl; eauto.
Qed.

(* Simplification rules for [if_value_res]. *)

Lemma if_value_res_value:
  forall A v (a1 a2 : A),
  is_value_res v ->
  if_value_res v a1 a2 = a1.
Proof.
  destruct v; simpl; tauto.
Qed.

Lemma if_value_res_nonvalue:
  forall A t (a1 a2 : A),
  ~ is_value_res t ->
  if_value_res t a1 a2 = a2.
Proof.
  destruct t; simpl; tauto.
Qed.

(* The syntactic subcategory of values is preserved by renamings. *)

Lemma is_value_res_renaming:
  forall v xi,
  is_value_res v ->
  is_value_res v.[ren xi].
Proof.
  destruct v; simpl; eauto.
Qed.

Lemma is_value_res_subst_stable:
  forall v sigma,
  is_value_res v ->
  is_value_res v.[sigma].
Proof.
  destruct v; simpl; eauto; intros; false; eauto.
Qed.

Lemma is_value_res_subst_list_stable:
  forall l sigma,
  List.Forall is_value_res l ->
  List.Forall is_value_res l..[sigma].
Proof.
  induction l; intros; asimpl; inverts_Forall; econstructor; eauto using is_value_res_subst_stable.
Qed.

Lemma is_nonvalue_renaming:
  forall v xi,
  ~ is_value_res v ->
  ~ is_value_res v.[ren xi].
Proof.
  destruct v; simpl; eauto.
Qed.

Global Hint Resolve is_value_res_renaming is_nonvalue_renaming : is_value_res obvious.

Ltac is_value_res :=
  eauto with is_value_res.

(* The tactic [not_a_value] can be used to prove that the current case
   is impossible, because we have a hypothesis of the form [~ is_value_res v],
   where [v] clearly is a value. *)

Ltac not_a_value :=
  solve [ false; is_value_res ].

Ltac if_value_res :=
  repeat first [ rewrite if_value_res_value by is_value_res |
                 rewrite if_value_res_nonvalue by is_value_res ].

(* The tactic [value_or_nonvalue t] creates two cases: either [t] is a value,
   or it isn't. *)

Ltac value_or_nonvalue t :=
  destruct (value_or_nonvalue t);
  if_value_res.

(* The tactic [value_or_app_or_let] creates three cases: either [t] is a value,
   or it is an application, or it is a [let] construct. *)

Ltac value_or_app_or_let t :=
  value_or_nonvalue t; [|
    destruct t as [ ? | ? | t1 t2 | t1 t2 ]; [ not_a_value | not_a_value | |]
      (* In principle, we should not fix the names [t1] and [t2] here,
         as it might cause name clashes. *)
  ].

(* The predicate [is_value_res_subst sigma] holds if every term in the
   codomain of the substitution [sigma] is a value. *)

Definition is_value_res_subst (sigma : var -> term) :=
  forall x, is_value_res (sigma x).

Definition is_not_value_res_subst (sigma : var -> term) :=
  forall x, ~ is_value_res (sigma x).

Lemma is_value_res_subst_is_value_subst sigma :
  is_value_res_subst sigma -> is_value_subst sigma.
Proof.
  unfold is_value_res_subst, is_value_subst.
  is_value.
Qed.

Global Hint Resolve is_value_res_subst_is_value_subst : is_value obvious.

Lemma is_value_res_subst_cons:
  forall v sigma,
  is_value_res v ->
  is_value_res_subst sigma ->
  is_value_res_subst (v .: sigma).
Proof.
  intros. intros [|x]; is_value_res.
Qed.

Lemma is_value_res_subst_renaming:
  forall sigma i,
  is_value_res_subst sigma ->
  is_value_res_subst (sigma >> ren (+i)).
Proof.
  intros. intro x. asimpl. is_value_res.
Qed.

Global Hint Resolve is_value_res_subst_renaming
  : is_value_res obvious.

Lemma values_are_preserved_by_value_substitutions:
  forall v sigma,
  is_value_res v ->
  is_value_res_subst sigma ->
  is_value_res v.[sigma].
Proof.
  destruct v; simpl; intros; eauto with is_value_res.
Qed.

Lemma nonvalues_are_preserved_by_substitutions:
  forall t sigma,
  is_not_value_res_subst sigma ->
  ~ is_value_res t ->
  ~ is_value_res t.[sigma].
Proof.
  destruct t; simpl; try tauto.
  - unfold is_not_value_res_subst.
    eauto.
Qed.

Global Hint Resolve
  is_value_res_subst_cons
  values_are_preserved_by_value_substitutions
  nonvalues_are_preserved_by_substitutions
: is_value_res obvious.


Require Import Coq.Lists.List.
Import ListNotations.

Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Hygiene.
Require Import ContextHygiene.
Require Import System.
Require Import Judgement.

Lemma upper_bound_all_list :
  forall (l : list nat),
    exists n,
      list_rect (fun _ => Prop)
        True
        (fun i _ P => i <= n /\ P)
        l.
Proof.
intros l.
cut (exists n,
       forall m,
         n <= m
         -> list_rect (fun _ => Prop)
              True
              (fun i _ P => i <= m /\ P)
              l).
  {
  intros (n & Hn).
  exists n.
  apply Hn; auto.
  }
induct l.

(* nil *)
{
exists 0.
cbn.
auto.
}

(* cons *)
{
intros i l IH.
destruct IH as (j & Hj).
exists (max i j).
intros n Hn.
cbn.
split.
  {
  so (Nat.le_max_l i j).
  omega.
  }

  {
  apply Hj.
  so (Nat.le_max_r i j).
  omega.
  }
}
Qed.

Lemma upper_bound_all :
  forall (n : nat),
    nat_rect (fun _ => list nat -> Prop)
      (fun l =>
         exists n,
           list_rect (fun _ => Prop)
             True
             (fun i _ P => i <= n /\ P)
             (List.rev l))
      (fun _ P l =>
         forall (i : nat), P (cons i l))
      n
      nil.
Proof.
intro n.
generalize (@nil nat).
induct n.

(* 0 *)
{
intros l.
cbn.
apply upper_bound_all_list.
}

(* S *)
{
intros n IH l.
cbn.
intro i.
apply IH.
}
Qed.

Section object.

Variable object : Type.

Lemma can_hygiene :
  forall (m : @term object),
    exists i, hygiene (fun j => j < i) m.
Proof.
intros m.
pattern m.
apply (term_mut_ind _ _
         (fun a r =>
            exists i, hygiene_row (fun j => j < i) r)); clear m.

(* var *)
{
intros i.
exists (S i).
apply hygiene_var.
omega.
}

(* oper *)
{
intros a th r IH.
destruct IH as (i & Hi).
exists i.
apply hygiene_oper; auto.
}

(* nil *)
{
exists 0.
apply hygiene_nil.
}

(* cons *)
{
intros j a m IH1 r IH2.
destruct IH1 as (i1 & Hi1).
destruct IH2 as (i2 & Hi2).
exists (max i1 i2).  (* higher than necessary, but that's fine *)
apply hygiene_cons.
  {
  eapply hygiene_weaken; eauto.
  intros k Hk.
  so (le_gt_dec j k) as [Hjk | Hkj]; auto.
  right.
  split; auto.
  so (Nat.le_max_l i1 i2).
  omega.
  }

  {
  eapply hygiene_row_weaken; eauto.
  intros k Hk.
  so (Nat.le_max_r i1 i2).
  omega.
  }
}
Qed.

Lemma can_hygiene' :
  forall (m : @term object),
    exists i, forall j, i <= j -> hygiene (fun k => k < j) m.
Proof.
intros m.
so (can_hygiene m) as (i & Hi).
exists i.
intros j Hj.
eapply hygiene_weaken; eauto.
intros k.
omega.
Qed.

Lemma can_hygieneh :
  forall (h : @hyp object),
    exists i, hygieneh (fun j => j < i) h.
Proof.
intros h.
induct h.

{
exists 0.
apply hygieneh_tpl.
}

{
exists 0.
apply hygieneh_tp.
}

{
intros a.
so (can_hygiene a) as (i & Hi).
exists i.
apply hygieneh_tml; auto.
}

{
intros a.
so (can_hygiene a) as (i & Hi).
exists i.
apply hygieneh_tm; auto.
}

{
exists 0.
apply hygieneh_emp.
}
Qed.

Lemma can_hygieneh' :
  forall (h : @hyp object),
    exists i, forall j, i <= j -> hygieneh (fun k => k < j) h.
Proof.
intros h.
so (can_hygieneh h) as (i & Hi).
exists i.
intros j Hj.
eapply hygieneh_weaken; eauto.
intros k.
omega.
Qed.

Lemma can_hygienej :
  forall (J : @judgement object),
    exists i, hygienej (fun j => j < i) J.
Proof.
intros J.
induct J.
intros m n a.
so (can_hygiene m) as (i1 & Hm).
so (can_hygiene n) as (i2 & Hn).
so (can_hygiene a) as (i3 & Ha).
so (upper_bound_all 3 i1 i2 i3) as (i & Hi1 & Hi2 & Hi3 & _).
exists i.
apply hygienej_deq; eapply hygiene_weaken; eauto; intros j Hj; omega.
Qed.

Lemma can_hygienej' :
  forall (J : @judgement object),
    exists i, forall j, i <= j -> hygienej (fun k => k < j) J.
Proof.
intros J.
so (can_hygienej J) as (i & Hi).
exists i.
intros j Hj.
eapply hygienej_weaken; eauto.
intros k.
omega.
Qed.

Fixpoint shut n : @context object :=
  match n with
  | 0 => nil

  | S n' => hyp_tm unittp :: shut n'
  end.

Lemma length_shut :
  forall n, length (shut n) = n.
Proof.
intro n.
induct n; auto; intros; cbn; f_equal; auto.
Qed.

Lemma promote_shut :
  forall n, @promote object (shut n) = shut n.
Proof.
intros n.
induct n; intros; cbn; f_equal; auto.
Qed.

Lemma shut_term :
  forall (G : @context object) (m : @term object),
    exists i,
      forall j,
        i <= j
        -> hygiene (ctxpred (G ++ shut j)) m.
Proof.
intros G m.
so (can_hygiene m) as (i & Hi).
exists i.
intros j Hj.
eapply hygiene_weaken; eauto.
intros k Hk.
rewrite ctxpred_length, app_length, length_shut.
omega.
Qed.

Lemma shut_hyp :
  forall (G : @context object) (h : @hyp object),
    exists i,
      forall j,
        i <= j
        -> hygieneh (ctxpred (G ++ shut j)) h.
Proof.
intros G m.
so (can_hygieneh m) as (i & Hi).
exists i.
intros j Hj.
eapply hygieneh_weaken; eauto.
intros k Hk.
rewrite ctxpred_length, app_length, length_shut.
omega.
Qed.

Lemma shut_judgement :
  forall (G : @context object) (J : @judgement object),
    exists i,
      forall j,
        i <= j
        -> hygienej (ctxpred (G ++ shut j)) J.
Proof.
intros G J.
so (can_hygienej J) as (i & Hi).
exists i.
intros j Hj.
eapply hygienej_weaken; eauto.
intros k Hk.
rewrite ctxpred_length, app_length, length_shut.
omega.
Qed.

End object.

Arguments shut {object}.

Definition pseq (G : scontext) (J : judgement) : Prop :=
  exists i,
    forall j,
      i <= j
      -> seq (G ++ shut j) J.

Definition obj := Candidate.obj Page.stop.

(* Given a goal of the form:

   forall G,
     pseq (G1 ++ G) J1
     -> ...
     -> pseq (Gn ++ G) Jn
     -> pseq G J

   refine (seq_pseq m H1 p1 ... Hm pm n G1 J1 ... Gn Jn J _)

   will produce a subgoal of the form:

   forall G,
     hygiene (ctxpred (Hi ++ G)) pi)
     -> ...
     -> hygiene (ctxpred (Hm ++ G)) pm)
     -> seq (G1 ++ G) J1
     -> ...
     -> seq (Gn ++ G) Jn
     -> seq G J

   Note that one can fill in all the Jis with _, and all the
   Gis with [_, ..., _].
*)
Lemma seq_pseq :
  forall m,
    nat_rect (fun _ => list (scontext * term _) -> Prop)
      (fun T =>
         forall n,
           nat_rect (fun _ => list (scontext * judgement) -> Prop)
             (fun L =>
                forall J,
                  (forall G,
                     list_rect (fun _ => Prop)
                       (list_rect (fun _ => Prop)
                          (seq G J)
                          (fun X _ P =>
                             match X with
                             | pair G' J' => seq (G' ++ G) J' -> P
                             end)
                          (rev L))
                        (fun X _ P =>
                           match X with
                           | pair G' p => hygiene (ctxpred (G' ++ G)) p -> P
                           end)
                        (rev T))
                  ->
                  forall G,
                    list_rect (fun _ => Prop)
                      (pseq G J)
                      (fun X _ P =>
                         match X with
                         | pair G' J' => pseq (G' ++ G) J' -> P
                         end)
                      (rev L))
             (fun _ P L =>
                forall (G : scontext) (J : judgement), P ((G, J) :: L))
             n
             nil)
      (fun _ P T =>
         forall (G : scontext) (p : term obj), P ((G, p) :: T))
      m
      nil.
Proof.
intro m.
set (T := @nil (scontext * term obj)).
clearbody T.
revert T.
induct m.
2:{
  intros m IH T.
  cbn.
  intros G p.
  apply IH.
  }
intros T.
cbn.
set (T' := rev T).
clearbody T'.
renameover T' into T.
intro n.
set (L := nil).
clearbody L.
revert L.
induct n.
2:{
  intros n IH L.
  cbn.
  intros G J.
  apply IH.
  }
intros L.
cbn.
set (L' := rev L).
clearbody L'.
renameover L' into L.
intros J Hseqs G.
set (i := 0).
assert (forall j,
          i <= j
          -> list_rect (fun _ => Prop)
               (list_rect (fun _ => Prop)
                  (seq (G ++ shut j) J)
                  (fun X _ P =>
                     match X with
                     | pair G' J' => seq (G' ++ G ++ shut j) J' -> P
                     end)
                  L)
                (fun X _ P =>
                   match X with
                   | pair G' p => hygiene (ctxpred (G' ++ G ++ shut j)) p -> P
                   end)
                T).
  {
  intros j Hj.
  cbn in Hseqs.
  exact (Hseqs (G ++ shut j)).
  }
clear Hseqs.
clearbody i.
revert i H.
induct T.

(* nil *)
{
intros i1 Hseq.
cbn in Hseq.
revert i1 Hseq.
induct L.
  (* nil *)
  {
  cbn.
  intros i Hseq.
  exists i.
  intros j Hj.
  apply Hseq; auto.
  }

  (* cons *)
  {
  intros (G', J') L IH i Hseqs.
  cbn.
  intros (j & Hseq).
  apply (IH (max i j)).
  intros k Hk.
  exploit (Hseqs k) as H.
    {
    so (Nat.le_max_l i j).
    omega.
    }
  cbn in H.
  apply H.
  rewrite -> app_assoc.
  apply Hseq.
  so (Nat.le_max_r i j).
  omega.
  }
}

(* cons *)
{
intros (G', p) T IH i Hseqs.
so (shut_term _ (G' ++ G) p) as (j & Hclp).
apply (IH (max i j)).
intros k Hk.
exploit (Hseqs k) as H.
  {
  so (Nat.le_max_l i j).
  omega.
  }
cbn in H.
apply H.
rewrite -> app_assoc.
apply Hclp.
so (Nat.le_max_r i j).
omega.
}
Qed.

(* Given a goal of the form:

   forall G,
     pseq (G1a ++ G1b ++ G) J1
     -> ...
     -> pseq (Gna ++ Gnb ++ G) Jn
     -> pseq (Ga ++ Gb ++ G) J

   refine (seq_pseq_hyp m H1 p1 ... Hm pm n G1a G1b J1 ... Gna Gnb Jn Ga Gb J _)

   will produce a subgoal of the form:

   forall G,
     hygiene (ctxpred (Hi ++ G) pi)
     -> ...
     -> hygiene (ctxpred (Hm ++ G) pm)
     -> seq (G1a ++ G1b ++ G) J1
     -> ...
     -> seq (Gna ++ Gnb ++ G) Jn
     -> hygienej (ctxpred (Ga ++ Gb ++ G)) J
     -> seq (Ga ++ Gb ++ G) J

   Note that one can fill in all the Jis with _, and all the
   Gias and Gibs with [_; ...; _].
*)
Lemma seq_pseq_hyp :
  forall m,
    nat_rect (fun _ => list (scontext * term _) -> Prop)
      (fun T =>
         forall n,
           nat_rect (fun _ => list (scontext * scontext * judgement) -> Prop)
             (fun L =>
                forall G1 G2 J,
                  (forall G,
                     list_rect (fun _ => Prop)
                       (list_rect (fun _ => Prop)
                          (hygienej (ctxpred (G1 ++ G2 ++ G)) J -> seq (G1 ++ G2 ++ G) J)
                          (fun X _ P =>
                             match X with
                             | pair (pair G1' G2') J' => seq (G1' ++ G2' ++ G) J' -> P
                             end)
                          (rev L))
                       (fun X _ P =>
                          match X with
                          | pair G' p => hygiene (ctxpred (G' ++ G)) p -> P
                          end)
                       (rev T))
                  ->
                  forall G,
                    list_rect (fun _ => Prop)
                      (pseq (G1 ++ G2 ++ G) J)
                      (fun X _ P =>
                         match X with
                         | pair (pair G1' G2') J' => pseq (G1' ++ G2' ++ G) J' -> P
                         end)
                      (rev L))
             (fun _ P L =>
                forall (G1 G2 : scontext) (J : judgement), P (((G1, G2), J) :: L))
             n
             nil)
      (fun _ P T =>
         forall (G : scontext) (p : term obj), P ((G, p) :: T))
      m
      nil.
Proof.
intro m.
set (T := @nil (scontext * term obj)).
clearbody T.
revert T.
induct m.
2:{
  intros m IH T.
  cbn.
  intros G p.
  apply IH.
  }
intros T.
cbn.
set (T' := rev T).
clearbody T'.
renameover T' into T.
intro n.
set (L := nil).
clearbody L.
revert L.
induct n.
2:{
  intros n IH L.
  cbn.
  intros G1 G2 J.
  apply IH.
  }
intros L.
cbn.
set (L' := rev L).
clearbody L'.
renameover L' into L.
intros G1 G2 J Hseqs G.
set (i := 0).
assert (forall j,
          i <= j
          -> list_rect (fun _ => Prop)
               (list_rect (fun _ => Prop)
                  (hygienej (ctxpred (G1 ++ G2 ++ G ++ shut j)) J -> seq (G1 ++ G2 ++ G ++ shut j) J)
                  (fun X _ P =>
                     match X with
                     | pair (pair G1' G2') J' => seq (G1' ++ G2' ++ G ++ shut j) J' -> P
                     end)
                  L)
                (fun X _ P =>
                   match X with
                   | pair G' p => hygiene (ctxpred (G' ++ G ++ shut j)) p -> P
                   end)
                T) as H.
  {
  intros j Hj.
  exact (Hseqs (G ++ shut j)).
  }
clear Hseqs.
clearbody i.
revert i H.
induct T.

(* nil *)
{
intros i1 Hseq.
cbn in Hseq.
revert i1 Hseq.
induct L.
  (* nil *)
  {
  cbn.
  intros i1 Hseq.
  so (shut_judgement _ (G1 ++ G2 ++ G) J) as (i2 & HclJ).
  so (upper_bound_all 2 i1 i2) as (i & Hi1 & Hi2 & _).
  exists i.
  intros j Hj.
  rewrite <- !app_assoc.
  apply Hseq; eauto using le_trans.
  lapply (HclJ j); [| omega].
  intro H.
  autorewrite with canonlist in H.
  exact H.
  }

  (* cons *)
  {
  intros ((G1', G2'), J') L IH i Hseqs.
  cbn.
  intros (j & Hseq).
  apply (IH (max i j)).
  intros k Hk.
  exploit (Hseqs k) as H.
    {
    so (Nat.le_max_l i j).
    omega.
    }
  cbn in H.
  apply H.
  setoid_rewrite -> app_assoc.
  setoid_rewrite -> app_assoc.
  setoid_rewrite <- app_assoc at 2.
  apply Hseq.
  so (Nat.le_max_r i j).
  omega.
  }
}

(* cons *)
{
intros (G', p) T IH i Hseqs.
so (shut_term _ (G' ++ G) p) as (j & Hclp).
apply (IH (max i j)).
intros k Hk.
exploit (Hseqs k) as H.
  {
  so (Nat.le_max_l i j).
  omega.
  }
cbn in H.
apply H.
rewrite -> app_assoc.
apply Hclp.
so (Nat.le_max_r i j).
omega.
}
Qed.

(* Given a goal of the form:

   forall G,
     pseq (G1 ++ if b1 then promote G else G) J1
     -> ...
     -> pseq (Gn ++ if bn then promote G else G) Jn
     -> pseq G J

   refine (seq_pseq_promote m H1 p1 ... Hm pm n b1 G1 J1 ... bn Gn Jn J _)

   will produce a subgoal of the form:

   forall G,
     hygiene (ctxpred (Hi ++ G) pi)
     -> ...
     -> hygiene (ctxpred (Hm ++ G) pm)
     -> seq (G1 ++ if b1 then promote G else G) J1
     -> ...
     -> seq (Gn ++ if bn then promote G else G) Jn
     -> seq G J

   Note that one can fill in all the Jis with _, and all the
   Gis with [_, ..., _].
*)
Lemma seq_pseq_promote :
  forall m,
    nat_rect (fun _ => list (scontext * term _) -> Prop)
      (fun T =>
         forall n,
           nat_rect (fun _ => list (bool * scontext * judgement) -> Prop)
             (fun L =>
                forall J,
                  (forall G,
                     list_rect (fun _ => Prop)
                       (list_rect (fun _ => Prop)
                          (seq G J)
                          (fun X _ P =>
                             match X with
                             | pair (pair b G') J' => seq (G' ++ match b with true => promote G | false => G end) J' -> P
                             end)
                          (rev L))
                        (fun X _ P =>
                           match X with
                           | pair G' p => hygiene (ctxpred (G' ++ G)) p -> P
                           end)
                        (rev T))
                  ->
                  forall G,
                    list_rect (fun _ => Prop)
                      (pseq G J)
                      (fun X _ P =>
                         match X with
                         | pair (pair b G') J' => pseq (G' ++ match b with true => promote G | false => G end) J' -> P
                         end)
                      (rev L))
             (fun _ P L =>
                forall (b : bool) (G : scontext) (J : judgement), P ((b, G, J) :: L))
             n
             nil)
      (fun _ P T =>
         forall (G : scontext) (p : term obj), P ((G, p) :: T))
      m
      nil.
Proof.
intro m.
set (T := @nil (scontext * term obj)).
clearbody T.
revert T.
induct m.
2:{
  intros m IH T.
  cbn.
  intros G p.
  apply IH.
  }
intros T.
cbn.
set (T' := rev T).
clearbody T'.
renameover T' into T.
intro n.
set (L := nil).
clearbody L.
revert L.
induct n.
2:{
  intros n IH L.
  cbn.
  intros b G J.
  apply IH.
  }
intros L.
cbn.
set (L' := rev L).
clearbody L'.
renameover L' into L.
cbn.
intros J Hseqs G.
set (i := 0).
assert (forall j,
          i <= j
          -> list_rect (fun _ => Prop)
               (list_rect (fun _ => Prop)
                  (seq (G ++ shut j) J)
                  (fun X _ P =>
                     match X with
                     | pair (pair b G') J' => seq (G' ++ match b with true => promote (G ++ shut j) | false => G ++ shut j end) J' -> P
                     end)
                  L)
               (fun X _ P =>
                  match X with
                  | pair G' p => hygiene (ctxpred (G' ++ G ++ shut j)) p -> P
                  end)
               T) as H.
  {
  intros j Hj.
  cbn in Hseqs.
  exact (Hseqs (G ++ shut j)).
  }
clear Hseqs.
clearbody i.
revert i H.
induct T.

(* nil *)
{
intros i1 Hseq.
cbn in Hseq.
revert i1 Hseq.
induct L.
  (* nil *)
  {
  cbn.
  intros i Hseq.
  exists i.
  intros j Hj.
  apply Hseq; auto.
  }

  (* cons *)
  {
  intros ((b, G'), J') L IH i Hseqs.
  cbn.
  intros (j & Hseq).
  apply (IH (max i j)).
  intros k Hk.
  exploit (Hseqs k) as H.
    {
    so (Nat.le_max_l i j).
    omega.
    }
  cbn in H.
  apply H.
  destruct b.
    {
    rewrite -> promote_append.
    rewrite -> promote_shut.
    rewrite -> app_assoc.
    apply Hseq.
    so (Nat.le_max_r i j).
    omega.
    }

    {
    rewrite -> app_assoc.
    apply Hseq.
    so (Nat.le_max_r i j).
    omega.
    }
  }
}

(* cons *)
{
intros (G', p) T IH i Hseqs.
so (shut_term _ (G' ++ G) p) as (j & Hclp).
apply (IH (max i j)).
intros k Hk.
exploit (Hseqs k) as H.
  {
  so (Nat.le_max_l i j).
  omega.
  }
cbn in H.
apply H.
rewrite -> app_assoc.
apply Hclp.
so (Nat.le_max_r i j).
omega.
}
Qed.

Ltac finish_pseq j :=
eauto using le_trans;
match goal with
| H : forall (x : nat), _ <= x  -> _ |- _ =>
  let H' := fresh
  in
    lapply (H j); [| eauto using le_trans];
    intro H';
    autorewrite with canonlist in H';
    exact H'
end.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Bool.
Require Export Ring_theory.
Require Export Ring_base.
Require Export InitialRing.
Require Export Ring_tac.

Lemma BoolTheory :
  ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)).
split; simpl.
destruct x; reflexivity.
destruct x; destruct y; reflexivity.
destruct x; destruct y; destruct z; reflexivity.
reflexivity.
destruct x; destruct y; reflexivity.
destruct x; destruct y; reflexivity.
destruct x; destruct y; destruct z; reflexivity.
reflexivity.
destruct x; reflexivity.
Qed.

Definition bool_eq (b1 b2:bool) :=
  if b1 then b2 else negb b2.

Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2.
destruct b1; destruct b2; auto.
Qed.

Ltac bool_cst t :=
  let t := eval hnf in t in
  match t with
    true => constr:(true)
  | false => constr:(false)
  | _ => constr:(NotConstant)
  end.

Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).