Import Require Min.

Require Import msl.msl_standard.
Require Import Maps.
Require Import FuncListMachine.
Require Import lemmas.

Open Scope pred.

Program Definition getsn (n:nat) (stk stk':stack) (Q:pred world) : pred world :=
  fun pr => let (p,r) := pr in
    level p >= n -> exists n', n' < n /\
      exists p', exists r', stepN n' p p' r stk r' stk' /\
        Q (p',r').
Next Obligation.
  hnf. simpl; intros.
  destruct a. destruct a'.
  intro.
  cut (S (level p0) = level p).
  intro. rewrite <- H2 in H0 .
  spec H0. omega.
  destruct H0 as [n' [? ?]].
  exists n'. split; auto.
admit.
admit.
Qed.

Program Definition haltsn (n : nat) (stk : stack) : pred world :=
  fun pr => let (p,r) := pr in
    (level p >= n -> eventually_halts_n n p r stk).
Next Obligation.
  unfold hereditary; intros.
  destruct a as [p r'].
  destruct a' as [p' r''].
  intros.
  unfold prog in *.
  spec H0.
  apply age_level in H; simpl in H; omega.
  hnf in H.
  simpl in H.
  unfold prog_lookup, prog in *.
  remember (age1 p).
  icase o.
  rewrite K.knot_age1 in Heqo.
  remember (K.unsquash p).
  destruct p0.
  icase n0.
  inv H.
  inv Heqo.
  destruct H0 as [px [rx [? ?]]].
  repeat rewrite K.knot_level in *.
  rewrite <- Heqp0 in H.
  rewrite K.unsquash_squash in H1.
  remember (K.unsquash px).
  destruct p0.
  simpl in *.
  destruct n1.
  omegac.
  exists (K.squash (n1, f0)).
  exists rx.
  split.
  repeat rewrite K.knot_level in *.
  repeat rewrite K.unsquash_squash.
  trivial.
  generalize (stepstar_approxprog 1 _ _ (K.squash (n0,f)) (K.squash (n1, f0)) _ _ stk _ _ H0); intro.
  spec H2.
  exists (K.squash (n0,f)). split; try reflexivity.
  hnf. rewrite K.knot_age1.
  rewrite <- Heqp0. trivial.
  spec H2.
  exists (K.squash (n1,f0)). split; try reflexivity.
  hnf. rewrite K.knot_age1.
  rewrite <- Heqp1. trivial.
  spec H2. apply stack_approx_rel_refl.
  destruct H2 as [s2' [? ?]].
  inversion H3. subst s2'.
  trivial.
Qed.

Definition guardsn (n : nat) (P : pred world) (stk : stack) : pred world :=
  P --> haltsn n stk.

Definition termMeas :=
  { R : store -> nat -> Prop |
    forall x y y', R x y -> R x y' -> y = y' }.

Program Definition code (l : label) (c : instruction) : pred prog :=
  fun p =>
    exists i, prog_lookup p l = Some i /\ instr_approx_rel (level p) c i.
Next Obligation.
  unfold hereditary; intros.
  hnf in H.
  unfold prog_lookup, prog in *.
  destruct H0 as [i [? ?]].
  exists (fmap_instr (K.approx (level a')) c).
  split.
  2: red; symmetry; apply collapse_instr_approx_same.
  rewrite K.knot_age1 in H.
  remember (K.unsquash a).
  destruct p.
  icase n.
  inv H.
  rewrite K.knot_level in *.
  rewrite <- Heqp in H1.
  rewrite K.unsquash_squash.
  simpl in *.
  unfold KnotInput.fmap.
  erewrite fmap_eqn.
  2: apply H0.
  red in H1.
  replace n with (min n (S n)) by (apply min_l; auto with arith).
  do 2 rewrite <- collapse_instr_approx.
  rewrite H1.
  trivial.
Qed.

Program Definition evalTM (t : termMeas) (n : nat) : pred world :=
  fun w => let (_, r) := w in
    proj1_sig t r n.
Next Obligation.
  unfold hereditary; intros.
  destruct a. destruct a'.
  hnf in H. simpl in H. unfold prog in *.
  icase (age1 p).
  inv H. trivial.
Qed.

Program Definition embedWP (P : pred world) : pred prog :=
  fun p => forall r, P (p,r).
Next Obligation.
  unfold hereditary; intros.
  rewrite <- (nec_useless P) in H0.
  apply (H0 r (a',r)).
  simpl. rewrite worldNec_unfold. intuition.
Qed.

(* Definition of the hoare relation and rules *)

Definition hoare' (n':nat) (G:pred prog) (R P:pred world) (c:instruction) (Q:pred world) :=
  forall p n k stk,
    G p ->
    (forall r', guardsn n R stk       (p,r')) ->
    (forall r', guardsn n Q (k::stk)  (p,r')) ->
    (forall r,  guardsn (n'+n) P ((c ;; k)::stk) (p,r)).

Definition hoare (G:pred prog) (R P:pred world) (c:instruction) (Q:pred world) :=
  forall p k stk,
    G p -> forall r p', necR p p' -> P (p',r) -> exists n,
      getsn n ((c;;k)::stk) (k::stk) Q (p',r)  \/
      getsn n ((c;;k)::stk) stk R (p',r).

Lemma hoare_seq2 : forall G R P Q S i1 i2,
  hoare G R P i1 Q ->
  hoare G R Q i2 S ->
  hoare G R P (i1 ;; i2) S.
Proof.
  repeat intro.
  spec H p (i2;;k) stk H1.
  spec H r p' H2 H3.
  destruct H as [n1 [?|?]].
  hnf in H.
  destruct (le_lt_dec n1 (level p')).
  spec H. omega.
  destruct H as [n' [? ?]].
  destruct H4 as [p'' [r'' [? ?]]].
  spec H0 p k stk H1.
  spec H0 r'' p''.
  spec H0. admit.
  spec H0; auto.
  destruct H0 as [n2 [?|?]].
  exists (n1+n2). left.
  hnf; intros.
  hnf in H0. spec H0.
admit.
  destruct H0 as [n'' [??]].
  destruct H7 as [p''' [r''' [? ?]]].
  exists (n'+n''). split. omega.
  do 2 econstructor; split. 2: eauto.
admit.
  exists (n1+n2). right.
admit.
  clear H.
  exists n1. left. intro. exfalso; omega.
  exists (n1+1). right.
  repeat intro.
  hnf in  H. spec H. omega.
  destruct H as [n' [? ?]].
  exists (n'+1). split. omega.
admit.
Qed.

(*
Definition funptr' (l:label) (A:Type) (t:termMeas) (P Q: A -> pred world) : pred prog :=
  EX c : instruction, code l c &&
    ALL stk : stack, ALL n : nat, ALL x : A,
      |> ((embedWP (guardsn n (Q x) stk)) -->
           (ALL n' : nat, embedWP (evalTM t n'   -->
                                    guardsn (n+n') (P x) ((c;;instr_assert FF)::stk) ))).
*)

Definition funptr' (l:label) (A:Type) (t:termMeas) (P Q: A -> pred world) : pred prog :=
  EX c : instruction, code l c &&
  ALL stk : stack,  ALL x : A,
      embedWP (P x --> EX n:nat, evalTM t n &&
                 |>getsn n ((c;;instr_assert FF)::stk) stk (Q x)).

Definition funptr l A P Q : pred prog :=
  EX t:termMeas,
      funptr' l A t P Q &&
      ALL x:A, (embedWP (P x --> EX n:nat, evalTM t n)).

(*
Lemma hoare_call : forall G R v Q l A lP lQ a,
  let wp :=
      store_op (fun r => r#v = Some (value_label l)) &&
      prog_op (funptr l A lP lQ) &&
      lP a && (closed (lQ a --> Q))
 in
  hoare G R wp (instr_call v) Q.
Proof.
  repeat intro.
  subst wp.
  destruct H1 as [[[??]?]?].
  hnf in H2. destruct H2 as [? _].
  destruct H2 as [t [? ?]].
  hnf in H2.
  hnf in H2.
  destruct H2 as [i [? ?]].
  spec H6 (k :: stk) a r.
  spec H6 (p',r). spec H6; auto.
  spec H6; auto.
  destruct H6 as [n1 [? ?]].
  exists (1+n1). left.
  intro.
  case_eq (age1 p'); intros.
  spec H7 (p0,r). spec H7.
admit.
  hnf in H7. spec H7.
admit.
  destruct H7 as [n' [? ?]]. exists (1+n'). split. omega.
  destruct H10 as [p'' [r'' [? ?]]].
(*
  case_eq (age1 p''). intros p''' ?.
  exists p'''; exists r''; split.*)
  exists p''. exists r''. split; auto.
  destruct H2 as [i' [? ?]].
  econstructor.
  econstructor; eauto.
  hnf in H1. destruct H1.
  apply H13.
admit.
  spec H4 (p',r''). spec H4; simpl; auto.
  hnf. simpl; auto.
  eapply H4; eauto.
admit.
admit.
Qed.
*)

Definition verify_prog (psi:program assert) (G:pred prog) :=
  forall n, agedfrom (K.squash (n,psi)) && |>G |-- G.

(*
Lemma verify_func_simple : forall psi l (G:pred prog) (A:Type) (P Q:A -> pred world) i
  (REL:A -> A -> Prop),
  well_founded REL ->
  psi#l = Some i ->
  (forall a,
    let Pr' a' := P a' && !!(REL a' a) in
      exists t:termMeas,
        hoare (funptr' l A t Pr' Q && G) (Q a) (P a) i FF) ->

  verify_prog psi G ->
  verify_prog psi (funptr l A P Q  && G).
Proof.
  do 13 intro.
  intros w Hw.
  destruct Hw as [Hw1 Hw2].
  split.
  2: eapply H2; eauto.
  2: split; eauto.
  2: repeat rewrite later_and in Hw2.
  2: destruct Hw2; auto.
  hnf. intro x.
  induction x using (well_founded_induction H).
  destruct (H1 x) as [t' ?].
  hnf in H4.

  hnf; exists i. split.
admit.
  intros stk x r w' ? ?.
  spec H0 x r. simpl in H0. hnf in H0.
  case_eq (age1 w'); intros.
  spec H0 (fst w0).
  generalize (H0 (instr_assert FF)). clear H0; intro.
  spec H0 stk. spec H0.
  clear H0.
  split.
  spec H2 (level w0). spec H2.
admit.
  spec H2 (fst w0). spec H2.
  split; auto.
admit.
admit.
  destruct H2.
  destruct H0 as [? ?].
  destruct H0 as [i' [? ?]].
  exists i'. split; auto.
  intros stk' x' r' w'' ? ?.
  destruct H9. destruct w''; destruct H10. clear H10.
  rewrite later_and in Hw2.
  destruct Hw2.
  rewrite later_and in H10.
  destruct H10.
  spec H13 (fst w0).
  spec H13.
admit.
  spec H13 x r (fst w0, r). spec H13; auto.
  spec H13.
admit.
  destruct H13 as [n1 ?].
  simpl in H13.
  spec H11 n1 H13.
  destruct H11 as [n2 [? ?]].
  spec H7 stk' x' s (p,s).
  spec H7.
admit.
  spec H7; auto.
admit.

  spec H0 r (fst w0). spec H0; auto.
  spec H0. split.
admit.
  repeat rewrite later_and in Hw2.
  destruct Hw2. destruct H6.
  spec H8 (fst w0).
  spec H8.
admit.
  spec H8 x r. spec H8 (fst w0, r). spec H8; auto.
  spec H8.
admit.
  destruct H8 as [n' ?]. simpl in H8.
  exists n'; split; auto. hnf; auto.
  destruct H0 as [n' [?|?]].
admit.

  exists n'. split; auto.

*)

Lemma verify_func_simple : forall psi l (G:pred prog) (A:Type) (P Q:A -> pred world) i (t:termMeas),
  psi#l = Some i ->

  (forall a r,
    let Pr  := P a && EX n:nat, store_op (fun r' => proj1_sig t r' n /\ (r' = r)) in
    let Pr' a' := P a' && store_op (fun r' => forall n, proj1_sig t r n -> exists n', proj1_sig t r' n' /\ n' < n) in
    hoare (funptr' l A t Pr' Q && G) (Q a) Pr i FF) ->

  verify_prog psi G ->
  verify_prog psi (funptr' l A t P Q  &&
                   (ALL a:A, embedWP (P a --> EX x:nat, evalTM t x))
                   && G).
Proof.
  do 12 intro. induction n using (well_founded_induction lt_wf).
  intros w Hw.
  destruct Hw as [Hw1 Hw2].
  split.
  2: eapply H1; eauto.
  2: split; eauto.
  2: repeat rewrite later_and in Hw2.
  2: destruct Hw2; auto.
  split; intros.
  hnf; exists i. split.
admit.
  intros stk x r w' ? ?.
  spec H0 x r. simpl in H0. hnf in H0.
  case_eq (age1 w'); intros.
  spec H0 (fst w0).
  generalize (H0 (instr_assert FF)). clear H0; intro.
  spec H0 stk. spec H0.
  clear H0.
  split.
  spec H2 (level w0). spec H2.
admit.
  spec H2 (fst w0). spec H2.
  split; auto.
admit.
admit.
  destruct H2.
  destruct H0 as [? ?].
  destruct H0 as [i' [? ?]].
  exists i'. split; auto.
  intros stk' x' r' w'' ? ?.
  destruct H9. destruct w''; destruct H10. clear H10.
  rewrite later_and in Hw2.
  destruct Hw2.
  rewrite later_and in H10.
  destruct H10.
  spec H13 (fst w0).
  spec H13.
admit.
  spec H13 x' r (fst w0, r). spec H13; auto.
  spec H13.
admit.
  destruct H13 as [n1 ?].
  simpl in H13.
  spec H11 n1 H13.
  destruct H11 as [n2 [? ?]].
  spec H7 stk' x' s (p,s).
  spec H7.
admit.
  spec H7; auto.
admit.

  spec H0 r (fst w0). spec H0; auto.
  spec H0. split.
admit.
  repeat rewrite later_and in Hw2.
  destruct Hw2. destruct H6.
  spec H8 (fst w0).
  spec H8.
admit.
  spec H8 x r. spec H8 (fst w0, r). spec H8; auto.
  spec H8.
admit.
  destruct H8 as [n' ?]. simpl in H8.
  exists n'; split; auto. hnf; auto.
  destruct H0 as [n' [?|?]].
admit.
  repeat rewrite later_and in Hw2.
  destruct Hw2. destruct H6.
  spec H8 (fst w0).
  spec H8.
admit.
  spec H8 x r. spec H8 (fst w0, r). spec H8; auto.
  spec H8.
admit.
  destruct H8 as [n'' ?].
  exists n''. split; auto.
admit.

Lemma hoare_weaken : forall x x' G G' (R R' P P' Q Q':pred world) i,
  x <= x' ->
  G' |-- G  ->
  prog_op G' && R  |-- R' ->
  prog_op G' && P' |-- P  ->
  prog_op G' && Q  |-- Q' ->
  hoare' x  G  R  P  i Q ->
  hoare' x' G' R' P' i Q'.
Proof.
  intros until i; repeat intro.
  destruct a'.
  spec H4 p n k stk.
  spec H4; auto.
  rewrite worldNec_unfold in H8.
  destruct H8.
  subst s.
  spec H4. repeat intro. eapply H6; eauto.
  apply H1. split; auto. destruct a'. rewrite worldNec_unfold in H10. split; trivial.
  apply pred_nec_hereditary with p; intuition.
  spec H4. repeat intro. eapply H7; eauto.
  apply H3. split; auto. destruct a'. rewrite worldNec_unfold in H10. split; auto.
  apply pred_nec_hereditary with p; intuition.
  spec H4 r (p0, r).
  spec H4. rewrite worldNec_unfold. intuition.
  spec H4; auto.
  apply H2. split; auto. split; auto.
  apply pred_nec_hereditary with p; auto.
  simpl in *.
  intro.
  spec H4. omega.
  destruct H4 as [px [rx [? ?]]].
  exists px. exists rx. split; trivial.
  omega.
Qed.

Lemma hoare_weaken_time : forall x x' G R P i Q,
  x <= x' ->
  hoare' x G R P i Q ->
  hoare' x' G R P i Q.
Proof.
  intros until Q. intro. apply hoare_weaken; hnf; simpl; intuition.
Qed.

Lemma hoare_weaken_pre : forall x G R P P' i Q,
  prog_op G && P' |-- P ->
  hoare' x G R P i Q ->
  hoare' x G R P' i Q .
Proof.
  intros until Q. intro.
  apply hoare_weaken; hnf; simpl; intuition.
Qed.

Lemma hoare_weaken_post : forall x G R P i Q Q',
  prog_op G && Q |-- Q' ->
  hoare' x G R P i Q ->
  hoare' x G R P i Q'.
Proof.
  intros until Q'. intro.
  apply hoare_weaken; hnf; simpl; intuition.
Qed.

Lemma hoare_ex_pre : forall x G R T P i Q,
  (forall z:T, hoare' x G R (P z) i Q) ->
  hoare' x G R (exp P) i Q.
Proof.
  repeat intro.
  destruct H4.
  spec H x0.
  eapply H; eauto.
Qed.

Lemma hoare_ex_pre' : forall x G R T P i Q,
  hoare' x G R (exp P) i Q ->
  (forall z:T, hoare' x G R (P z) i Q).
Proof.
  repeat intro.
  eapply H; eauto.
  exists z. auto.
Qed.

Lemma hoare_fact_pre : forall x G R (X:Prop) P i Q,
  (X -> hoare' x G R P i Q) ->
  hoare' x G R (!!X && P) i Q.
Proof.
  repeat intro.
  destruct H4. hnf in H4.
  spec H H4. eapply H; eauto.
Qed.

Lemma hoare_return : forall G R,
  hoare' 0 G R R instr_return FF.
Proof.
  repeat intro.
  spec H0 r a' H2 H3.
  destruct a'.
  intro.
  destruct H0 as [pz [rz [? ?]]]. omega.
  exists pz. exists rz.
  split. omega.
  econstructor. eapply step_return.
  auto.
Qed.

Lemma hoare_seq : forall x y G R P Q S i1 i2,
  hoare' x G R P i1 Q ->
  hoare' y G R Q i2 S ->
  hoare' (x+y) G R P (i1 ;; i2) S.
Proof.
  intros. hnf; intros.
  assert (guardsn (x+(y+n)) P ((i1;;i2;;k)::stk) (p,r)).
    apply H; auto.
    repeat intro. destruct a'. repeat intro.
    rewrite worldNec_unfold in H4. destruct H4. subst s.
    spec H2 r' (p0, r'). spec H2. rewrite worldNec_unfold. intuition.
    spec H2 H5.
    unfold haltsn in H2. simpl in H2. spec H2. omega.
    destruct H2 as [pz [rz [? ?]]].
    exists pz; exists rz.
    split. omega.
    trivial.
  do 3 intro.
  spec H4 a' H5 H6.
  destruct a'. intro. unfold haltsn in H4. simpl in H4. spec H4. omega.
  destruct H4 as [px [rx [? ?]]].
  exists px. exists rx.
  split. omega.
  econstructor. econstructor.
  auto.
Qed.

Lemma hoare_getlabel : forall l v G R P,
  hoare' 0 G R
    (box (setM v (value_label l)) P)
    (instr_getlabel l v)
    P.
Proof.
  repeat intro.
  spec H1 (r#v <- (value_label l)).
  destruct a'.
  rewrite worldNec_unfold in H2. destruct H2. subst s.
  spec H1 (p0, r#v <- (value_label l)).
  spec H1. rewrite worldNec_unfold. intuition.
  spec H1. apply H3. constructor; auto.
  intro.
  destruct H1 as [pz [rz [? ?]]]. omega.
  exists pz; exists rz.
  split. omega.
  econstructor. econstructor.
  auto.
Qed.

Lemma hoare_call : forall x G R v Q l A t lP lQ a,
  let wp :=
      store_op (fun r => r#v = Some (value_label l)) &&
      evalTM t x &&
      (prog_op (funptr' l A t lP lQ)) &&
      lP a && (closed (lQ a --> Q))
 in
  hoare' (S x) G R wp (instr_call v) Q.
Proof.
  do 23 intro.
  unfold wp in H3.
  destruct H3 as [[[[? ?] ?] ?] ?].
  destruct a'.
  destruct H5 as [[i [? ?]] _].
  intro.
  case_eq (age1 p0); intros.
  2: rewrite (af_level1 age_facts) in H10; omegac.
  spec H8 (k::stk) n a p1.
  spec H8. simpl. apply t_step. trivial.
  spec H8 p1. spec H8. apply rt_refl.
  spec H8.
    intros r'. spec H1 r'.
    repeat intro.
    spec H1 a'.
    spec H1.
    destruct a'.
    rewrite worldNec_unfold in H11. destruct H11. subst s0.
    rewrite worldNec_unfold in H2. destruct H2. subst s.
    rewrite worldNec_unfold. split; trivial.
    apply rt_trans with p0. trivial.
    apply rt_trans with p1. apply rt_step. trivial. trivial.
    spec H1; auto.
    destruct a'.
    spec H7 (p0,s0).
    spec H7. simpl; hnf; auto.
    apply H7; auto.
    repeat rewrite worldNec_unfold in *; intuition.
    apply rt_trans with p1; auto.
    apply rt_step; auto.
  spec H8 x s (p1,s).
  spec H8. simpl; hnf; auto.
  spec H8. apply H4.
  spec H8 (p1,s).
  spec H8. apply rt_refl.
  spec H8. apply pred_nec_hereditary with (p0,s); auto.
  rewrite worldNec_unfold; intuition.

  copy H10.
  apply (af_level2 age_facts) in H10.
  destruct H8 as [pz [rz [? ?]]]. omega.
  exists pz; exists rz.
  split. omega.
  destruct H5 as [ix [? ?]].
  econstructor.
  eapply step_call.
  apply H3.
  apply H5.
  apply H11.
  generalize (stepstar_approxprog 0 p1 pz p1 pz s
      ((i;; instr_assert FF) :: k :: stk) ((ix;; instr_assert FF) :: k :: stk)
      rz nil); intro.
  spec H14 H12.
  spec H14. red. trivial.
  spec H14. red. trivial.
  spec H14.
  constructor.
  rewrite <- H10.
  red. simpl. red in H13. congruence.
  apply stack_approx_rel_refl.
  destruct H14 as [sx [? ?]].
  inversion H15.
  subst sx.
  trivial.
Qed.

Lemma hoare_call2 : forall G R v Q l A t lP lQ a,
  let wp :=
      store_op (fun r => r#v = Some (value_label l)) &&
      (prog_op (funptr' l A t lP lQ)) &&
      lP a && (closed (lQ a --> Q))
 in
  hoare G R wp (instr_call v) Q.
Proof.
  intros.
  hnf. subst wp.

Lemma hoare_call' : forall x G R v Q,
  let wp :=
    EX l:label, EX A:Type, EX t:termMeas,
    EX lP:(A->pred world), EX lQ:(A -> pred world), EX a:A,
      store_op (fun r => r#v = Some (value_label l)) &&
      (evalTM t x) &&
      (prog_op (funptr l A t lP lQ)) &&
      lP a && (closed (lQ a --> Q))
 in
  hoare (S x) G R wp (instr_call v) Q.
Proof.
  intros. subst wp.
  repeat (apply hoare_ex_pre; intro).
  apply hoare_call.
Qed.

Lemma hoare_step_fetch0 : forall v1 v2 x1 x2 G R P,
  hoare 0 G R
    (store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x1) P)
    (instr_fetch_field v1 0 v2)
    P.
Proof.
  repeat intro.
  destruct a'.
  destruct H3.
  destruct H3 as [_ ?].
  rewrite worldNec_unfold in H2. destruct H2. subst s.
  spec H1 (r#v2 <- x1).
  spec H1 (p0,r#v2 <- x1).
  spec H1. repeat rewrite worldNec_unfold; intuition.
  spec H1. apply H4. constructor. auto.
  intro.
  spec H1 H5.
  destruct H1 as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  econstructor. econstructor. eauto.
  auto.
Qed.

Lemma hoare_step_fetch1 : forall v1 v2 x1 x2 G R P,
  hoare 0 G R
    (store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x2) P)
    (instr_fetch_field v1 1 v2)
    P.
Proof.
  repeat intro.
  destruct a'.
  destruct H3.
  destruct H3 as [_ ?].
  rewrite worldNec_unfold in H2. destruct H2. subst s.
  spec H1 (r#v2 <- x2).
  spec H1 (p0,r#v2 <- x2).
  spec H1. repeat rewrite worldNec_unfold; intuition.
  spec H1. apply H4. constructor. auto.
  intro.
  spec H1 H5.
  destruct H1 as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  econstructor. econstructor. eauto.
  auto.
Qed.

Lemma hoare_cons : forall v1 v2 v3 x1 x2 G R P,
  hoare 0 G R
     (store_op (fun r => r#v1 = Some x1 /\ r#v2 = Some x2) &&
        box (setM v3 (value_cons x1 x2)) P)
     (instr_cons v1 v2 v3)
     P.
Proof.
  repeat intro.
  destruct a'.
  destruct H3.
  destruct H3 as [_ ?].
  rewrite worldNec_unfold in H2. destruct H2. subst s.
  spec H1 (r#v3 <- (value_cons x1 x2)).
  spec H1 (p0, r#v3 <- (value_cons x1 x2)).
  spec H1. repeat rewrite worldNec_unfold; intuition.
  spec H1. apply H4. constructor. auto.
  intro.
  spec H1 H5.
  destruct H1 as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  destruct H3.
  econstructor. econstructor; eauto.
  auto.
Qed.

Lemma hoare_if : forall x v s1 s2 P1 P2 G R Q,
  let wp :=
    EX val:value,
      store_op (fun r => r#v = Some val) &&
    (

      ((!!(val = value_label (L 0)) && P1))
      ||
      ((EX x1:value, (EX x2:value,
        !!(val = (value_cons x1 x2)))) && P2)
    )
   in
  hoare x G R P1 s1 Q ->
  hoare x G R P2 s2 Q ->
  hoare x G R wp (instr_if_nil v s1 s2) Q.
Proof.
  do 23 intro.
  hnf in H5.
  destruct a'.
  destruct H5 as [v' [[_ ?] ?]].
  destruct H6 as [[? ?]|[? ?]].

  (* nil case *)
  simpl in H6.
  spec H p n k stk.
  do 3 (spec H; auto).
  rewrite worldNec_unfold in H4. destruct H4. subst s.
  spec H r (p0,r).
  spec H. rewrite worldNec_unfold. intuition.
  spec H H7.
  intro.
  spec H H8.
  destruct H as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  econstructor. eapply step_if_nil1; eauto.
  subst v'; auto.
  auto.

  (* cons case *)
  destruct H6 as [v1 [v2 ?]]. simpl in H6. subst v'.
  spec H0 p n k stk.
  do 3 (spec H0; auto).
  rewrite worldNec_unfold in H4. destruct H4. subst s.
  spec H0 r (p0,r).
  spec H0. rewrite worldNec_unfold. intuition.
  spec H0 H7.
  intro. spec H0 H6.
  destruct H0 as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  econstructor. eapply step_if_nil2; eauto.
  auto.
Qed.

Lemma hoare_assert : forall G R P (Q:assert),
  prog_op G && P |-- Q ->
  hoare 0 G R P (instr_assert Q) P.
Proof.
  repeat intro.
  spec H2 r a' H3 H4.
  destruct a'.
  intro.
  spec H2 H5.
  destruct H2 as [px [rx [? ?]]].
  exists px. exists rx.
  split. trivial.
  econstructor 2.
  econstructor.
  apply H.
  split; auto.
  rewrite <- (nec_useless G) in H0.
  simpl; split; auto.
  apply H0.
  rewrite worldNec_unfold in H3. intuition.
  auto.
Qed.

(* Verifying function bodies and entire programs *)

Definition verify_prog (psi:program assert) (G:pred prog) :=
  forall n, agedfrom (K.squash (n,psi)) && |>G |-- G.

Lemma verify_complete : forall G psi,
  verify_prog psi G ->
  forall n, G (K.squash (n,psi)).
Proof.
  intros.
  spec H n.
  cut (agedfrom (K.squash (n,psi)) |-- G).
  intros.
  eapply H0.
  hnf; apply rt_refl.
  apply goedel_loeb.
  apply derives_trans with
    (agedfrom (K.squash (n,psi)) && |>G); auto.
  intros a Ha; destruct Ha; split; auto.
Qed.

Record funspec (B:Type) :=
  { fs_A  : B -> Type
  ; fs_t  : B -> termMeas
  ; fs_P  : forall b, fs_A b -> pred world
  ; fs_Q  : forall b, fs_A b -> pred world
  }.

Definition funspec_assumptions B b n (fss:list (label*funspec B) ) : pred prog :=
  ALL l:_, ALL fs:_, !!(In (l,fs) fss) -->
    let P' a := fs_P B fs b a &&
      store_op (fun r => exists n', proj1_sig (fs_t B fs b) r n' /\ n' < n)
    in funptr l (fs_A B fs b) (fs_t B fs b) P' (fs_Q B fs b).

Lemma verify_true :
  forall psi,
    verify_prog psi TT.
Proof.
  repeat intro; hnf; auto.
Qed.

Lemma verify_clique : forall psi G B (fss:list (label * funspec B)),

  (forall l fs,
    In (l,fs) fss ->
    exists i, psi#l = Some i /\
    forall b a n,
    let Pr := fs_P B fs b a && store_op (fun r' => proj1_sig (fs_t B fs b) r' n) in
      hoare n (funspec_assumptions B b n fss && G) (fs_Q B fs b a) Pr i FF) ->

  verify_prog psi G ->

  verify_prog
      psi
      ((ALL b:B, ALL l:_, ALL fs:_,
        !!(In (l,fs) fss) -->
        funptr l (fs_A B fs b) (fs_t B fs b)
        (fs_P B fs b) (fs_Q B fs b)) && G).
Proof.
  repeat intro.
  destruct H1.
  rewrite box_and in H2; destruct H2.
  split. 2: eapply H0; eauto; split; eauto.
  apply verify_complete with _ _ n in H0.
  clear H3.
  simpl in H1.
  clear H2.
  intros b l fs p' ? ?. simpl in H3.
  unfold funptr.
  destruct (H l fs H3) as [i [? ?]].
  exists (fmap_instr (K.approx (level p')) i).
  split.
  exists
    (fmap_instr (K.approx (level p')) (fmap_instr (K.approx n) i)). split.
  apply nec_prog_lookup with (K.squash (n,psi)).
  eapply rt_trans; eauto.
  unfold prog_lookup. rewrite K.unsquash_squash. simpl. unfold KnotInput.fmap.
  erewrite fmap_eqn.
  auto.
  auto.
  hnf.
  f_equal.
  rewrite collapse_instr_approx.
  rewrite min_l; auto.
  replace n with (level (K.squash (n,psi))).
  apply nec_level. apply rt_trans with a; auto.
  rewrite K.knot_level.
  rewrite K.unsquash_squash; auto.

  clear H5.
  intros stk n0 x ? ? ? ? ? n'.
  revert stk n0 x a' a'0 H5 H6 H7.
  revert l fs i H3 H4.
  induction n' using (well_founded_induction lt_wf).

  repeat intro.
  destruct a'1. rewrite worldNec_unfold in H9. destruct H9; subst.
  destruct a'2. rewrite worldNec_unfold in H11. destruct H11; subst.
  simpl in H10.
  destruct (H l fs H4) as [i' [? ?]].
  rewrite H5 in H13; inv H13.
  rename i' into i.
  spec H14 b x n'.
  hnf in H14.
  spec H14 p n0.
  generalize (H14 (instr_assert FF)). clear H14; intro H14.
  spec H14 stk.
  spec H14.
    split.
    hnf; simpl; intros.
    destruct (H b0 b1 H15) as [i' [? ?]].
    exists (fmap_instr (K.approx (level a'1) )i'). split.
    exists (fmap_instr (K.approx (level a'1)) i'). split.
    replace (fmap_instr (K.approx (level a'1)) i')
      with  (fmap_instr (K.approx (level a'1)) (fmap_instr (K.approx n) i')).
    apply nec_prog_lookup with (K.squash (n,psi)).
    apply rt_trans with p; auto.
    apply rt_trans with a'0; auto.
    apply rt_trans with a'; auto.
    apply rt_trans with p'; auto.
    apply rt_trans with a; auto.
    apply Rt_Rft; auto.
    unfold prog_lookup.
    rewrite K.unsquash_squash; simpl.
    unfold KnotInput.fmap.
    eapply fmap_eqn; auto.
    rewrite collapse_instr_approx.
    rewrite min_l; auto.
    replace n with (level (K.squash (n,psi))).
    apply nec_level.
    apply rt_trans with a; auto.
    apply rt_trans with p'; auto.
    apply rt_trans with a'; auto.
    apply Rt_Rft; auto.
    apply rt_trans with a'0; auto.
    apply rt_trans with p; auto.
    rewrite K.knot_level. rewrite K.unsquash_squash.
    simpl; auto.
    hnf. auto.

    intros.
    destruct H24.
    destruct a'5.
    destruct H25.
    destruct H26 as [n'' [? ?]].
    destruct a'4.
    rewrite worldNec_unfold in H21.
    destruct H21.
    subst s1.
    intros.
    rewrite worldNec_unfold in H23.
    destruct H23; subst.
    assert (n'' = b5).
    destruct (fs_t B b1 b); eauto.
    subst b5.
    spec H3 n''.
    spec H3; auto.
    spec H3 b0 b1 i'.
    spec H3; auto.
    spec H3; auto.
    spec H3 b2 b3 b4.
    spec H3 a'1 a'3.
    spec H3.
      simpl.
      apply Rt_Rft_trans with a'; auto.
      apply rt_trans with p; auto.
      apply rt_trans with a'0; auto.
    spec H3.
      apply rt_trans with a'2; auto.
      apply Rt_Rft; auto.
    spec H3; auto.
    simpl in H3.
    spec H3 s (p2,s).
    spec H3.
    rewrite worldNec_unfold; simpl; auto.
    spec H3; auto.
    spec H3 (p1,s).
    spec H3.
    rewrite worldNec_unfold; simpl; auto.
    spec H3; auto.
    spec H3; auto.
    destruct H3 as [? [? [? ?]]].
    destruct (stepstar_approxprog 0 p1 x0 p1 x0 _ _ (((fmap_instr (K.approx (level a'1)) i');;instr_assert FF) :: b2) _ _ H29).
    simpl; auto.
    simpl; auto.
    constructor.
    hnf. simpl. f_equal.
    rewrite collapse_instr_approx.
    rewrite min_l.
    rewrite collapse_instr_approx.
    rewrite min_l.
    auto.
    apply later_level.
    apply Rt_Rft_trans with a'2; auto.
    apply rt_trans with a'3; auto.
    apply rt_trans with p2; auto.

    apply later_level.
    apply Rt_Rft_trans with a'; auto.
    apply rt_trans with a'0; auto.
    apply rt_trans with p; auto.
    apply rt_trans with a'1; auto.
    apply rt_trans with a'2; auto.
    apply Rt_Rft; auto.
    apply rt_trans with a'3; auto.
    apply rt_trans with p2; auto.

    apply stack_approx_rel_refl.
    destruct H30.
    inv H31. hnf; eauto.
    apply pred_nec_hereditary with (K.squash (n,psi)); auto.
    apply rt_trans with a; auto.
    apply rt_trans with p'; auto.
    apply rt_trans with a'; auto.
    apply Rt_Rft; auto.
    apply rt_trans with a'0; auto.

  spec H14.
  intro r'.
  spec H8 r'.
  apply pred_nec_hereditary with (a'0,r'); auto.
  rewrite worldNec_unfold; auto.
  spec H14; repeat intro. inv H15.
  spec H14 s0.
  simpl in H14.
  spec H14 (p0,s0).
  spec H14.
  rewrite worldNec_unfold; auto.
  spec H14; intuition.
  spec H14. omega.
  rewrite plus_comm.
  destruct H14 as [? [? [? ?]]].
  destruct (stepstar_approxprog 0 p0 x0 p0 x0 _ _ (((fmap_instr (K.approx (level p')) i);;instr_assert FF) :: stk) _ _ H15).
  simpl; auto.
  simpl; auto.
  constructor.
  hnf; simpl. f_equal.
  rewrite collapse_instr_approx.
  rewrite min_l.
  auto.
  apply later_level.
  apply Rt_Rft_trans with a'; auto.
  apply rt_trans with a'0; auto.
  apply rt_trans with p; auto.
  apply stack_approx_rel_refl.
  destruct H16.
  inv H17.
  hnf; eauto.
Qed.

Lemma verify_func : forall psi l (G:pred prog) (B:Type) (A:B->Type) (P Q:forall b, A b -> pred world) i (t:B -> termMeas),
  psi#l = Some i ->

  (forall b a n,
    let Pr  := P b a && store_op (fun r' => proj1_sig (t b) r' n) in
    let Pr' a' := P b a' && store_op (fun r' => exists n', proj1_sig (t b) r' n' /\ n' < n) in
    hoare n (funptr l (A b) (t b) Pr' (Q b) && G) (Q b a) Pr i FF) ->

  verify_prog psi G ->
  verify_prog psi
              ((ALL b:_, funptr l (A b) (t b) (P b) (Q b)) && G).
Proof.
  intros.
  generalize (verify_clique psi G B
    ((l,Build_funspec B A t P Q)::nil)); intros.
  spec H2.
    clear H2.
    intros.
    simpl in H2. intuition. inv H3.
    exists i; split; auto.
    simpl. intros.
    spec H0 b a n.
    revert H0.
    Opaque funptr.
    apply hoare_weaken; auto;
      hnf; simpl; intuition.
    spec H2 l0 (Build_funspec B A t P Q) a0.
    spec H2; auto.
  spec H2; auto.
  repeat intro.
  spec H2 n a.
  destruct H3.
  spec H2; split; auto.
    repeat intro.
    spec H4 a' H5.
    destruct H4; split; auto.
    repeat intro.
    simpl in H4.
    spec H4 b.
    simpl in H8. intuition.
    inv H9.
    simpl.
    eapply pred_nec_hereditary; eauto.
    destruct H2.
    intro b.
    spec H2 b.
    spec H2 l (Build_funspec B A t P Q).
    spec H2 a. spec H2; auto.
    simpl in H2. spec H2; auto.
    destruct H2; auto.
Qed.

Lemma verify_func_simple : forall psi l (G:pred prog) (A:Type) (P Q:A -> pred world) i (t:termMeas),
  psi#l = Some i ->

  (forall a n,
    let Pr  := P a && store_op (fun r' => proj1_sig t r' n) in
    let Pr' a' := P a' && store_op (fun r' => exists n', proj1_sig t r' n' /\ n' < n) in
    hoare n (funptr l A t Pr' Q && G) (Q a) Pr i FF) ->

  verify_prog psi G ->
  verify_prog psi (funptr l A t P Q && G).
Proof.
  intros.
  generalize (verify_func psi l G unit (fun _ => A) (fun _ => P) (fun _ => Q) i (fun _ => t) H); intros.
  spec H2. intros. eapply H0; eauto.
  spec H2. intros. eapply H1; eauto.
  repeat intro.
  spec H2 n a.
  rewrite box_and in H3.
  destruct H3.
  destruct H4.
  spec H2. split; auto.
  rewrite box_and. split; auto.
  rewrite box_all. intro. auto.
  destruct H2; split; auto.
  apply H2. exact tt.
Qed.

Lemma end_assert_lemma : forall Q n p p' r r' stk,
    stepN n p p' r (stk++(instr_assert Q ;; instr_return ;; instr_assert FF) :: nil) r' nil ->
    stepstar p p' r stk r' nil /\ proj1_sig Q (p',r').
Proof.
  induction n; simpl; intros; inv H.
  destruct stk; discriminate.
  destruct stk. simpl in H1.
  inv H1.
  inv H2.
  inv H.
  inv H0.
  split; auto.
  constructor.
  inv H.

  simpl in H1.
  inv H1.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; auto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; auto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (i1;;i2;;i3)::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (i1;;i0)::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (i2;;i0)::stk) in H2.
  intuition. econstructor. eapply step_if_nil2; eauto. auto.
  apply IHn with (stk:= (i'0;;instr_assert FF)::i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:=stk) in H2.
  intuition. econstructor. econstructor. auto.
Qed.

(* Fundamental liveness theorem.  A verified function,
   when started in a state satisfying its precondition,
   will halt in a state satisfying its postcondition.
 *)

Lemma verify_totally_correct : forall G A P Q psi l t x,
  verify_prog psi G ->
  G |-- funptr l A t P Q ->
  forall r,
    (forall n, P x (K.squash (n,psi),r)) ->
    forall n c, proj1_sig t r n ->
      psi#l = Some c ->
      exists p', exists r',
        stepstar (K.squash (n,psi)) p'
        r ((c ;; instr_assert FF)::nil)
        r' nil /\
        Q x (p',r').
Proof.
  intros.
  assert (forall n, G (K.squash (n,psi))).
  apply verify_complete; auto.
  hnf; auto.
  assert (funptr l A t P Q (K.squash (S n,psi))) by auto.
  destruct H5 as [i [? ?]].
  spec H6 ((instr_assert (Q x) ;; instr_return ;; instr_assert FF)::nil).
  spec H6 0 x (K.squash (n,psi)).
  spec H6.
  simpl.
  apply t_step.
  hnf. rewrite K.knot_age1.
  rewrite K.unsquash_squash; simpl.
  f_equal.
  apply K.unsquash_inj.
  repeat rewrite K.unsquash_squash.
  f_equal.
  transitivity (KnotInput.fmap (K.approx n oo K.approx (S n)) psi).
  rewrite <- KnotInput.fmap_comp; auto.
  replace (K.approx n oo K.approx (S n)) with (K.approx n); auto.
  extensionality.
  unfold compose.
  change (K.approx n x0 = (K.approx n oo K.approx (1+n)) x0).
  rewrite <- K.approx_approx1; auto.
  spec H6 (K.squash (n,psi)).
  spec H6.
  apply rt_refl.
  spec H6.
  repeat intro.
  destruct a'.
  simpl.
  intro.
  exists p.
  econstructor.
  split.
  omega.
  econstructor.
  econstructor.
  auto.
  econstructor 2.
  econstructor.
  econstructor.

  spec H6 n r.
  spec H6 (K.squash (n,psi),r).
  spec H6; auto.
  spec H6. auto.
  spec H6 (K.squash (n,psi),r).
  spec H6; auto.
  spec H6. auto.
  hnf in H6.
  spec H6; auto.
  rewrite K.knot_level.
  rewrite K.unsquash_squash; simpl. omega.
  destruct H6 as [pz [rz [? ?]]].
  exists pz; exists rz.
  destruct H5 as [i' [? ?]].
  rewrite K.knot_level in H8.
  rewrite K.unsquash_squash in H8.
  simpl in H8.
  unfold prog_lookup in H5.
  rewrite K.unsquash_squash in H5.
  simpl in H5.
  unfold KnotInput.fmap in H5.
  apply fmap_eqn2 in H5.
  destruct H5 as [? [? ?]].
  unfold prog in *.
  unfold assert, world, prog, KnotInput.other in *.
  rewrite H3 in H5.
  inv H5.
  assert (stepstar (K.squash (n,psi)) pz r
    ((x0;;instr_assert FF) ::
      (instr_assert (Q x) ;; instr_return ;; instr_assert FF) :: nil) rz nil).
  generalize H7; intros.
  eapply stepstar_approxprog in H7.
  2: instantiate (2:=O). 2: simpl; auto.
  2: simpl; auto.
  2: instantiate (1:=
    (x0;; instr_assert FF) ::
    (instr_assert (Q x);; instr_return;;instr_assert FF) :: nil).
  destruct H7 as [? [? ?]].
  inv H9.
  auto.
  constructor.
  rewrite K.knot_level; simpl.
  rewrite K.unsquash_squash.
  simpl.
  hnf.
  hnf in H8.
  simpl; f_equal.
  rewrite collapse_instr_approx in H8.
  rewrite min_l in H8; auto.
  apply stack_approx_rel_refl.
  apply stepstar_stepN in H5.
  destruct H5.
  eapply end_assert_lemma; eauto.
Qed.

(* Weaker corollary: a program with a safe entry point
   will eventually halt.
 *)
Corollary verify_halts : forall t G psi l,
  verify_prog psi G ->
  G |-- funptr l unit t (fun _ => TT) (fun _ => TT) ->
  forall r n c,
    proj1_sig t r n ->
    psi#l = Some c ->
    eventually_halts (K.squash (n,psi)) r
       ((c ;; instr_assert FF)::nil).
Proof.
  intros.
  generalize (verify_totally_correct G unit (fun _ => TT) (fun _ => TT) psi l t tt); intros.
  spec H3; auto.
  spec H3; auto.
  spec H3 r.
  spec H3; auto.
  intros; hnf; auto.
  spec H3 n c H1 H2.
  hnf.
  destruct H3 as [? [? [? ?]]].
  eauto.
Qed.


(** A proof of the fact the [Applicative] functors are the same thing
    as [Monoidal] functors. *)

From CoqMTL Require Export Control.Applicative.
From CoqMTL Require Export Control.Monoidal.

(** We cat define [pure] by mapping a constant function over the default
    computation. *)
Definition pure_Monoidal
  {F : Type -> Type} {inst : Monoidal F} {A : Type} (x : A) : F A :=
    fmap (fun u : unit => x) default.

(** We can define [ap] by pairing f with a and mapping over it with a
    function which applies the first component of the pair to the
    second component. *)
Definition ap_Monoidal
  {F : Type -> Type} {inst : Monoidal F} {A B : Type}
  (f : F (A -> B)) (a : F A) : F B :=
    fmap (fun p => apply (fst p) (snd p)) (pairF f a).

(** The direction [Monoidal] => [Applicative] was very hard for me to
    prove. After unfolding definitions, the easy part is taken care of
    by the tactic [monoidal]. The rest is mostly precisely tailored
    rewrites in the reverse direction. If you gazed at the goals for
    long enough, you could probably have proved this all by yourself,
    but thanks to me you don't need to... *)
#[refine]
#[export]
Instance Monoidal_Applicative
  (F : Type -> Type) (inst : Monoidal F) : Applicative F :=
{
  is_functor := @is_functor F inst;
  pure := @pure_Monoidal F inst;
  ap := @ap_Monoidal F inst
}.
Proof.
  all: unfold pure_Monoidal, ap_Monoidal; intros; monoidal.
    rewrite !par_comp. cbn. unfold apply.
      rewrite <- (pairF_default_l _ (pairF g (pairF f x))).
      rewrite <- ?pairF_assoc, <- ?fmap_comp'. repeat f_equal.
      ext p. destruct p as [[[u g'] f'] x']. cbn. reflexivity.
    rewrite <- fmap_comp'. reflexivity.
    rewrite <- fmap_comp', par_comp. cbn.
      replace (fun p : (A -> B) * unit => id (fst p) x)
      with (@fst (A -> B) unit .> flip apply x).
        monoidal. unfold flip, apply, id, compose. reflexivity.
        ext p. destruct p. cbn. reflexivity.
Defined.

(** We can define [default] by injecting [tt] into the functor. *)
Definition default_Applicative
  {F : Type -> Type} {inst : Applicative F} : F unit := pure tt.

(** We can define [pairF] by applying [pair] injected into the functor. *)
Definition pairF_Applicative
  {F : Type -> Type} {inst : Applicative F} {A B : Type}
  (x : F A) (y : F B) : F (A * B)%type := pair <$> x <*> y.

#[global] Hint Unfold default_Applicative pairF_Applicative : CoqMTL.

(*Hint Remove fmap_pure_ap : CoqMTL.*)

(** The proof is quite easy, nothing to see here.
    Note that [fmap_pure_ap] is not necessary in the big rewrite
    alternative ||, but the tactic [hs] uses it, so it's necessary
    to prove the equivalence. *)
#[refine]
#[export]
Instance Applicative_Monoidal
  (F : Type -> Type) (inst : Applicative F) : Monoidal F :=
{
  is_functor := inst;
  default := default_Applicative;
  pairF := @pairF_Applicative F inst;
}.
Proof.
  all: hs;
  repeat (
    rewrite identity || rewrite homomorphism ||
    (*rewrite fmap_pure_ap ||*) rewrite <- composition ||
    rewrite interchange
  );
  reflexivity.
Defined.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-04-02
- Adam Koprowski, 2007-03-29
- Frederic Blanqui, 2009-05-11

useful definitions and lemmas on natural numbers
*)

Set Implicit Arguments.

From Coq Require Import Min Max Morphisms Psatz Compare Euclid.
From Coq Require Export Arith Omega.

From CoLoR Require Import LogicUtil EqUtil BoolUtil RelUtil.

(***********************************************************************)
(** Declare implicit arguments. *)

Arguments lt_S [n m] _.
Arguments lt_S_n [n m] _.
Arguments lt_n_S [n m] _.
Arguments le_S [n m] _.
Arguments gt_le_S [n m] _.
Arguments le_lt_n_Sm [n m] _.
Arguments lt_le_weak [n m] _.
Arguments le_plus_minus [n m] _.
Arguments le_plus_minus_r [n m] _.
Arguments lt_n_0 [n] _.
Arguments le_lt_trans [n m p] _ _.
Arguments lt_le_trans [n m p] _ _.
Arguments le_lt_or_eq [n m] _.
Arguments lt_n_Sm_le [n m] _.
Arguments lt_trans [n m p] _ _.
Arguments le_trans [n m p] _ _.
Arguments lt_le_weak [n m] _.
Arguments lt_le_S [n m] _.
Arguments lt_not_le [n m] _ _.
Arguments le_lt_eq_dec [n m] _.
Arguments le_S_n [n m] _.
Arguments le_not_lt [n m] _ _.
Arguments eq_add_S [n m] _.
Arguments le_n_S [n m] _.

(***********************************************************************)
(** Tactics. *)

Ltac coq_omega := omega.
Tactic Notation "omega" := intros; omega.
Tactic Notation "lia" := intros; lia.
Tactic Notation "nia" := intros; nia.

Ltac max :=
  match goal with
    | |- context [max ?x ?y] => gen (le_max_l x y); gen (le_max_r x y)
  end; omega.

(***********************************************************************)
(** Properties of ordering relations on nat. *)

Instance le_preorder : PreOrder le.

Proof. split; intro; omega. Qed.

Instance lt_trans : Transitive lt.

Proof. intro; omega. Qed.

Instance ge_preorder : PreOrder ge.

Proof. split; intro; omega. Qed.

Instance gt_trans : Transitive gt.

Proof. intro; omega. Qed.

(***********************************************************************)
(** Boolean function for equality. *)

Fixpoint beq_nat (x y : nat) :=
  match x, y with
    | 0, 0 => true
    | S x', S y' => beq_nat x' y'
    | _, _ => false
  end.

Lemma beq_nat_ok : forall x y, beq_nat x y = true <-> x = y.

Proof.
  induction x; destruct y; simpl; split; intro; try (refl || discr).
  f_equal. fo. fo.
Qed.

Ltac case_beq_nat := case_beq beq_nat beq_nat_ok.

Lemma eq_nat_dec_refl : forall n, eq_nat_dec n n = left (n<>n) (eq_refl n).

Proof.
  intro. gen (eq_nat_dec n n). destruct s.
  rewrite (UIP_refl eq_nat_dec e). refl. cong.
Qed.

(***********************************************************************)
(** Boolean functions for orderings. *)

Fixpoint bgt_nat (x y : nat) :=
  match x, y with
    | 0, _ => false
    | S _, 0 => true
    | S x', S y' => bgt_nat x' y'
  end.

Lemma bgt_nat_ok : forall x y, bgt_nat x y = true <-> x > y.

Proof.
  induction x; destruct y; simpl; split; intro; try omega; try discr. refl.
  rewrite IHx in H. omega. rewrite IHx. omega.
Qed.

Ltac check_gt := rewrite <- bgt_nat_ok; check_eq.

Lemma bgt_nat_ko : forall x y, bgt_nat x y = false <-> x <= y.

Proof.
  induction x; destruct y; simpl; split; intro; try (refl || discr || omega).
  rewrite IHx in H. omega. apply le_S_n in H. rewrite IHx. hyp.
Qed.

Fixpoint bge_nat (x y : nat) :=
  match x, y with
    | 0, 0 => true
    | 0, _ => false
    | S _, 0 => true
    | S x', S y' => bge_nat x' y'
  end.

Lemma bge_nat_ok : forall x y, bge_nat x y = true <-> x >= y.

Proof.
  induction x; destruct y; simpl; split; intro; try (refl || discr || omega).
  rewrite IHx in H. omega. apply le_S_n in H. rewrite IHx. hyp.
Qed.

Ltac check_ge := rewrite <- bge_nat_ok; check_eq.

Definition blt_nat x y := bgt_nat y x.

Lemma blt_nat_ok : forall x y, blt_nat x y = true <-> x < y.

Proof. intros. unfold blt_nat. rewrite bgt_nat_ok. omega. Qed.

Definition bne_nat x y := negb (beq_nat x y).

Lemma bne_nat_ok : forall x y, bne_nat x y = true <-> x <> y.

Proof.
  intros x y. unfold bne_nat. rewrite negb_lr. simpl.
  rewrite (beq_ko beq_nat_ok). refl.
Qed.

(***********************************************************************)
(** Unicity of equality and ordering proofs on nat. *)

Lemma eq_unique : forall (n m : nat) (h1 h2 : n = m), h1 = h2.

Proof. intros. apply UIP. apply eq_nat_dec. Qed.

Scheme le_ind_dep := Induction for le Sort Prop.

Lemma le_unique : forall n m (h1 h2 : n <= m), h1 = h2.

Proof.
intro n.
assert (forall m (h1 : n <= m) p (h2 : n <= p),
           m=p -> eq_dep nat (le n) m h1 p h2).
 intros m h1; elim h1 using le_ind_dep.
  intros p h2; case h2; intros.
   auto.
   subst n. absurd (S m0 <= m0); auto with arith.
 intros m0 l Hrec p h2.
  case h2; intros.
   subst n; absurd (S m0 <= m0); auto with arith.
   assert (m0=m1); auto ; subst m0.
   replace l0 with l; auto.
   apply (@eq_dep_eq _ eq_nat_dec (le n) m1); auto.
 intros; apply (@eq_dep_eq _ eq_nat_dec (le n) m); auto.
Qed.

Lemma lt_unique : forall n m (h1 h2 : n < m), h1 = h2.

Proof. intros n m. unfold lt. intros. apply le_unique. Qed.

Lemma lt_Sn_nS : forall m n (H : m < n), lt_S_n (lt_n_S H) = H.

Proof. intros. apply lt_unique. Qed.

Lemma lt_nS_Sn : forall m n (H : S m < S n), lt_n_S (lt_S_n H) = H.

Proof. intros. apply lt_unique. Qed.

(***********************************************************************)
(** Lemmas on the maximum of two numbers. *)

Arguments max_r [n m] _.
Arguments max_l [n m] _.

From Coq Require Import Compare.

Lemma max_assoc : forall a b c, max a (max b c) = max (max a b) c.

Proof.
intros.
case (le_dec b c); intro H.
 rewrite (max_r H).
 case (le_dec a b); intro H'.
  rewrite (max_r (le_trans H' H)), (max_r H'), (max_r H). refl.
  case (le_dec a c); intro H''; rewrite (max_l H'); refl.
  rewrite (max_l H).
  case (le_dec a b); intro H'.
   rewrite (max_r H').
   apply (sym_equal (max_l H)).
   assert (H'' : c <= max a b). eapply le_trans. apply H. apply le_max_r.
   apply (sym_equal (max_l H'')).
Qed.

Lemma le_max_intro_l x y z : x <= y -> x <= max y z.

Proof. lia. Qed.

Lemma lt_max_intro_l x y z : x < y -> x < max y z.

Proof. lia. Qed.

Lemma le_max_intro_r x y z : x <= z -> x <= max y z.

Proof. lia. Qed.

Lemma lt_max_intro_r x y z : x < z -> x < max y z.

Proof. lia. Qed.

Lemma le_max_elim_l x y z : max x y <= z -> x <= z.

Proof. lia. Qed.

Lemma le_max_elim_r x y z : max x y <= z -> y <= z.

Proof. lia. Qed.

Lemma max_ge_compat x y x' y' : x >= x' -> y >= y' -> max x y >= max x' y'.

Proof. lia. Qed.

Lemma max_gt_compat x y x' y' : x > x' -> y > y' -> max x y > max x' y'.

Proof. lia. Qed.

Lemma min_gt_compat x y x' y' : x > x' -> y > y' -> min x y > min x' y'.

Proof. lia. Qed.

Lemma max_lt x y z : max y z < x <-> y < x /\ z < x.

Proof. lia. Qed.

Lemma gt_max x y z : x > max y z <-> x > y /\ x > z.

Proof. apply max_lt. Qed.

Lemma max_0_r x : max x 0 = x.

Proof. destruct x; refl. Qed.

(***********************************************************************)
(** Lemmas on the minimum of two numbers. *)

Lemma elim_min_l x y z : x <= z -> min x y <= z.

Proof. lia. Qed.

Lemma elim_min_r : forall x y z, y <= z -> min x y <= z.

Proof. lia. Qed.

Lemma lt_min_intro_l x y z : x < z -> min x y < z.

Proof. lia. Qed.

Lemma lt_min_intro_r x y z : y < z -> min x y < z.

Proof. lia. Qed.

Lemma le_min_intro_l x y z : x <= z -> min x y <= z.

Proof. lia. Qed.

Lemma le_min_intro_r x y z : y <= z -> min x y <= z.

Proof. lia. Qed.

Lemma min_ge_compat x y x' y' : x >= x' -> y >= y' -> min x y >= min x' y'.

Proof. lia. Qed.

(***********************************************************************)
(** Decidability of ordering relations on nat. *)

Lemma ge_dec : rel_dec ge.

Proof. intros i j. destruct (le_lt_dec j i); intuition. Defined.

Lemma gt_dec : rel_dec gt.

Proof. intros i j. destruct (le_gt_dec i j); auto with arith. Defined.

Lemma lt_ge_dec x y : {x < y} + {x >= y}.

Proof.
  destruct (lt_eq_lt_dec x y); auto; try destruct s; auto with *.
Defined.

(***********************************************************************)
(** Euclidian division. *)

Lemma mult_is_not_O m n : m * n <> 0 <-> m <> 0 /\ n <> 0.

Proof. nia. Qed.

Lemma mult_lt_r_elim : forall x x' y, x * y < x' * y -> x < x'.

Proof. induction x; induction y; simpl; nia. Qed.

Arguments mult_lt_r_elim [x x' y] _.

Lemma eucl_div_unique b q1 r1 q2 r2 :
  b > r1 -> b > r2 -> q1 * b + r1 = q2 * b + r2 -> q1 = q2 /\ r1 = r2.

Proof.
intros.
assert ((q1-q2)*b=r2-r1). nia.
assert ((q2-q1)*b=r1-r2). (*nia works but is slow*)
rewrite mult_minus_distr_r. clear H2; omega.
(*nia works but is slow*)
destruct (le_gt_dec r1 r2).
(* r1 <= r2 *)
destruct (eq_nat_dec r1 r2).
(* r1 = r2 *)
subst. rewrite minus_diag in *. nia.
(* r1 < r2 *)
assert (r2 - r1 < b). clear -H H0; omega.
rewrite <- H2 in H4. rewrite <- (mult_1_l b) in H4 at -1.
ded (mult_lt_r_elim H4).
assert (q1=q2). clear H H0 H1 H3 H4; omega.
subst q2; clear H2 H3 H4 H5. omega.
(* r1 > r2 *)
assert (r1 - r2 < b). clear -H H0; omega.
rewrite <- H3 in H4. rewrite <- (mult_1_l b) in H4 at -1.
ded (mult_lt_r_elim H4).
assert (q1=q2). clear H H0 H1 H2 H4; omega.
subst q2; clear H2 H3 H4 H5. omega.
Qed.

Arguments eucl_div_unique [b q1 r1 q2 r2] _ _ _.

(***********************************************************************)
(** Iteration of a function. *)

Section iter.

  Variables (A : Type) (a : A) (f : A -> A).

  Fixpoint iter i :=
    match i with
      | 0 => a
      | S i' => f (iter i')
    end.

End iter.

Section iter_prop.

  Variables (A : Type) (f : A -> A).

  Lemma iter_com : forall a i, iter (f a) f i = f (iter a f i).

  Proof. induction i; simpl; intros. refl. rewrite IHi. refl. Qed.

  Lemma red_iter : forall R : relation A,
    (forall x y, R x y -> R (f x) (f y)) ->
    forall i x y, R x y -> R (iter x f i) (iter y f i).

  Proof. induction i; simpl; intros. hyp. apply H. apply IHi. hyp. Qed.

End iter_prop.

(***********************************************************************)
(** Arithmetical lemmas. *)

Lemma le_plus : forall x y, x <= y -> exists k, y = k + x.

Proof.
  induction 1; simpl. ex 0. refl. destruct IHle as [k e]. ex (S k). omega.
Qed.

Lemma le_lt_S : forall i k, i <= k -> i < S k.

Proof. auto with arith. Qed.

Lemma i_lt_n : forall n i j : nat, n = i + S j -> i < n.

Proof. omega. Qed.

Arguments i_lt_n [n i j] _.

Lemma S_neq_O : forall n, S n = O -> False.

Proof. discr. Qed.

Lemma plus_reg_l_inv : forall n1 n2 p2, n2=p2 -> n1+n2=n1+p2.

Proof. omega. Qed.

Lemma plus_reg_r_inv : forall n1 p1 n2, n1=p1 -> n1+n2=p1+n2.

Proof. omega. Qed.

Lemma plus_minus_eq : forall v p, v+p-p=v.

Proof. omega. Qed.

Lemma le_minus_plus : forall v p, p<=v -> v-p+p=v.

Proof. omega. Qed.

Arguments le_minus_plus [v p] _.

Lemma plus_1_S : forall n, n+1 = S n.

Proof. omega. Qed.

Lemma lt_from_le : forall x y, 0 < y -> x <= y-1 -> x < y.

Proof. omega. Qed.

Lemma le_from_lt : forall x y, x < y+1 -> x <= y.

Proof. omega. Qed.

Lemma lt_pm : forall n k x, n < x -> x <= n+k -> x-n-1 < k.

Proof. omega. Qed.

Arguments lt_pm [n k x] _ _.

Lemma le_plus_r : forall k l, k <= k+l.

Proof. omega. Qed.

Lemma misc1 : forall x k, S k = x+2+k-x-1.

Proof. omega. Qed.

Lemma misc2 : forall x k, k = x+2+k-(x+1)-1.

Proof. omega. Qed.

Lemma mult_gt_0 : forall i j, i > 0 -> j > 0 -> i * j > 0.

Proof. nia. Qed.

Lemma mult_lt_compat_lr : forall i j k l,
  i <= j -> j > 0 -> k < l -> i * k < j * l.

Proof. nia. Qed.

Lemma S_add_S : forall n1 n2 n, n1 + S n2 = n -> S n1 + S n2 = S n.

Proof. intros. subst. refl. Qed.

Arguments S_add_S [n1 n2 n] _.

Lemma gt_plus : forall l k, l > k -> exists m, l = (m + 1) + k.

Proof. induction 1. exists 0. omega. destruct IHle. exists (S x). omega. Qed.

Arguments gt_plus [l k] _.

(***********************************************************************)
(** Given a non-null function [F], [Interval_list F i] is the pair
[(S(i),S(i+1)] where S(0)=0 and S(i+1)=S(i)+F(i). *)

Section Interval_list.

  Variables (F : nat -> nat) (HFi : forall i, exists y, F i = S y).

  Fixpoint Interval_list i : nat * nat :=
    match i with
      | 0 => (0, F 0)
      | S i' => let x := snd (Interval_list i') in (x, x + F i)
    end.

  Local Notation F' := Interval_list.

  Lemma int_exPi : forall i, exists j, fst (F' j) <= i /\ i < snd (F' j).

  Proof.
    intros i. induction i. exists 0. simpl. destruct (HFi 0); rewrite H. omega.
    destruct IHi as [k Hk]. assert (HSi : S i <= snd (F' k)). omega.
    destruct (le_lt_or_eq HSi). exists k. intuition.
    exists (S k). simpl. rewrite H. split. omega.
    destruct (HFi (S k)). rewrite H0. omega.
  Qed.

End Interval_list.

(***********************************************************************)
(** Monotone functions on nat. *)

Section mon.

  Variables (A : Type) (ltA : relation A) (ht : transitive ltA) (f : nat->A).

  Lemma monS : (forall x, ltA (f x) (f (S x)))
    -> (forall x y, x < y -> ltA (f x) (f y)).

  Proof.
    intros hf x. cut (forall k, ltA (f x) (f (k+S x))).
    intros hx y xy. assert (y = (y-S x)+S x). omega. rewrite H. apply hx.
    induction k; simpl. apply hf. apply ht with (f (k+S x)). hyp. apply hf.
  Qed.

End mon.

Arguments monS [A ltA] _ [f] _ [x y] _.

(****************************************************************************)
(** Smallest natural number satisfying some satisfiable property. *)

Section smallest.

  Variables (P : nat -> Prop) (P_dec : forall x, {P x}+{~P x}).

  Section smallest_aux.

    Variables (n : nat) (h : P n).

    Fixpoint smallest_aux acc k :=
      match k with
        | 0 => if P_dec k then 0 else acc
        | S k' => smallest_aux (if P_dec k then k else acc) k'
      end.

    Definition smallest := smallest_aux n n.

    Lemma smallest_aux_ok : forall k acc, P acc -> P (smallest_aux acc k).

    Proof.
      induction k; intros acc Pacc; simpl.
      destruct (P_dec 0); hyp.
      destruct (P_dec (S k)); fo.
    Qed.

    Lemma smallest_ok : P smallest.

    Proof. unfold smallest. apply smallest_aux_ok. hyp. Qed.

    Lemma smallest_aux_le_max_args l :
      forall k acc, acc <= l -> k <= l -> smallest_aux acc k <= l.

    Proof.
      induction k; intros acc accl kl; simpl.
      destruct (P_dec 0); omega.
      destruct (P_dec (S k)); apply IHk; omega.
    Qed.

    Lemma smallest_le_arg : smallest <= n.

    Proof. apply smallest_aux_le_max_args; refl. Qed.

    Lemma smallest_aux_plus_exists m :
      forall k acc, exists acc', smallest_aux acc (k + m) = smallest_aux acc' m.

    Proof.
      induction k; intro acc; simpl.
      ex acc. refl.
      set (a := if P_dec (S (k + m)) then S (k + m) else acc).
      destruct (IHk a) as [acc' hacc']. ex acc'. hyp.
    Qed.

    Lemma smallest_aux_plus m : P (S m) ->
      forall k acc acc', smallest_aux acc (k + S m) = smallest_aux acc' (S m).

    Proof.
      intro PSm. induction k; intros acc acc'; simpl.
      destruct (P_dec (S m)). refl. contr. erewrite IHk. refl.
    Qed.

    Lemma smallest_aux_le_exists k l acc :
      k <= l -> exists acc', smallest_aux acc l = smallest_aux acc' k.

    Proof.
      intro kl. destruct (le_plus kl) as [m e]; subst.
      apply smallest_aux_plus_exists.
    Qed.

    Lemma smallest_aux_le k l acc acc' :
      k <= l -> P (S k) -> smallest_aux acc (S l) = smallest_aux acc' (S k).

    Proof.
      intros kl Pk. destruct (le_plus kl) as [m e]; subst.
      assert (e : S (m + k) = m + S k). omega. rewrite e.
      apply smallest_aux_plus. hyp.
    Qed.

  End smallest_aux.

  Lemma smallest_inv_le k l : k <= l -> P k -> smallest l = smallest k.

  Proof.
    unfold smallest. destruct k; simpl.
    (* k=0 *)
    intros _ P0. destruct (P_dec 0). 2: contr. clear p. revert l.
    cut (forall l acc, smallest_aux acc l = 0). fo.
    induction l; intro acc; simpl. destruct (P_dec 0). refl. contr. fo.
    (* k > 0 *)
    destruct l; simpl. omega. intro kl. apply smallest_aux_le. omega.
  Qed.

  Lemma smallest_inv m n : P m -> P n -> smallest m = smallest n.

  Proof.
    intros Pm Pn. destruct (le_dec n m). apply smallest_inv_le; hyp.
    sym. apply smallest_inv_le. omega. hyp.
  Qed.

  Lemma smallest_comp m n : P m -> P n -> smallest m <= n.

  Proof.
    intros Pm Pn. destruct (le_dec m n). rewrite smallest_le_arg. hyp.
    rewrite smallest_inv with (n:=n); auto. apply smallest_le_arg.
  Qed.

End smallest.

Arguments smallest [P] _ _.
Arguments smallest_ok [P] _ [n] _.
Arguments smallest_comp [P] _ [m n] _ _.


Require Export Unicode.Utf8_core.
Require Import String List.
Require Export Showable PartialOrder TErrorMonad Connection HoTT Decidable.

Notation "x .1" := (projT1 x) (at level 3).
Notation "x .2" := (projT2 x) (at level 3).
Notation " ( x ; p ) " := (existT _ x p).
Notation "{ x : A & P }" := (sigT_HSet A (fun x => P)) : type_scope.

Local Open Scope string_scope.

Set Universe Polymorphism.

(** * Dependent equivalences *)

(**

A _simple_ type is an inhabitant of [Type], e.g. [A: Type], [A → B: Type].

A _rich_ type is a dependent pair, e.g. [{ a : A | B a}].

A _dependent_ type is a type family [A → Type] indexed by some type
[A], e.g. [C: nat → Type], [C (S n) → C n].

  We define the following family of cast operators:
  - [to_rich]: from [A] to [{a: A & P a}]
  - [to_dep]: from [A] to [B a]
  - [to_simp]: from [B a] to [A]

   We don't provide an explicit [rich_to_simpl], since this is just [projT1]
*)

(**

  A dependent equivalence between [B : A -> Type] and [C : Type] is
  witnessed by a (proof-irrelevant) predicate [P : A -> C -> Type]
  such that [B] and [{C & P}] are equivalent while [{C & P}] and [C]
  are partially equivalent. It also a partial index synthesis function
  [c_to_a], which tries to compute an index from a computational
  element [C].

*)

(* =DepEquiv= *)
Class DepAnticonnection (A:HSet) (B: A -> HSet) (C:HSet) :=
  {  a_P : A -> C -> HProp;
     a_total_equiv :> forall a, B a ≃ {c:C & a_P a c};
     a_partial_equiv :> forall a, {c:C & a_P a c} ≈K C;
     a_c_to_a : C ⇀ A;
     a_prop_c_to_a : forall a (b:B a), (a_c_to_a °° ((a_partial_equiv a).(apc_fun)))
                                  ((a_total_equiv a).(e_fun) b) = Some a;
  }.
Notation "B ≈K□ C" := (DepAnticonnection _ B C)
(* =end= *)
                      (at level 50).

Hint Extern 1 (IsEquiv ?f) => apply (e_isequiv (e := a_total_equiv _)) :
             typeclass_instances.

Hint Extern 1 (IsAnticonnectionK ?f) => apply (apc_isconn (a := a_partial_equiv _)) :
             typeclass_instances.

Definition c_to_b {A:HSet} {B: A -> HSet} {C:HSet}
           `{B ≈K□ C} {a:A}: {c:C & a_P a c} -> (B a) :=
  e_inv _.

Definition b_to_c {A:HSet} {B: A -> HSet} {C}
           `{B ≈K□ C} {a:A}: B a -> {c:C & a_P a c} :=
  (a_total_equiv a).(e_fun).

Definition to_rich {A:HSet} {B: A -> HSet} {C}
           `{B ≈K□ C} {a:A}: C ⇀ {c: C & a_P a c} :=
  apc_inv (apc_fun (@a_partial_equiv _ _ _ _ a)).

Program Definition to_dep {A:HSet} {B: A -> HSet} {C}
           `{B ≈K□ C}
           (a:A) : C ⇀ (B a) :=
  fun c => c' <- apc_inv (apc_fun (@a_partial_equiv _ _ _ _ a)) c; clift (e_inv _) c'.

Definition to_simpl {A:HSet} {B: A -> HSet} {C:HSet}
           `{B ≈K□ C}
           {a:A} : B a ⇀ C :=
  (a_partial_equiv a).(apc_fun) ° ((a_total_equiv a).(e_fun)).

(** ** Properties *)

Definition sub_eq_implies {A B B' : HSet} (x:TError A info_str) {f : A ⇀ B} {y : TError B info_str}
           {g : A ⇀ B'} {y' : TError B' info_str}
  (e : forall a, f a ≼ y -> g a ≼ y') : (a <- x; f a) ≼ y -> (a <- x; g a) ≼ y'.
Proof.
  destruct x. apply e. exact (fun x => x).
Defined.

Definition sub_eq_implies_simpl {A B : HSet} (x:TError A info_str) {y : TError A info_str}
           {g : A ⇀ B} {y' : TError B info_str}
  (e : forall a, creturn a ≼ y -> g a ≼ y') : x ≼ y -> (a <- x; g a) ≼ y'.
Proof.
  destruct x. apply e. intros H. exact H.
Defined.

Definition sub_eq_implies_complex  {A B B' C :HSet} (x:TError A info_str) {f : A ⇀ B}
           {y : TError B info_str} {g : A ⇀ B'} {y' : TError C info_str} {g' : B' ⇀ C}
           (e : forall a, f a ≼ y -> (b <- g a ; g' b) ≼ y') :
  (a <- x; f a) ≼ y ->  (b <- (a <- x; g a); g' b)  ≼ y'.
Proof.
  destruct x. apply e. intros X. simpl in *. exact X.
Defined.

Definition sub_eq_implies_op {A B B' : HSet} (x:TError A info_str) {f : A ⇀ B} {y : B}
           {g : A ⇀ B'} {y' : TError B' info_str}
  (e : forall a, creturn y ≼ f a -> y' ≼ g a) : creturn y ≼ (a <- x; f a) -> y' ≼ (a <- x; g a).
Proof.
  destruct x. apply e. intro H; inversion H.
Defined.

Definition sub_eq_implies_op_simpl {A B :HSet} (x:TError A info_str) {y : A}
           {g : A ⇀ B} {y' : TError B info_str}
  (e : forall a, creturn y ≼ creturn a -> y' ≼ g a) : creturn y ≼ x -> y' ≼ (a <- x; g a).
Proof.
  destruct x. apply e. intros H. inversion H.
Defined.

(* =DepEquiv_PartialEquivK= *)
Program Definition DepAnticonnection_ConnectionK  (A : HSet) (B : A -> HSet)
         (C : HSet) `{B ≈K□ C} (a:A) : B a ≈K C :=
  {| apc_fun := to_simpl;
     apc_isconn := {| apc_inv := to_dep a|} |}.
(* =end= *)
Next Obligation.
  - rename a0 into b. change ((to_dep a) °° to_simpl b ≼ creturn b). unfold kleisliComp, compose.
    unfold to_dep, to_rich, to_simpl, compose in *.
    assert (f := apc_sect (IsAnticonnectionK := apc_isconn (a := a_partial_equiv a)) _ (b_to_c b)).
    unfold kleisliComp in f.
    revert f. unfold b_to_c, compose.
    apply sub_eq_implies. intro c.
    apply sub_eq_implies_simpl. intro x.
    intro e. pose (ap (e_inv _) (Some_inj e)). apply (ap (@Some _ _)).
    pose (e_sect (IsEquiv := e_isequiv (e := a_total_equiv a)) _ b).
    refine (e0 @ e1).
Defined.
Next Obligation.
    rename a0 into c. unfold kleisliComp.
    unfold to_dep, to_rich in *.
    unfold to_simpl, clift, compose.
    assert (f := apc_retr (IsAnticonnectionK := apc_isconn (a := a_partial_equiv a)) _ c).
    unfold kleisliComp in f.
    revert f. apply sub_eq_implies_complex. intros s e.
    pose (e_retr (IsEquiv := e_isequiv (e := a_total_equiv a)) _ s).
    unfold compose in e0. simpl in *.
    simpl.
    rewrite e0. exact e.
Defined.

(* =to_dep_dom= *)
Definition to_dep_dom {A D: HSet} {B: A -> HSet} {C: HSet}
    `{B ≈K□ C}(f: C ⇀ D) (a: A): B a ⇀ D := f °° to_simpl.
(* =end= *)

Definition to_dep_dom2 {A:HSet} {B: A -> HSet} {C} {D E}
           `{B ≈K□ C}
           (f: C -> D ⇀ E) : forall a, B a -> D ⇀ E :=
  fun a b x=>
    c <- to_simpl b;
    f c x.

(** ** Casts from dependent to simple *)

(* =to_simpl_dom= *)
Definition to_simpl_dom {A D: HSet} {B: A -> HSet} {C: HSet}
           `{B ≈K□ C} (f: forall a: A, B a ⇀ D): C ⇀ D := fun c =>
     a <- a_c_to_a c;
     b <- to_dep a c ;
     f a b.
(* =end= *)

Program Definition TotalEquiv (A:HSet) (B: A -> HSet) (C:HSet) (P: A -> C -> HProp)
   {DREquiv_prop : forall a c, IsHProp (P a c)}
   {HSet_C : IsHSet C}
   (b_to_c : forall a, B a -> {c : C & P a c})
   (c_to_b : forall a, {c : C & P a c} -> B a)
   (prop_b_to_b : forall a, (c_to_b a) ° (b_to_c a) == id )
   (prop_c_to_c : forall a, (b_to_c a) ° (c_to_b a) == id) a:
  Equiv (B a) {c : C & P a c} :=
    {| e_fun := b_to_c a ;
       e_isequiv :=
         {| e_inv := c_to_b a ;
            e_sect := prop_b_to_b a;
            e_retr := prop_c_to_c a;|} |}.
Next Obligation.
  apply (is_hprop (IsHProp := is_hset (IsHSet := trunc_sigma _ _) _ _)).
Defined.

(* =IsDepAntiEquiv= *)
Definition IsDepAnticonnection (A:HSet) (B: A -> HSet) (C:HSet) P (H:forall a c, Checkable (P a c))
  (b_to_c : forall a, B a -> {c : C & P a c}) (c_to_b : forall a, {c : C & P a c} -> B a) (c_to_a : C ⇀ A) :
  (forall a, (c_to_b a) ° (b_to_c a) == id ) -> (forall a, (b_to_c a) ° (c_to_b a) == id) ->
  (forall a (b:B a), c_to_a (b_to_c a b).1 = Some a) -> B ≈K□ C
(* =end= *)
  :=
    fun prop_b_to_b prop_c_to_c prop_c_to_a =>
      Build_DepAnticonnection A B C P
                        (TotalEquiv A B C P b_to_c c_to_b prop_b_to_b prop_c_to_c)
                        (fun a => Checkable_AnticonnectionK C (P a))
                        c_to_a prop_c_to_a.

(** Given a relation [R : TError A -> A -> Type], one can automatically
construct a partial type equivalence between [B: A → Type] and [C:
Type] as long as we can recompute the index from an inhabitant of
[C]. This is the role of the function [c_to_a_rel]. *)

Definition Anticonnection_rel {A:HSet} {B: A -> HSet} {C:HSet} (R : TError A info_str -> A -> HProp)
   (c_to_a_rel : C ⇀ A)
   (P := fun a c => R (c_to_a_rel c) a)
   (b_to_c_rel : forall a, B a -> {c : C & P a c})
   (c_to_b_rel : forall a, {c : C & P a c} -> B a)
   (prop_b_to_b_rel : forall a, (c_to_b_rel a) ° (b_to_c_rel a) == id)
   (prop_c_to_c_rel : forall a, (b_to_c_rel a) ° (c_to_b_rel a) == id)
   {DepEquiv_check_rel : forall a a', Checkable (R a a')}
   {HSet : IsHSet C}
   (prop_c_to_a_R : forall a (b:B a), c_to_a_rel (b_to_c_rel _ b).1 = Some a) :
  B ≈K□ C
  :=
  IsDepAnticonnection A B C P _ b_to_c_rel c_to_b_rel c_to_a_rel prop_b_to_b_rel prop_c_to_c_rel
            (fun _ _ => prop_c_to_a_R _ _).


From Hammer Require Import Hammer.

Require Import Ensembles.
From GroupTheory Require Import Laws.
From GroupTheory Require Import Group_definitions.
From GroupTheory Require Import gr.
From GroupTheory Require Import g1.

Theorem auxsub :
forall (H : Group U) (x : U), subgroup U H Gr -> In U (G_ U H) x -> In U G x.
Proof. hammer_hook "g2" "g2.auxsub".
intros H x H'; elim H'; auto with sets.
Qed.

Section Trois.

Variable H K : Group U.
Variable subH : subgroup U H Gr.
Variable subK : subgroup U K Gr.

Inductive Prod : Ensemble U :=
Definition_of_Prod :
forall x y z : U,
In U (G_ U H) x -> In U (G_ U K) y -> star x y = z -> In U Prod z.
End Trois.

Section Quatre.
Variable H K : Group U.
Variable subH : subgroup U H Gr.
Variable subK : subgroup U K Gr.

Theorem T4 : Same_set U (Prod H K) (Prod K H) -> Setsubgroup U (Prod H K) Gr.
Proof. hammer_hook "g2" "g2.T4".
generalize (auxsub H); intro tH; generalize (auxsub K); intro tK.
intro H'.
apply T_1_6_3 with (witness := e); auto with sets.
rewrite <- (G2c' e); auto with sets.
apply Definition_of_Prod with (x := e) (y := e); auto with sets.
rewrite <- (eh_is_e H); auto with sets.
rewrite <- (eh_is_e K); auto with sets.
red in |- *.
intros x H'0; elim H'0.
intros x0 y z H'1 H'2 H'3; rewrite <- H'3; auto with sets.
intros a b H'0 H'1.
generalize H'1; clear H'1.
elim H'0.
intros x y z H'1 H'2 H'3; rewrite <- H'3.
intro H'4; elim H'4.
intros x0 y0 z0 H'5 H'6 H'7; rewrite <- H'7.
rewrite <- (inv_star' x0 y0); auto with sets.
rewrite <- (G1' x y (star (inv y0) (inv x0))); auto with sets.
red in H'.
elim H'; intros H'8 H'9; red in H'9; clear H'.
rewrite (G1' y (inv y0) (inv x0)); auto with sets.
lapply (H'9 (star (star y (inv y0)) (inv x0)));
[ intro H'10; elim H'10 | idtac ].
intros x1 y1 z1 H' H'11 H'12; rewrite <- H'12.
rewrite (G1' x x1 y1); auto with sets.
apply Definition_of_Prod with (x := star x x1) (y := y1); auto with sets.
rewrite <- (starH_is_star H); auto with sets.
apply Definition_of_Prod with (x := star y (inv y0)) (y := inv x0).
rewrite <- (starH_is_star K); auto with sets.
rewrite <- (invH_is_inv K); auto with sets.
rewrite <- (invH_is_inv H); auto with sets.
trivial with sets.
Qed.

Theorem T4R : Setsubgroup U (Prod H K) Gr -> Included U (Prod H K) (Prod K H).
Proof. hammer_hook "g2" "g2.T4R".
generalize (auxsub H); intro tH; generalize (auxsub K); intro tK.
intro H'; elim H'.
intros x H'0; red in |- *.
intros x0 H'1.
elim H'0; intros L1 L2; clear H'0.
generalize (auxsub x); intro tx.
cut (exists t : U, In U (Prod H K) t /\ t = inv x0).
intro H'2; elim H'2.
intros x1 H'3; elim H'3; intros H'4 H'5; try exact H'4; clear H'3.
generalize H'5.
elim H'4.
intros x2 y z H'3 H'6 H'7; rewrite <- H'7.
intro H'8.
rewrite (inv_involution' x0); auto with sets.
rewrite <- H'8.
rewrite <- (inv_star' x2 y); auto with sets.
apply Definition_of_Prod with (x := inv y) (y := inv x2); auto with sets.
rewrite <- (invH_is_inv K subK y); auto with sets.
rewrite <- (invH_is_inv H subH x2); auto with sets.
generalize H'1.
rewrite <- L2; auto with sets.
intro H'0.
apply ex_intro with (x := inv x0).
split; [ idtac | trivial with sets ].
rewrite <- (invH_is_inv x L1 x0); auto with sets.
Qed.

Theorem T4R1 :
Setsubgroup U (Prod H K) Gr -> Included U (Prod K H) (Prod H K).
Proof. hammer_hook "g2" "g2.T4R1".
generalize (auxsub H); intro tH; generalize (auxsub K); intro tK.
intro H'; elim H'.
intros x H'0; red in |- *.
intros x0 H'1.
elim H'0; intros L1 L2; clear H'0.
generalize (auxsub x); intro tx.
cut (exists t : U, In U (Prod K H) t /\ t = inv (inv x0)).
intro H'0; elim H'0.
intros x1 H'2.
elim H'2; intros H'3 H'4; generalize H'4; clear H'2.
elim H'3.
intros x2 y z H'2 H'5 H'6; rewrite <- H'6.
intro H'7.
rewrite (inv_involution' x0).
rewrite <- H'7.
rewrite (inv_involution' (star x2 y)).
rewrite <- (inv_star' x2 y).
rewrite <- (invH_is_inv x L1 (star (inv y) (inv x2))).
rewrite <- L2; auto with sets.
elim L1; simpl in |- *; auto with sets.
intros H'15 H'16; apply (G3a_ U x); auto with sets.
rewrite L2.
apply Definition_of_Prod with (x := inv y) (y := inv x2); auto with sets.
rewrite <- (invH_is_inv H subH y); auto with sets.
rewrite <- (invH_is_inv K subK x2); auto with sets.
rewrite L2.
apply Definition_of_Prod with (x := inv y) (y := inv x2); auto with sets.
rewrite <- (invH_is_inv H subH y); auto with sets.
rewrite <- (invH_is_inv K subK x2); auto with sets.
elim H'1; intros x3 y0 z0 H'8 H'9 H'10; rewrite <- H'10.
apply ex_intro with (x := star x3 y0).
split; [ idtac | auto with sets ].
apply Definition_of_Prod with (x := x3) (y := y0); trivial with sets.
Qed.
Hint Resolve T4 T4R T4R1.

Theorem T_1_6_8 :
Same_set U (Prod H K) (Prod K H) <-> Setsubgroup U (Prod H K) Gr.
Proof. hammer_hook "g2" "g2.T_1_6_8".
red in |- *; auto with sets.
Qed.
End Quatre.


Require Import Basics Types HSet.
Require Import Truncations.Core Truncations.SeparatedTrunc.
Require Import Modalities.Modality Modalities.Separated Modalities.Identity.
Require Import Limits.Pullback.

(** * Projective types *)

(** To quantify over all truncation levels including infinity, we parametrize [IsOProjective] by a [Modality]. When specializing to [IsOProjective purely] we get an (oo,-1)-projectivity predicate, [IsProjective]. When specializing to [IsOProjective (Tr n)] we get an (n,-1)-projectivity predicate, [IsTrProjective]. *)

Definition IsOProjective (O : Modality) (X : Type) : Type
  := forall A, In O A -> forall B, In O B ->
     forall f : X -> B, forall p : A -> B,
     IsSurjection p -> merely (exists s : X -> A, p o s == f).

(** (oo,-1)-projectivity. *)

Notation IsProjective := (IsOProjective purely).

(** (n,-1)-projectivity. *)

Notation IsTrProjective n := (IsOProjective (Tr n)).

(** A type X is projective if and only if surjections into X merely split. *)
Proposition iff_isoprojective_surjections_split
  (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X <->
    (forall (Y : Type), In O Y -> forall (p : Y -> X),
          IsSurjection p -> merely (exists s : X -> Y, p o s == idmap)).
Proof.
  split.
  - intros isprojX Y oY p S; unfold IsOProjective in isprojX.
    exact (isprojX Y _ X _ idmap p S).
  - intro splits. unfold IsOProjective.
    intros A oA B oB f p S.
    pose proof (splits (Pullback p f) _ pullback_pr2 _) as s'.
    strip_truncations.
    destruct s' as [s E].
    refine (tr (pullback_pr1 o s; _)).
    intro x.
    refine (pullback_commsq p f (s x) @ _).
    apply (ap f).
    apply E.
Defined.

Corollary equiv_isoprojective_surjections_split
  `{Funext} (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X <~>
    (forall (Y : Type), In O Y -> forall (p : Y -> X),
          IsSurjection p -> merely (exists s : X -> Y, p o s == idmap)).
Proof.
  exact (equiv_iff_hprop_uncurried (iff_isoprojective_surjections_split O X)).
Defined.

(** ** Projectivity and the axiom of choice *)

(** In topos theory, an object X is said to be projective if the axiom of choice holds when making choices indexed by X. We will refer to this as [HasOChoice], to avoid confusion with [IsOProjective] above. In similarity with [IsOProjective], we parametrize it by a [Modality]. *)

Class HasOChoice (O : Modality) (A : Type) :=
  hasochoice :
    forall (B : A -> Type), (forall x, In O (B x)) ->
    (forall x, merely (B x)) -> merely (forall x, B x).

(** (oo,-1)-choice. *)

Notation HasChoice := (HasOChoice purely).

(** (n,-1)-choice. *)

Notation HasTrChoice n := (HasOChoice (Tr n)).

Global Instance hasochoice_sigma
  `{Funext} {A : Type} {B : A -> Type} (O : Modality)
  (chA : HasOChoice O A)
  (chB : forall a : A, HasOChoice O (B a))
  : HasOChoice O {a : A | B a}.
Proof.
  intros C sC f.
  set (f' := fun a => chB a (fun b => C (a; b)) _ (fun b => f (a; b))).
  specialize (chA (fun a => forall b, C (a; b)) _ f').
  strip_truncations.
  apply tr.
  intro.
  apply chA.
Defined.

Proposition isoprojective_ochoice (O : Modality) (X : Type)
  : HasOChoice O X -> IsOProjective O X.
Proof.
  intros chX A ? B ? f p S.
  assert (g : merely (forall x:X, hfiber p (f x))).
  - rapply chX.
    intro x.
    exact (center _).
  - strip_truncations; apply tr.
    exists (fun x:X => pr1 (g x)).
    intro x.
    exact (g x).2.
Defined.

Proposition hasochoice_oprojective (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X -> HasOChoice O X.
Proof.
  refine (_ o fst (iff_isoprojective_surjections_split O X)).
  intros splits P oP S.
  specialize splits with {x : X & P x} pr1.
  pose proof (splits _ (fst (iff_merely_issurjection P) S)) as M.
  clear S splits.
  strip_truncations; apply tr.
  destruct M as [s p].
  intro x.
  exact (transport _ (p x) (s x).2).
Defined.

Proposition iff_isoprojective_hasochoice (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X <-> HasOChoice O X.
Proof.
  split.
  - apply hasochoice_oprojective. exact _.
  - apply isoprojective_ochoice.
Defined.

Proposition equiv_isoprojective_hasochoice
  `{Funext} (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X <~> HasOChoice O X.
Proof.
  refine (equiv_iff_hprop_uncurried (iff_isoprojective_hasochoice O X)).
  apply istrunc_forall.
Defined.

Proposition isprojective_unit : IsProjective Unit.
Proof.
  apply (isoprojective_ochoice purely Unit).
  intros P trP S.
  specialize S with tt.
  strip_truncations; apply tr.
  apply Unit_ind.
  exact S.
Defined.

Section AC_oo_neg1.
  (** ** Projectivity and AC_(oo,-1) (defined in HoTT book, Exercise 7.8) *)
  (* TODO: Generalize to n, m. *)

  Context {AC : forall X : HSet, HasChoice X}.

  (** (Exercise 7.9) Assuming AC_(oo,-1) every type merely has a projective cover. *)
  Proposition projective_cover_AC `{Univalence} (A : Type)
    : merely (exists X:HSet, exists p : X -> A, IsSurjection p).
  Proof.
    pose (X := Build_HSet (Tr 0 A)).
    pose proof ((equiv_isoprojective_hasochoice _ X)^-1 (AC X)) as P.
    pose proof (P A _ X _ idmap tr _) as F; clear P.
    strip_truncations.
    destruct F as [f p].
    refine (tr (X; (f; BuildIsSurjection f _))).
    intro a; unfold hfiber.
    apply equiv_O_sigma_O.
    refine (tr (tr a; _)).
    rapply (equiv_path_Tr _ _)^-1%equiv.  (* Uses Univalence. *)
    apply p.
  Defined.

  (** Assuming AC_(oo,-1), projective types are exactly sets. *)
  Theorem equiv_isprojective_ishset_AC `{Univalence} (X : Type)
    : IsProjective X <~> IsHSet X.
  Proof.
    apply equiv_iff_hprop.
    - intro isprojX. unfold IsOProjective in isprojX.
      pose proof (projective_cover_AC X) as P; strip_truncations.
      destruct P as [P [p issurj_p]].
      pose proof (isprojX P _ X _ idmap p issurj_p) as S; strip_truncations.
      destruct S as [s h].
      rapply (istrunc_embedding_trunc s).
      apply isembedding_isinj_hset.
      exact (isinj_section h).
    - intro ishsetX.
      apply (equiv_isoprojective_hasochoice purely X)^-1.
      rapply AC.
  Defined.

End AC_oo_neg1.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Cat.Facts.
From Categories Require Import Functor.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Functor.Representable.Hom_Func.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat
     Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat
     NatTrans.NatIso.

Local Open Scope nattrans_scope.

Section Y_emb.
  Context (C : Category).

  (** The dual of the Yoneda embedding for category C – the curry of hom
      functor of C. *)
  Definition CoYoneda : (C^op --> (Func_Cat C Type_Cat))%functor :=
    Exp_Cat_morph_ex (Hom_Func C).

  (** The Yoneda embedding for category C – the curry of hom functor of Cᵒᵖ. *)
  Definition Yoneda : (C --> (Func_Cat (C^op) Type_Cat))%functor :=
    Exp_Cat_morph_ex (Hom_Func (C^op)).

End Y_emb.

Section Y_Left_Right.
  Context (C : Category).

  (** The left hand side of the Yoneda lemma's isomorphism *)
  Definition Y_left :
    ((C^op × (Func_Cat (C^op) Type_Cat)) --> Type_Cat)%functor
    :=
      ((Hom_Func _)
         ∘ (Prod_Functor
              ((Yoneda C)^op) (Functor_id (Func_Cat (C^op) Type_Cat))))%functor.

  (** The right hand side of the Yoneda lemma's isomorphism *)
  Definition Y_right
    : ((C^op × (Func_Cat (C^op) Type_Cat)) --> Type_Cat)%functor :=
    ((Exp_Cat_Eval (C^op) Type_Cat) ∘ (Twist_Func _ _))%functor.

End Y_Left_Right.

Local Obligation Tactic := idtac.

(** The left to right natural transformation of Yoneda lemma. *)
Program Definition Y_left_to_right (C : Category) : (Y_left C) --> (Y_right C) :=
{|
  Trans := fun c_F => fun N => ((Trans N (fst c_F))) (id (fst c_F))
|}.

Next Obligation. (* Trnas_com *)
Proof.
  intros C [c F] [c' F'] [h1 h2].
  extensionality N; cbn.
  cbn in *.
  match goal with
    [|- _ = ?W] =>
    match W with
      (?F _a ?X (?Y ?Z))%morphism =>
      change W with (((F _a X) ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn.
  match goal with
    [|- _ = Trans h2 c' ?W] =>
    match W with
      (?F _a ?X (?Y ?Z))%morphism =>
      change W with (((F _a X) ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn.
  auto.
Qed.

Next Obligation.
Proof.
  symmetry; simpl.
  apply Y_left_to_right_obligation_1.
Qed.

(** The natural transformation needed to make the right to left natural
    transformation of Yoneda lemma. *)
Program Definition Y_right_to_left_NT (C : Category) (c : Obj)
        (F : (C^op --> Type_Cat)%functor) (h : (F _o c)%object)
  :
    ((Yoneda _) _o c)%object --> F :=
{|
  Trans := fun c' => fun g => (F _a g)%morphism h
|}.

Next Obligation. (* Trnas_com *)
Proof.
  intros C c F h c1 c2 h'.
  extensionality g; cbn.
  simpl_ids.
  match goal with
    [|- (?F _a (?X ∘ ?Y) ?Z)%morphism = _] =>
      transitivity (((F _a Y) ∘ (F _a X)) Z)%morphism; trivial
  end.
  auto.
Qed.

Next Obligation.
Proof.
  symmetry; simpl.
  apply Y_right_to_left_NT_obligation_1.
Qed.

(** The right to left natural transformation of Yoneda lemma. *)
Program Definition Y_right_to_left (C : Category) : (Y_right C) --> (Y_left C) :=
{|
  Trans := fun c_F => fun h => Y_right_to_left_NT C (fst c_F) (snd c_F) h
|}.

Next Obligation. (* Trans_com *)
Proof.
  intros C [c f] [c' f'] [h N].
  cbn in *.
  extensionality g; cbn.
  apply NatTrans_eq_simplify.
  extensionality d; extensionality g'; cbn.
  simpl_ids.
  match goal with
    [|- ?W = _] =>
    match W with
      (?F _a ?X (?F _a ?Y ?Z))%morphism =>
      change W with (((F _a X) ∘ (F _a Y)) Z)%morphism
    end
  end.
  rewrite <- F_compose; cbn.
  match goal with
    [|- ?W = _] =>
    match W with
      ?X (?Y ?Z) =>
      change W with ((X ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn; trivial.
Qed.

Next Obligation.
Proof.
  symmetry; simpl.
  apply Y_right_to_left_obligation_1.
Qed.

(** The Yoneda Lemma*)
Program Definition Yoneda_Lemma (C : Category) :
  ((Y_left C) ≃ (Y_right C))%natiso :=
  NatIso _ _ (Y_left_to_right C) (Y_right_to_left C) _ _.

Next Obligation.
Proof.
  intros C [c F]; FunExt; cbn in *.
  rewrite (F_id F).
  trivial.
Qed.

Next Obligation.
  simpl; intros C [c F]; FunExt.
  apply NatTrans_eq_simplify.
  FunExt.
  cbn in *.
  match goal with
    [|- ?W = _] =>
    match W with
      ?X (?Y ?Z) =>
      change W with ((X ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn.
  auto.
Qed.

(** Yoneda embedding is faithful. *)
Lemma Yoneda_Faithful (C : Category) : Faithful_Func (Yoneda C).
Proof.
  intros c c' f f' H.
  cbn in *.
  match type of H with
      ?X = ?Y =>
      assert(H' : Trans X c id= Trans Y c id)
  end.
  + rewrite H; trivial.
  + cbn in H'.
    simpl_ids in H'.
    trivial.
Qed.

(** Yoneda embedding is full. *)
Lemma Yoneda_Full (C : Category) : Full_Func (Yoneda C).
Proof.
  intros c c' N.
  exists (Trans (Y_left_to_right C) (c, (((Yoneda C) _o)%object c')) N).
  apply NatTrans_eq_simplify.
  extensionality x; extensionality h.
  transitivity ((((Yoneda C) _o c')%object _a h ∘ (Trans N c)) id)%morphism.
  + cbn; auto.
  + rewrite <- Trans_com.
    cbn; auto.
Qed.

(** Yoneda embedding is indeed an embedding. *)
Definition Yoneda_Emb (C : Category) : Embedding C (Func_Cat (C^op) Type_Cat) :=
{|
  Emb_Func := Yoneda C;
  Emb_Faithful := Yoneda_Faithful C;
  Emb_Full := Yoneda_Full C
|}.

(** Yoneda is conservative of isomorphisms. *)
Theorem Yoneda_Iso (C : Category) : forall (c c' : Obj),
    ((Yoneda C) _o c ≃ (Yoneda C) _o c')%isomorphism → (c ≃ c')%isomorphism.
Proof.
  intros.
  apply (Emb_Conservative _ _ (Yoneda_Emb C) _); trivial.
Qed.

Ltac Yoneda := apply Yoneda_Iso.

(** The dual of Yoneda is conservative of isomorphisms. *)
Theorem CoYoneda_Iso (C : Category) : forall (c c' : Obj),
    ((CoYoneda C) _o c ≃ (CoYoneda C) _o c')%isomorphism → (c ≃ c')%isomorphism.
Proof.
  intros; Yoneda; trivial.
Qed.

Ltac CoYoneda := apply CoYoneda_Iso.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import SSCHPreservation.
Require Import TraceCriterion.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section SSCHCriterion.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Set.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.
  Local Definition hprop__S := hprop trace__S.
  Local Definition hprop__T := hprop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition hsat__S := hsat Source_Semantics.
  Local Definition hsat__T := hsat Target_Semantics.

  Local Definition cmp := compile_whole Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).

  Variable rel : trace__S -> trace__T -> Prop.

  Local Definition adjunction :=  induced_connection rel.

  Local Definition τ' : prop__S -> prop__T := α adjunction.
  Local Definition σ' : prop__T -> prop__S := γ adjunction.

  Local Definition rel_adjunction_law : Adjunction_law τ' σ' := adjunction_law adjunction.

  Lemma τ_mono : monotone τ'.
  Proof. move/Galois_equiv: rel_adjunction_law. by move => [H1 H2]. Qed.

  Definition rel_TC : Prop := rel_TC  compilation_chain
                                   Source_Semantics Target_Semantics
                                   rel.

  Local Definition sCl_σ : hprop__T -> hprop__S := sCl_σ σ'.
  Local Definition sCl_τ : hprop__S -> hprop__T := sCl_τ τ'.

  Local Definition sCl_τhP := sCl_τhP compilation_chain
                                      Source_Semantics Target_Semantics
                                      τ'.

  Local Definition sCl_σhP := sCl_σhP compilation_chain
                                      Source_Semantics Target_Semantics
                                      σ'.

  Lemma sCl_σhP_sCl_τhP : (forall (W : prg__S) (H__T : hprop__T), SSC H__T ->  sCl_σhP W H__T) <->
                          (forall (W : prg__S) (H__S : hprop__S), SSC H__S -> sCl_τhP W H__S).
  Proof.
    split.
    + move => Hσ P H__S ssc_H rsat_source.
      have rsat_sigma_tau : hsat__S P (sCl_σ (sCl_τ H__S)).
      { apply: hsat_upper_closed. exact rsat_source.
        apply: Galois_snd_lift. exact rel_adjunction_law. exact ssc_H. }
      have τ_ssc : SSC (sCl_τ H__S) by apply: sCl_SCH.
      exact (Hσ P (sCl_τ H__S) τ_ssc rsat_sigma_tau).
    + move => Hτ P H__T ssc_H rsat_source.
      have h_ssc: SSC (sCl_σ H__T) by apply: sCl_SCH.
      move: (Hτ P (sCl_σ H__T) h_ssc rsat_source).
      move => HHH. eapply hsat_upper_closed. exact HHH.
      apply: Galois_fst_lift; eauto. exact rel_adjunction_law.
  Qed.

  Theorem rel_TC_sClτSCHP : rel_TC <-> (forall (P : prg__S) (H__S : hprop__S), SSC H__S -> sCl_τhP P H__S).
  Proof.
    setoid_rewrite rel_TC'.
    split.
    - move => Htilde P H H_ssc Hsrc.
      exists (τ' (beh__S P)). split.
      + rewrite /lift. exists (beh__S P).
        split; auto. exact: (Htilde P).
    - move => Hτ W.
      have Hssc: SSC (fun b: prop__S => b ⊆ beh__S W) by firstorder.
      have Hfoo: hsat__S W (fun b: prop__S => b ⊆ beh__S W) by rewrite /hsat__S.
      move: (Hτ W _ Hssc Hfoo).
      move => [b__T [[b__S [H1 H2]] H3]]. subst.
      apply: subset_trans.
      exact H3. by apply: τ_mono.
  Qed.

  Theorem rel_TC_sCl_σRSCHP : rel_TC <-> (forall (W : prg__S) (H__T : hprop__T), SSC H__T ->  sCl_σhP W H__T).
  Proof. by rewrite sCl_σhP_sCl_τhP rel_TC_sClτSCHP. Qed.

End SSCHCriterion.


From Coq Require Import ssreflect.
From stdpp Require Import base gmap.
From iris.proofmode Require Import tactics.
From aneris.aneris_lang.lib Require Import list_proof.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.aneris_lang Require Import aneris_lifting proofmode.
From aneris.examples.crdt.spec Require Import crdt_base crdt_time crdt_events crdt_denot crdt_resources.
From aneris.examples.crdt.oplib Require Import oplib_code.
From aneris.examples.crdt.oplib.spec Require Import model spec.
From aneris.examples.crdt.oplib.examples.pncounter Require Import pncounter_code.

(** A positive-negative counter *)
Section PNCounterCrdt.

  Inductive CtrOp :=
  | Add (z : Z) : CtrOp. (* note we can add a negative number *)

  Definition ctr_payload (op : CtrOp) : Z :=
    match op with
    | Add z => z
    end.

  Global Instance ctr_op_eqdecision : EqDecision CtrOp.
  Proof. solve_decision. Qed.

  Global Instance ctr_op_countable : Countable CtrOp.
  Proof.
    refine {|
      encode op := match op with Add z => encode z end;
      decode n := Add <$> @decode Z _ _ n;
    |}.
    intros []. rewrite decode_encode /=. done.
  Qed.

  Definition CtrSt := Z.
  Context `{!Log_Time}.

  (* The value of a counter is just the sum of the operations' payloads. *)
  Fixpoint ctr_value (s : list (Event CtrOp)) : Z :=
    match s with
    | [] => 0%Z
    | ev :: xs => (ctr_payload ev.(EV_Op) + ctr_value xs)%Z
    end.

  Definition ctr_denot (s : gset (Event CtrOp)) (st : CtrSt) : Prop :=
    st = ctr_value (elements s).

  Global Instance ctr_denot_fun : Rel2__Fun ctr_denot.
  Proof.
    constructor; unfold ctr_denot; intros; subst; done.
  Qed.

  Global Instance ctr_denot_instance : CrdtDenot CtrOp CtrSt := {
    crdt_denot := ctr_denot;
  }.
End PNCounterCrdt.

Section OpPNCounter.

  Context `{!Log_Time}.

  Definition op_ctr_effect st (ev : Event CtrOp) st' :=
    st' = (st + ctr_payload ev.(EV_Op))%Z.

  Lemma op_ctr_effect_fun st : Rel2__Fun (op_ctr_effect st).
  Proof.
    constructor. unfold op_ctr_effect.
    intros a b b' Hb Hb'.
    destruct (EV_Op a) as [z]; simpl in *; subst; auto.
  Qed.

  Lemma ctr_value_singleton ev :
    ctr_value [ev] = ctr_payload (ev.(EV_Op)).
  Proof.
    unfold ctr_value. lia.
  Qed.

  Lemma ctr_value_cons ev l :
    ctr_value (ev :: l) = (ctr_payload ev.(EV_Op) + ctr_value l)%Z.
  Proof.
    simpl. auto.
  Qed.

  Lemma ctr_value_app (l l' : list (Event CtrOp)) :
    ctr_value (l ++ l') = (ctr_value l + ctr_value l')%Z.
  Proof.
    generalize dependent l'.
    induction l as [ | h t Ht]; intros l'; [done |].
    rewrite -app_comm_cons.
    do 2 rewrite ctr_value_cons.
    rewrite (Ht l'). lia.
  Qed.

  Lemma ctr_value_perm (l l' : list (Event CtrOp)) :
    Permutation l l' -> ctr_value l = ctr_value l'.
  Proof.
    generalize dependent l'.
    induction l as [ | h t Ht]; intros l' Hperm.
    - apply Permutation_nil in Hperm; subst; reflexivity.
    - rewrite ctr_value_cons.
      apply Permutation_sym in Hperm.
      pose proof Hperm as Hperm'.
      apply Permutation_vs_cons_inv in Hperm as [l1 [l2 ->]].
      apply Permutation_sym, Permutation_cons_app_inv, Ht in Hperm'.
      rewrite Hperm'.
      do 2 rewrite ctr_value_app.
      rewrite ctr_value_cons.
      lia.
  Qed.

  Lemma ctr_denot_union (s : gset (Event CtrOp)) (ev : Event CtrOp) (res : CtrSt) :
    ⟦ s ⟧ ⇝ res ->
    ev ∉ s ->
    ⟦ s ∪ {[ ev ]} ⟧ ⇝ (res + ctr_payload ev.(EV_Op))%Z.
  Proof.
    simpl. unfold ctr_denot.
    intros -> Hnotin.
    assert (s ## {[ ev ]}) as Hdisj by set_solver.
    pose proof (elements_disj_union s
                                    ({[ev]} : gset (Event CtrOp))
                                    Hdisj) as Hperm.
    apply ctr_value_perm in Hperm. rewrite Hperm.
    by rewrite elements_singleton ctr_value_app ctr_value_singleton.
  Qed.

  Instance op_ctr_effect_coh : OpCrdtEffectCoh op_ctr_effect.
  Proof.
    intros s e st st'.
    intros Hdenot Hnotin. split.
    - intros Heff.
      unfold op_ctr_effect in Heff; subst.
      by apply ctr_denot_union.
    - intros Hdenot'.
      unfold op_ctr_effect.
      pose proof (ctr_denot_union s e st Hdenot Hnotin) as Hunion.
      pose proof (rel2_fun Hdenot' Hunion) as Hequiv.
      apply leibniz_equiv in Hequiv; subst; done.
  Qed.

  Definition op_ctr_init_st := 0%Z.

  Lemma op_ctr_init_st_coh : ⟦ (∅ : gset (Event CtrOp)) ⟧ ⇝ op_ctr_init_st.
  Proof. done. Qed.

  Global Instance op_ctr_model_instance : OpCrdtModel CtrOp CtrSt := {
    op_crdtM_effect := op_ctr_effect;
    op_crdtM_effect_fun := op_ctr_effect_fun;
    op_crdtM_effect_coh := op_ctr_effect_coh;
    op_crdtM_init_st := op_ctr_init_st;
    op_crdtM_init_st_coh := op_ctr_init_st_coh
  }.

End OpPNCounter.

From aneris.examples.crdt.oplib.proof Require Import time.

Section PNCounter_proof.
  Context `{!anerisG M Σ}.

  Context `{!CRDT_Params, !OpLib_Res CtrOp}.

  Definition Ctr_OpLib_Op_Coh := λ (op : CtrOp) v, match op with Add z => v = #z end.

  Lemma Ctr_OpLib_Op_Coh_Inj (o1 o2 : CtrOp) (v : val) :
    Ctr_OpLib_Op_Coh o1 v → Ctr_OpLib_Op_Coh o2 v → o1 = o2.
  Proof. destruct o1; destruct o2; simpl; intros ? ?; simplify_eq; done. Qed.

  Lemma Ctr_OpLib_Coh_Ser (op : CtrOp) (v : val) :
    Ctr_OpLib_Op_Coh op v → Serializable int_serialization v.
  Proof.
    destruct op; rewrite /Ctr_OpLib_Op_Coh; intros ?; simplify_eq; apply _.
  Qed.

  Definition Ctr_OpLib_State_Coh := λ (st : CtrSt) v, v = #st.

  Global Instance Ctr_OpLib_Params : OpLib_Params CtrOp CtrSt :=
  {|
    OpLib_Serialization := int_serialization;
    OpLib_State_Coh := Ctr_OpLib_State_Coh;
    OpLib_Op_Coh := Ctr_OpLib_Op_Coh;
    OpLib_Op_Coh_Inj := Ctr_OpLib_Op_Coh_Inj;
    OpLib_Coh_Ser := Ctr_OpLib_Coh_Ser
  |}.

  Lemma Ctr_init_st_fn_spec : ⊢ init_st_fn_spec pncounter_init_st.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /pncounter_init_st.
    wp_pures.
    iApply "HΦ"; done.
  Qed.

  Lemma Ctr_effect_spec : ⊢ effect_spec pncounter_effect.
  Proof.
    iIntros (addr ev st s log_ev log_st).
    iIntros "!#" (Φ) "(%Hev & %Hst & %Hs & %Hevs) HΦ".
    rewrite /pncounter_effect.
    destruct log_ev as [[op] orig vc].
    destruct Hev as (evpl&evvc&evorig&?&Hevpl&?&?).
    rewrite /OpLib_State_Coh /=  /Ctr_OpLib_State_Coh in Hst.
    simplify_eq/=.
    wp_pures.
    iApply "HΦ"; eauto.
  Qed.

  Lemma Ctr_crdt_fun_spec : ⊢ crdt_fun_spec pncounter_crdt.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /pncounter_crdt.
    wp_pures.
    iApply "HΦ".
    iExists _, _; iSplit; first done.
    iSplit; [iApply Ctr_init_st_fn_spec|iApply Ctr_effect_spec].
  Qed.

  Lemma Ctr_init_spec :
    init_spec (oplib_init
               (s_ser (s_serializer OpLib_Serialization))
               (s_deser (s_serializer OpLib_Serialization))) -∗
    init_spec_for_specific_crdt pncounter_init.
  Proof.
    iIntros "#Hinit" (repId addr addrs_val).
    iIntros (Φ) "!# (%Haddrs & %Hrepid & Hprotos & Hskt & Hfr & Htoken) HΦ".
    rewrite /pncounter_init.
    wp_pures.
    wp_apply ("Hinit" with "[$Hprotos $Htoken $Hskt $Hfr]").
    { do 2 (iSplit; first done). iApply Ctr_crdt_fun_spec; done. }
    iIntros (get update) "(HLS & #Hget & #Hupdate)".
    wp_pures.
    iApply "HΦ"; eauto.
  Qed.

End PNCounter_proof.