Require Import Min.

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

Open Scope pred.

(* Various utility lemmas *)

Lemma later_level : forall k1 k2,
  laterR k1 k2 ->
  level k2 < level k1.
Proof.
  intros k1 k2 H; induction H.
  do 2 rewrite K.knot_level.
  hnf in H.
  rewrite K.knot_age1 in H.
  destruct (K.unsquash x).
  destruct n; try discriminate.
  inv H.
  rewrite K.unsquash_squash; simpl.
  auto with arith.
  apply lt_trans with (level y); auto.
Qed.

Lemma nec_level : forall k1 k2,
  necR k1 k2 ->
  level k2 <= level k1.
Proof.
  intros k1 k2 H; induction H.
  do 2 rewrite K.knot_level.
  hnf in H.
  rewrite K.knot_age1 in H.
  destruct (K.unsquash x).
  destruct n; try discriminate.
  inv H.
  rewrite K.unsquash_squash; simpl.
  auto with arith. auto.
  apply le_trans with (level y); auto.
Qed.

Lemma age1_level : forall p1 p2,
  age1 p1 = Some p2 ->
  level p1 = S (level p2).
Proof.
  intros.
  do 2 rewrite K.knot_level.
  rewrite K.knot_age1 in H.
  remember (K.unsquash p1).
  icase p.
  icase n.
  inv H.
  rewrite K.unsquash_squash.
  simpl.
  trivial.
Qed.

Fixpoint ageN (n : nat) (p1 p2 : prog) : Prop :=
  match n with
   | 0 => p1 = p2
   | S n' => exists p', age p1 p' /\ ageN n' p' p2
  end.

Lemma ageN_det: forall n p1 p2 p2',
  ageN n p1 p2 ->
  ageN n p1 p2' ->
  p2 = p2'.
Proof.
  induction n; intros.
  compute in *. congruence.
  destruct H as [px [? ?]]. destruct H0 as [px' [? ?]].
  red in H, H0.
  rewrite H in H0.
  inv H0.
  eapply IHn; eauto.
Qed.
Implicit Arguments ageN_det.

Lemma ageN_necR: forall p1 p2,
  (exists n, ageN n p1 p2) = necR p1 p2.
Proof.
  intros. apply prop_ext. split; intro.
  destruct H. revert p1 H.
  induction x; intros.
  compute in H. subst. auto.
  destruct H as [? [? ?]].
  apply rt_trans with x0. apply rt_step. trivial.
  eapply IHx; eauto.
  induction H.
  exists 1. exists y. intuition.
  exists 0. red. auto.
  destruct IHclos_refl_trans1 as [n1 ?].
  destruct IHclos_refl_trans2 as [n2 ?].
  exists (n1 + n2).
  clear H H0. revert x y z n2 H1 H2.
  induction n1; intros.
  inv H1.
  apply H2.
  simpl in *.
  destruct H1 as [px [? ?]].
  exists px.
  split. trivial.
  eapply IHn1; eauto.
Qed.

Lemma ageN_level: forall n p1 p2,
  ageN n p1 p2 ->
  level p1 = level p2 + n.
Proof.
  unfold prog. induction n; intros.
  inv H. auto.
  inv H. destruct H0.
  apply age1_level in H.
  spec IHn x p2 H0. omega.
Qed.

Let closedR (w1 w2:world) := fst w1 = fst w2.
Program Definition closedM : @modality world _ := exist _ closedR _.
Next Obligation.
  split; repeat intro; unfold closedR in *;
    destruct x as [? ?]; destruct y as [? ?];
      destruct z as [? ?]; simpl in *; intuition subst.
  hnf in H; simpl in H.
  exists  (p,s1); simpl; auto.
  hnf; simpl.
  destruct (@age1 _ K.ageable_knot p0).
  inv H. auto. discriminate.
  hnf in H0; simpl in H0.
  exists (p1,s); simpl; auto.
  hnf; simpl in *.
  destruct (@age1 _ K.ageable_knot p1).
  inv H0. auto. discriminate.
Qed.
Definition closed := box closedM.

Inductive setR v x : relation world :=
  intro_setR : forall p r r',
    r' = r#v <- x ->
    setR v x (p,r) (p,r').

Program Definition setM v x : @modality world _ := setR v x.
Next Obligation.
  split; hnf; intros.
  inv H0.
  hnf in H; simpl in H.
  case_eq (age1 p); intros; unfold prog in *;
    rewrite H0 in H; try discriminate.
  inv H.
  exists (p0,r).
  constructor; auto.
  hnf. simpl. rewrite H0. auto.
  inv H.
  destruct z.
  hnf in H0; simpl in H0.
  case_eq (age1 p0); unfold prog in *; intros;
    rewrite H in H0.
  inv H0.
  exists (p0,(r#v <- x)).
  hnf. simpl. rewrite H. auto.
  constructor; auto.
  discriminate.
Qed.

Program Definition world_op (Pp : pred prog) (Pr : store -> Prop) : pred world :=
  fun pr => let (p,r) := pr in Pp p /\ Pr r.
Next Obligation.
  unfold hereditary; intros.
  destruct a as [p r].
  destruct a' as [p' r'].
  hnf in H.
  simpl in H.
  rewrite K.knot_age1 in H.
  case_eq (K.unsquash p); intros; rewrite H1 in H.
  destruct n; try discriminate.
  inv H.
  intuition.
  destruct Pp as [Pp HPp].
  simpl.
  simpl in H.
  eapply HPp.
  2: apply H.
  hnf.
  rewrite K.knot_age1.
  rewrite H1; auto.
Qed.

Definition store_op (Pr : store -> Prop) := world_op TT Pr.
Definition prog_op (X:pred prog) :=  world_op X (fun _ => True).

Lemma worldNec_unfold : forall p r p' r',
  @necR world _ (p,r) (p',r') <->
  necR p p' /\ r = r'.
Proof.
  intros; split; intro H.
  remember (p,r) as w1.
  remember (p',r') as w2.
  revert p r p' r' Heqw1 Heqw2.
  induction H; simpl; intros; subst.
  hnf in H; simpl in H.
  unfold prog in *.
  case_eq (age1 p); intros; rewrite H0 in H.
  inv H. intuition.
  discriminate.
  inv Heqw2. intuition.
  destruct y as [p2 r2].
  assert (necR p p2 /\ r = r2). auto.
  assert (necR p2 p' /\ r2 = r'). auto.
  intuition; try congruence.
  eapply rt_trans; eauto.
  intuition; subst. induction H0.
  apply rt_step; hnf; simpl. hnf in H.
  unfold prog in *. rewrite H; auto.
  apply rt_refl.
  eapply rt_trans; eauto.
Qed.

Lemma worldLater_unfold : forall p r p' r',
  @laterR world _ (p,r) (p',r') <->
  laterR p p' /\ r = r'.
Proof.
  intros; split; intro H.
  remember (p,r) as w1.
  remember (p',r') as w2.
  revert p r p' r' Heqw1 Heqw2.
  induction H; simpl; intros; subst.
  hnf in H; simpl in H.
  unfold prog in *.
  case_eq (age1 p); intros; rewrite H0 in H.
  inv H. intuition.
  apply t_step; auto.
  discriminate.
  destruct y as [p2 r2].
  assert (laterR p p2 /\ r = r2). auto.
  assert (laterR p2 p' /\ r2 = r'). auto.
  intuition; try congruence.
  eapply t_trans; eauto.
  intuition; subst.
  induction H0. apply t_step.
  hnf; simpl. hnf in H. unfold prog in *. rewrite H. auto.
  eapply t_trans; eauto.
Qed.

Definition instr_approx_rel (n:nat) (i1 i2:instruction) : Prop :=
  fmap_instr (K.approx n) i1 = fmap_instr (K.approx n) i2.

Lemma intro_instr_approx_rel : forall m n i,
  m >= n ->
  instr_approx_rel n i (fmap_instr (K.approx m) i).
Proof.
  intros; hnf.
  induction i; simpl; auto.
  replace (K.approx n (K.approx m x))
    with (K.approx n x); auto.
  change (K.approx n x = (K.approx n oo K.approx m) x).
  replace m with ((m-n)+n) by omega.
  rewrite <- K.approx_approx1; auto.
  rewrite <- IHi1.
  rewrite <- IHi2.
  auto.
  rewrite <- IHi1.
  rewrite <- IHi2.
  auto.
Qed.

Lemma collapse_instr_approx : forall n m i,
  fmap_instr (K.approx n) (fmap_instr (K.approx m) i) =
  fmap_instr (K.approx (min n m)) i.
Proof.
  intros. induction i; simpl; auto.
  destruct (le_gt_dec n m).
  rewrite min_l; auto.
  assert ((m-n)+n = m) by omega.
  rewrite <- H.
  pattern (K.approx n) at 2.
  rewrite (K.approx_approx1 (m-n) n).
  unfold compose. rewrite H. auto.
  rewrite min_r.
  assert ((n-m)+m = n) by omega.
  rewrite <- H.
  pattern (K.approx m) at 2.
  rewrite (K.approx_approx2 (n-m) m).
  unfold compose. rewrite H. auto.
  omega.
  rewrite IHi1. rewrite IHi2. auto.
  rewrite IHi1. rewrite IHi2. auto.
Qed.

Lemma collapse_instr_approx_same : forall n  i,
  fmap_instr (K.approx n) (fmap_instr (K.approx n) i) =
  fmap_instr (K.approx n) i.
Proof.
  intros.
  rewrite collapse_instr_approx.
  apply min_case; auto.
Qed.

Inductive stack_approx_rel (n:nat) : stack -> stack -> Prop :=
  | stack_approx_nil : stack_approx_rel n nil nil
  | stack_approx_cons : forall i i' stk stk',
     instr_approx_rel n i i' ->
     stack_approx_rel n stk stk' ->
     stack_approx_rel n (i::stk) (i'::stk').

Lemma stack_approx_rel_refl : forall n stk,
  stack_approx_rel n stk stk.
Proof.
  induction stk; constructor; auto.
  hnf; auto.
Qed.

Lemma stack_approx_downward : forall n m s1 s2,
  n <= m ->
  stack_approx_rel m s1 s2 ->
  stack_approx_rel n s1 s2.
Proof.
  do 3 intro.
  revert n m.
  induction s1; intros.
  inversion H0.
  constructor.
  inversion H0.
  subst.
  constructor.
  replace n with (min n m).
  red.
  do 2 rewrite <- collapse_instr_approx.
  rewrite H3.
  trivial.
  apply min_l; trivial.
  apply IHs1 with m; trivial.
Qed.

Lemma nec_prog_lookup : forall p p' l i,
  necR p p' ->
  prog_lookup p l = Some i ->
  prog_lookup p' l = Some (fmap_instr (K.approx (level p')) i).
Proof.
  unfold prog_lookup; intros.
  revert l i H0. induction H; simpl; intros; auto.
  hnf in H.
  rewrite K.knot_age1 in H.
  destruct (K.unsquash x). destruct n; try discriminate.
  simpl in *.
  rewrite K.knot_level.
  inv H.
  rewrite K.unsquash_squash. simpl.
  unfold KnotInput.fmap.
  erewrite fmap_eqn; eauto.
  rewrite H0. f_equal.
  rewrite K.knot_level.
  case_eq (K.unsquash x); intros.
  rewrite H in H0. simpl in H0.
  apply K.unsquash_approx in H.
  generalize H0; intro.
  rewrite H in H0.
  unfold KnotInput.fmap in H0.
  erewrite fmap_eqn in H0; eauto.
  simpl; congruence.
  replace (fmap_instr (K.approx (level z)) i)
    with (fmap_instr (K.approx (level z))
          (fmap_instr (K.approx (level y)) i)).
  apply IHclos_refl_trans2.
  apply IHclos_refl_trans1. auto.
  rewrite collapse_instr_approx.
  rewrite min_l; auto.
  apply nec_level; auto.
Qed.

Lemma step_prog: forall p1 p2 r1 s1 r2 s2,
  step p1 p2 r1 s1 r2 s2 ->
  p1 = p2 \/ age p1 p2.
Proof.
  intros.
  inv H; auto.
Qed.

Lemma step_prog_levels : forall p p' r s r' s',
  step p p' r s r' s' ->
  level p' <= level p.
Proof.
  intros.
  apply step_prog in H. destruct H.
  subst p'. trivial.
  do 2 rewrite K.knot_level.
  hnf in H; simpl in H.
  rewrite K.knot_age1 in H.
  destruct (K.unsquash p).
  icase n.
  inv H.
  rewrite K.unsquash_squash; simpl.
  auto.
Qed.

Lemma step_approxprog: forall n p1 p2 p1' p2' r1 s1 s1' r2 s2,
  step p1 p2 r1 s1 r2 s2 ->
  ageN n p1 p1' ->
  ageN n p2 p2' ->
  stack_approx_rel (S (level p1')) s1 s1' ->
  exists s2',
    step p1' p2' r1 s1' r2 s2' /\
    stack_approx_rel (S (level p2')) s2 s2'.
Proof.
  unfold prog.
  intros.
  inversion H; subst.
(* assert *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H2. subst.
  red in H9. simpl in H9. inv H9.
  split.
  constructor.
  assert (K.approx (S (level p1')) P (p1', r2)).
    rewrite K.approx_spec. simpl.
    rewrite <- (nec_useless P) in H3. spec H3 (p1', r2).
    spec H3. simpl. rewrite worldNec_unfold. split; trivial.
    rewrite <- ageN_necR. exists n. trivial.
    split; trivial. omega.
  rewrite H5 in H4.
  rewrite K.approx_spec in H4. destruct H4. trivial.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* getlab *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H5; subst.
  split. constructor; trivial.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* fetch1 *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H6; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* fetch2 *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H6; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* cons *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H7; subst.
  split. constructor; trivial.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* seq *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists ((i'1_1 ;; (i'1_2 ;; i'2)) :: stk').
  inversion H5; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
  red. simpl. congruence.
(* if1 *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists ((i'1_1 ;; i'2) :: stk').
  inversion H6; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
  red. simpl. congruence.
(* if2 *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists ((i'1_2 ;; i'2) :: stk').
  inversion H6; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
  red. simpl. congruence.
(* call *)
  assert (age p1' p2').
    clear - H5 H0 H1. revert p1 p1' p2 p2' H0 H1 H5.
    induction n; intros; simpl in H0, H1.
    subst p1' p2'. trivial.
    destruct H0 as [px [? ?]]. destruct H1 as [px' [? ?]]. unfold prog in *.
    red in H, H5. rewrite H in H5. inv H5.
    eapply IHn; eauto.
  unfold prog in *.
  icase s1'. inversion H2.
  icase i0; inversion H2; disc. subst.
  icase i0_1.
  inversion H10. subst v0.
  exists ( ((fmap_instr (K.approx (level p1')) i') ;; instr_assert FF) :: i0_2 :: s1').
  split. econstructor; eauto.
  apply (nec_prog_lookup p1 p1' l i'); trivial.
  rewrite <- ageN_necR. exists n. trivial.
  apply age_level in H6.
  constructor.
  red. simpl.
  rewrite collapse_instr_approx. rewrite min_l. trivial. omega.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* return *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists stk'.
  inversion H5; subst.
  split. constructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  trivial.
Qed.

Lemma stepstar_prog_levels : forall p p' r s r' s',
  stepstar p p' r s r' s' ->
  level p' <= level p.
Proof.
  intros; induction H; auto.
  apply le_trans with (level p'); auto.
  eapply step_prog_levels; eauto.
Qed.

Lemma stepstar_approxprog: forall n p1 p2 p1' p2' r1 s1 s1' r2 s2,
  stepstar p1 p2 r1 s1 r2 s2 ->
  ageN n p1 p1' ->
  ageN n p2 p2' ->
  stack_approx_rel (S (level p1')) s1 s1' ->
  exists s2',
    stepstar p1' p2' r1 s1' r2 s2' /\
    stack_approx_rel (S (level p2')) s2 s2'.
Proof.
  do 11 intro.
  apply stepstar_stepN in H.
  destruct H as [m ?].
  revert n p1 p2 p1' p2' r1 s1 s1' r2 s2 H.
  induction m; intros.
  inversion H; subst.
  exists s1'.
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  split. constructor.
  apply stack_approx_downward with (S (level p1')). omega.
  trivial.
  inversion H; subst.
  assert (exists p'2, ageN n p' p'2).
    apply step_prog in H4.
    destruct H4.
    subst p'. exists p1'. trivial.
    apply stepN_stepstar in H5.
    apply stepN_stepstar in H.
    apply stepstar_prog_levels in H.
    apply stepstar_prog_levels in H5.
    apply ageN_level in H1.
    apply ageN_level in H0.
    apply age_level in H3.
    assert (level p' >= n) by (unfold prog in *; omega).
    clear -H4. revert p' H4.
    induction n; intros.
    exists p'. red. trivial.
    rewrite K.knot_level in H4.
    remember (K.unsquash p'). destruct p. simpl in H4.
    destruct n0. omegac.
    spec IHn (K.squash (n0, f)). spec IHn.
    rewrite K.knot_level. rewrite K.unsquash_squash.
    simpl. omega.
    destruct IHn as [px ?].
    exists px. exists (K.squash (n0,f)).
    split; trivial.
    red. rewrite K.knot_age1.
    rewrite <- Heqp. trivial.
  destruct H3 as [p'2 ?].
  destruct (step_approxprog _ _ _ _ _ _ _ _ _ _ H4 H0 H3 H2) as [sx [? ?]].
  spec IHm n p' p2 p'2 p2'.
  spec IHm s' i' sx r2 s2.
  spec IHm H5 H3 H1 H7.
  destruct IHm as [sx' [? ?]].
  exists sx'.
  split; trivial.
  econstructor 2; eauto.
Qed.

Program Definition agedfrom {A} `{ageable A} (x:A) : pred A := necR x.
Next Obligation.
  unfold hereditary; intros.
  apply rt_trans with a; auto.
  apply rt_step; auto.
Qed.

(* The next two also maybe can be combined *)
(*
Lemma safe_approx : forall p n r s s',
  level p < n ->
  stack_approx_rel n s s' ->
  safe p r s ->
  safe p r s'.
Proof.
  repeat intro.
  apply stepstar_stepN in H2.
  destruct H2 as [x H2].
  revert p n r s s' H H0 H1 p' s'0 k' H2.
  induction x; intros.
  inv H2.
  cut (step_or_halt p' s'0 s).
  intros.
  inv H2.
  cut (level p'0 < n); intros.
  generalize H3; intros.
  eapply step_approx in H3; eauto.
  destruct H3 as [s'' [? ?]].
  econstructor; eauto.
  apply le_lt_trans with (level p'); auto.
  eapply step_prog_levels; eauto.
  inv H0.
  constructor.
  apply H1; constructor.

  inv H2.
  cut (step_or_halt p r s).
  intros.
  inv H2.
  cut (level p'1 < n); intros.
  generalize H3; intros.
  eapply step_approx with (n:=n) in H3; eauto.
  destruct H3 as [s'' [? ?]].
  assert (s'1 = r' /\ i' = s'' /\ p'0 = p'1).
  eapply step_deterministic; eauto.
  decompose [and] H8; subst; clear H8.
  revert H5; eapply IHx; eauto.
  repeat intro.
  eapply H1.
  econstructor; eauto.
  apply le_lt_trans with (level p); auto.
  eapply step_prog_levels; eauto.
  inv H0.
  inv H4.
  apply H1.
  constructor.
Qed.

Lemma ev_halts_approx : forall p n r s s',
  level p < n ->
  stack_approx_rel n s s' ->

  eventually_halts p r s ->
  eventually_halts p r s'.
Proof.
  repeat intro.
  destruct H1 as [pz [rz ?]].
  destruct (stepstar_approx _ _ _ _ _ _ _ _  H H0 H1)
    as [z [? ?]].
  exists pz. exists rz.
  inv H3.
  auto.
Qed.

Lemma step_approx :
  forall n p1 p2 s1 s1' s2 r1 r2,
    level p2 < n ->
    stack_approx_rel n s1 s2 ->
    step p1 p2 r1 s1 r2 s1' ->
    exists s2',
      step p1 p2 r1 s2 r2 s2' /\
      stack_approx_rel n s1' s2'.
Proof.
  intros. inv H1; inv H0.

  (* step assert *)
  hnf in H4.
  destruct i'; inv H4.
  destruct i'1; inv H1.
  exists (i'2::stk'); split.
  apply step_assert.
  assert ((K.approx n a) (p2,r2)).
  rewrite <- H4.
  rewrite K.approx_spec.
  simpl; intuition.
  rewrite K.approx_spec in H0.
  simpl in H2; intuition.
  constructor; auto.

  (* step getlabel *)
  hnf in H3; destruct i'; inv H3.
  destruct i'1; inv H1.
  exists (i'2 :: stk'); split;
    econstructor; eauto.

  (* step fetch field 0 *)
  hnf in H4; destruct i'; inv H4.
  destruct i'1; inv H1.
  exists (i'2 :: stk'); split;
    econstructor; eauto.

  (* step fetch field 1 *)
  hnf in H4; destruct i'; inv H4.
  destruct i'1; inv H1.
  exists (i'2 :: stk'); split;
    econstructor; eauto.

  (* step cons *)
  hnf in H5; destruct i'; inv H5.
  destruct i'1; inv H1.
  exists (i'2 :: stk'); split;
    econstructor; eauto.

  (* step seq *)
  hnf in H3; destruct i'; inv H3.
  destruct i'1; inv H1.
  exists ((i'1_1 ;; i'1_2 ;; i'2) :: stk'); split.
  econstructor; eauto.
  constructor; auto.
  hnf; simpl.
  f_equal; auto.
  f_equal; auto.

  (* step if nil 1 *)
  hnf in H4; destruct i'; inv H4.
  destruct i'1; inv H1.
  exists ((i'1_1 ;; i'2) :: stk'); split;
    econstructor; eauto.
  hnf; simpl; f_equal; auto.

  (* step if nil 2 *)
  hnf in H4; destruct i'; inv H4.
  destruct i'1; inv H1.
  exists ((i'1_2 ;; i'2) :: stk'); split;
    econstructor; eauto.
  hnf; simpl; f_equal; auto.

  (* step call *)
  hnf in H6; destruct i'0; inv H6.
  destruct i'0_1; inv H1.
  exists ((i' ;; instr_assert FF):: i'0_2 :: stk'); split;
    econstructor; eauto.
  constructor; auto.
  constructor; auto.

  (* step return *)
  hnf in H3; destruct i'; inv H3.
  destruct i'1; inv H1.
  exists stk'; split.
  econstructor.
  auto.
Qed.
*)
(* end nagging suspicion *)
(*
Lemma stepstar_approx :
  forall n p1 p2 s1 s1' s2 r1 r2,
    level p1 < n ->
    stack_approx_rel n s1 s2 ->
    stepstar p1 p2 r1 s1 r2 s1' ->
    exists s2',
      stepstar p1 p2 r1 s2 r2 s2' /\
      stack_approx_rel n s1' s2'.
Proof.
  intros.
  apply stepstar_stepN in H1.
  destruct H1 as [x H1].
  revert n p1 p2 s1 s1' s2 r1 r2 H H0 H1.
  induction x; intros; inv H1.
  exists s2; split; auto.
  constructor.
  assert (level p' < n).
  apply le_lt_trans with (level p1); auto.
  eapply step_prog_levels; eauto.
  destruct (step_approx _ _ _ _ _ _ _ _ H1 H0 H3)
    as [z [? ?]].
  destruct (IHx _ _ _ _ _ _ _ _ H1 H5 H4)
    as [z' [? ?]].
  exists z'; split; auto.
  eapply stepstar_S; eauto.
Qed.
*)


Require Import Coq.Strings.String Coq.Classes.RelationClasses.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Wf.
Require Import Crypto.Reflection.Relations.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.
Require Import Crypto.Util.Notations.
Local Open Scope ctype_scope.
Local Open Scope expr_scope.

Section language.
  Context {base_type_code : Type}
          {interp_base_type1 interp_base_type2 : base_type_code -> Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          (interp_op1 : forall src dst, op src dst -> interp_flat_type interp_base_type1 src -> interp_flat_type interp_base_type1 dst)
          (interp_op2 : forall src dst, op src dst -> interp_flat_type interp_base_type2 src -> interp_flat_type interp_base_type2 dst)
          {R : forall t, interp_base_type1 t -> interp_base_type2 t -> Prop}
          (Rop : forall src dst op sv1 sv2, interp_flat_type_rel_pointwise R sv1 sv2
                                            -> interp_flat_type_rel_pointwise
                                                 R (interp_op1 src dst op sv1) (interp_op2 src dst op sv2)).

  Local Notation exprf1 := (@exprf base_type_code op interp_base_type1).
  Local Notation exprf2 := (@exprf base_type_code op interp_base_type2).
  Local Notation expr1 := (@expr base_type_code op interp_base_type1).
  Local Notation expr2 := (@expr base_type_code op interp_base_type2).
  Local Notation Expr := (@Expr base_type_code op).
  Local Notation interpf1 := (@interpf base_type_code interp_base_type1 op interp_op1).
  Local Notation interpf2 := (@interpf base_type_code interp_base_type2 op interp_op2).
  Local Notation interp1 := (@interp base_type_code interp_base_type1 op interp_op1).
  Local Notation interp2 := (@interp base_type_code interp_base_type2 op interp_op2).
  Local Notation Interp1 := (@Interp base_type_code interp_base_type1 op interp_op1).
  Local Notation Interp2 := (@Interp base_type_code interp_base_type2 op interp_op2).

  Lemma interp_flat_type_rel_pointwise_flatten_binding_list
        {t x x' T e1 e2}
        (Hpointwise : interp_flat_type_rel_pointwise R e1 e2)
        (HIn : List.In (existT (fun t : base_type_code => (interp_base_type1 t * interp_base_type2 t)%type) t (x, x')%core)
                       (flatten_binding_list (t:=T) e1 e2))
    : R t x x'.
  Proof.
    induction T; simpl in *; try tauto; [ | rewrite List.in_app_iff in HIn ];
      repeat first [ progress destruct_head or
                   | progress destruct_head False
                   | progress destruct_head and
                   | progress inversion_sigma
                   | progress inversion_prod
                   | progress subst
                   | solve [ eauto ] ].
  Qed.

  Local Hint Resolve List.in_app_or List.in_or_app interp_flat_type_rel_pointwise_flatten_binding_list.

  Section wf.
    Lemma interpf_wff
             {t} {e1 : exprf1 t} {e2 : exprf2 t}
             {G}
             (HG : forall t x x',
                 List.In (existT (fun t : base_type_code => (interp_base_type1 t * interp_base_type2 t)%type) t (x, x')%core) G
                 -> R t x x')
             (Rwf : wff G e1 e2)
    : interp_flat_type_rel_pointwise R (interpf1 e1) (interpf2 e2).
    Proof.
      induction Rwf; simpl; auto.
      repeat match goal with
             | [ H : context[List.In _ (_ ++ _)] |- _ ]
               => setoid_rewrite List.in_app_iff in H
             end.
      match goal with
      | [ H : _ |- _ ]
        => apply H; intros; destruct_head' or; solve [ eauto ]
      end.
    Qed.

    Local Hint Resolve interpf_wff.

    Lemma interp_wf
             {t} {e1 : expr1 t} {e2 : expr2 t}
             (Rwf : wf e1 e2)
    : interp_type_rel_pointwise R (interp1 e1) (interp2 e2).
    Proof.
      destruct Rwf; simpl; repeat intro; eauto.
    Qed.

    Lemma InterpWf
             {t} {e : Expr t}
             (Rwf : Wf e)
    : interp_type_rel_pointwise R (Interp1 e) (Interp2 e).
    Proof.
      unfold Interp, Wf in *; apply interp_wf; simpl; intuition.
    Qed.
  End wf.
End language.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils.

Set Implicit Arguments.

Reserved Notation " e '⇢' x " (at level 58).
Reserved Notation " e [ v / x ] " (at level 57, v at level 0, x at level 0,
                                   left associativity, format "e [ v / x ]").
Reserved Notation " e ⦃  x '⇠' v ⦄ " (at level 57, v at level 0, x at level 0, left associativity).

Section env.

  Variable (X Y : Type) (X_eq_dec : eqdec X) (Y_default : Y).

  Definition env := X -> Y.

  Implicit Type e : env.

  Definition get_env e x := e x.

  Definition set_env e x v : env := fun y => if X_eq_dec x y then v else e y.

  Definition nil_env : env := fun _ => Y_default.

  Fact get_set_env_eq e v p q : p = q -> get_env (set_env e p v) q = v.
  Proof. intros []; unfold set_env, get_env; destruct (X_eq_dec p p) as [ | [] ]; auto. Qed.

  Fact get_set_env_neq e v p q : p <> q -> get_env (set_env e p v) q = get_env e q.
  Proof. simpl; intros H; unfold set_env, get_env; destruct (X_eq_dec p q); auto; destruct H; auto. Qed.

End env.

Arguments nil_env {X}.

Opaque get_env.
Opaque set_env.

Local Notation " e ⇢ x " := (@get_env _ _ e x).
Local Notation " e ⦃  x ⇠ v ⦄ " := (@set_env _ _ _ e x v).

(* find the value of x inside the environment t *)

Ltac find_val x t :=
  match t with
    | ?s⦃x⇠?v⦄ => v
    | ?s⦃_⇠_⦄ => find_val x s
  end.

Tactic Notation "rew" "env" :=
  repeat once lazymatch goal with
    |              |- context[ _⦃ ?x⇠_⦄⇢?x ] => rewrite get_set_env_eq  with (1 := eq_refl x)
    | _ : ?x = ?y  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?y = ?x  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?x <> ?y |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    | _ : ?y <> ?x |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    |              |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y);
                                                  [ | discriminate ]
  end; auto.

(*
Tactic Notation "rew" "envi" :=
  repeat once lazymatch goal with
    | |- context f[ _[_/?l]#>?l ] => rewrite get_set_env_eq with (x := l)
    | _ : ?l <> ?m |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m)
    | _ : ?m <> ?l |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m)
    | |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m); [ | discriminate ]
  end; auto.
*)

Tactic Notation "rew" "env" "in" hyp(H) := revert H; rew env; intros H.


Require Import Common
        ADTNotation.BuildADT ADTRefinement.Core
        ADTRefinement.SetoidMorphisms.

(* A notation-friendly version of the setoid morphisms
   infrastructure for ADT refinement. *)

Theorem refineADT_BuildADT_Rep consSigs methSigs oldRep newRep
      (AbsR : oldRep -> newRep -> Prop)
: @respectful_heteroT _ _ _ _
      (fun oldCons newCons =>
         forall consIdx,
           @refineConstructor oldRep newRep AbsR
                          _
                          (getConsDef oldCons consIdx)
                          (getConsDef newCons consIdx))
      (fun x y => @respectful_heteroT _ _ _ _
                    (fun oldMeth newMeth =>
                       forall methIdx,
                         @refineMethod oldRep newRep AbsR _ _
                                         (getMethDef oldMeth methIdx)
                                         (getMethDef newMeth methIdx))
                    (fun m m' => refineADT))
     (@BuildADT oldRep consSigs methSigs)
     (@BuildADT newRep consSigs methSigs).
 Proof.
   unfold Proper, respectful_heteroT; intros.
   let A := match goal with |- refineADT ?A ?B => constr:(A) end in
   let B := match goal with |- refineADT ?A ?B => constr:(B) end in
   eapply (@refinesADT _ A B AbsR);
     unfold id, pointwise_relation in *; simpl in *; intros; eauto.
 Qed.

Lemma refineADT_BuildADT_Both
      rep consigs methSigs
: forall oldCons newCons,
    (forall consIdx, @refineConstructor _ _ eq _
                                   (getConsDef oldCons consIdx)
                                   (getConsDef newCons consIdx))
    -> forall oldMeth newMeth,
         (forall methIdx, @refineMethod _ _ eq _ _
                                         (getMethDef oldMeth methIdx)
                                         (getMethDef newMeth methIdx))
         -> refineADT (@BuildADT rep consigs methSigs oldCons oldMeth)
                      (@BuildADT rep consigs methSigs newCons newMeth).
  intros; eapply refineADT_BuildADT_Rep; eauto; reflexivity.
Qed.

(*Add Parametric Morphism rep consigs methSigs
: (@BuildADT rep consigs methSigs)
    with signature
    (fun oldCons newCons =>
       forall consIdx, @refineConsator _ _ eq _
                                  (getConsDef oldCons consIdx)
                                  (getConsDef newCons consIdx))
      ==> (fun oldMeth newMeth =>
             forall methIdx, @refineMetherver _ _ eq _ _
                                         (getMethDef oldMeth methIdx)
                                         (getMethDef newMeth methIdx))
      ==> refineADT
      as refineADT_BuildADT_Both.
Proof.
  intros; apply refineADT_BuildADT_Both'.
Qed.*)


Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs.object.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope Z.
Local Open Scope logic.

Definition object_invariant := list Z -> val -> mpred.

Definition tobject := tptr (Tstruct _object noattr).

Definition reset_spec (instance: object_invariant) :=
  WITH self: val, history: list Z
  PRE [ tobject]
          PROP ()
          PARAMS (self)
          SEP (instance history self)
  POST [ tvoid ]
          PROP() RETURN () SEP(instance nil self).

Definition twiddle_spec (instance: object_invariant) :=
  WITH self: val, i: Z, history: list Z
  PRE [ tobject, tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 history <= Int.max_signed / 4)
          PARAMS (self; Vint (Int.repr i))
          SEP (instance history self)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 history < v <= 2* fold_right Z.add 0 (i::history))
          RETURN (Vint (Int.repr v))
          SEP(instance (i::history) self).

Definition object_methods (instance: object_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val,
  !! readable_share sh &&
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset,twiddle) mtable.

Lemma object_methods_local_facts: forall instance p,
  object_methods instance p |-- !! isptr p.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.
entailer!.
Qed.
#[export] Hint Resolve object_methods_local_facts : saturate_local.

Definition object_mpred (history: list Z) (self: val) : mpred :=
  EX instance: object_invariant, EX mtable: val,
       (object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self*
     instance history self).

Definition foo_invariant : object_invariant :=
  (fun (history: list Z) p =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 history)))) p
      *  malloc_token Ews (Tstruct _foo_object noattr) p).

Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () PARAMS() GLOBALS (gv)
    SEP (mem_mgr gv; object_methods foo_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () RETURN (p)
     SEP (mem_mgr gv; object_mpred nil p; object_methods foo_invariant (gv _foo_methods)).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     EX i:Z, PROP(0<=i<=6) RETURN (Vint (Int.repr i)) SEP(TT).

Definition Gprog : funspecs :=   ltac:(with_library prog [
    foo_reset_spec; foo_twiddle_spec; make_foo_spec; main_spec]).

Lemma object_mpred_i:
  forall (history: list Z) (self: val) (instance: object_invariant) (mtable: val),
    object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self *
     instance history self
    |-- object_mpred history self.
Proof.
intros. unfold object_mpred. Exists instance mtable; auto.
Qed.

Lemma body_foo_reset: semax_body Vprog Gprog f_foo_reset foo_reset_spec.
Proof.
unfold foo_reset_spec, foo_invariant, reset_spec.
start_function.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
entailer!.
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_twiddle: semax_body Vprog Gprog f_foo_twiddle foo_twiddle_spec.
Proof.
unfold foo_twiddle_spec, foo_invariant, twiddle_spec.
start_function.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
forward.  (* return d+i; *)
simpl.
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
Exists (2 * fold_right Z.add 0 history + i).
simpl;
entailer!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!.
Qed.

Lemma split_object_methods:
  forall instance m,
    object_methods instance m |-- object_methods instance m * object_methods instance m.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.

Exists (fst (slice.cleave sh)) reset twiddle.
Exists (snd (slice.cleave sh)) reset twiddle.
rewrite (split_func_ptr' (reset_spec instance) reset) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddle) at 1.
entailer!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

Lemma body_make_foo: semax_body Vprog Gprog f_make_foo make_foo_spec.
Proof.
unfold make_foo_spec.
start_function.
forward_call (Tstruct _foo_object noattr, gv).
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _foo_object noattr) p;
          data_at_ Ews (Tstruct _foo_object noattr) p;
          object_methods foo_invariant (gv _foo_methods))).
*
change (Memory.EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!.
*
forward_call 1.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &foo_methods; *)
forward. (* p->data = 0; *)
forward. (* return (struct object * ) p; *)
Exists p.
unfold object_mpred.
Exists foo_invariant (gv _foo_methods).
sep_apply (split_object_methods foo_invariant (gv _foo_methods)).
unfold foo_invariant at 4.
entailer!.
simpl.
unfold_data_at (field_at _ _ nil _ p).
cancel.
unfold withspacer; simpl.
rewrite !field_at_data_at.
simpl.
apply derives_refl'.
rewrite <- ?sepcon_assoc. (* needed if Archi.ptr64=true *)
rewrite !field_compatible_field_address; auto with field_compatible.
clear - H.
(* TODO: simplify the following proof. *)
destruct p; try contradiction.
destruct H as [AL SZ].
repeat split; auto.
simpl in *.  unfold sizeof in *; simpl in *; lia.
eapply align_compatible_rec_Tstruct; [reflexivity |].
simpl co_members; intros.
simpl in H.
if_tac in H; [| inv H].
inv H. inv H0.
eapply align_compatible_rec_by_value.
reflexivity.
rewrite Z.add_0_r.
simpl.
unfold natural_alignment in AL.
eapply Z.divide_trans; [ | apply AL].
apply prove_Zdivide.
reflexivity.
left; auto.
Qed.

Lemma make_object_methods:
  forall sh instance reset twiddle mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset, twiddle) mtable
  |-- object_methods instance mtable.
Proof.
  intros.
  unfold object_methods.
  Exists sh reset twiddle.
  entailer!.
Qed.

Ltac method_call witness hist' result :=
repeat apply seq_assoc1;
match goal with
   |- semax _ (PROPx _ (LOCALx ?Q (SEPx ?R)))
            (Ssequence (Sset ?mt (Efield (Ederef (Etempvar ?x _)  _) _ _))
                 _) _  =>
    match Q with context [temp ?x ?x'] =>
     match R with context [object_mpred _ x'] =>
          let instance := fresh "instance" in let mtable := fresh "mtable" in
          unfold object_mpred; Intros instance mtable;
          forward;
          unfold object_methods at 1;
          let sh := fresh "sh" in let r := fresh "r" in let t := fresh "t" in
          Intros sh r t;
          forward;
          forward_call witness;
          [ .. | try Intros result;
                  sep_apply (make_object_methods sh instance r t mtable); [ auto .. | ];
                  sep_apply (object_mpred_i hist' x' instance mtable);
                  deadvars; try clear dependent sh; try clear r; try clear t
           ]
    end end
end.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
(* assert_gvar _foo_methods. (* TODO: this is needed for a field_compatible later on *) *)
fold noattr cc_default.
(* 0. This part should be handled automatically by start_function *)
gather_SEP (mapsto _ _ _ _) (data_at _ _ _ _);
replace_SEP 0 (data_at Ews (Tstruct _methods noattr)
   (gv _foo_reset, gv _foo_twiddle) (gv _foo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _methods _) _ (gv _foo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite field_at_data_at.  rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  cancel.
}

(* 1. Prove that [mtable] is a proper method-table for foo-objects *)

make_func_ptr _foo_twiddle.
make_func_ptr _foo_reset.
sep_apply (make_object_methods Ews foo_invariant(gv _foo_reset) (gv _foo_twiddle) (gv _foo_methods)); auto.

(* 2. Build an instance of class [foo], called [p] *)
forward_call (* p = make_foo(); *)
        gv.
Intros p.
assert_PROP (p<>Vundef) by entailer!.
(* Illustration of an alternate method to prove the method calls.
   Method 1:  comment out lines AA and BB and the entire range CC-DD.
   Method 2:  comment out lines AA-BB, inclusive.
*)

(* AA *) try (tryif
  (method_call (p, @nil Z) (@nil Z) whatever;
   method_call (p, 3, @nil Z) [3%Z] i;
     [simpl; computable | ])
(* BB *)  then fail else fail 99)
  .

(* CC *)
(* 4. first method-call *)
unfold object_mpred.
Intros instance mtable0.
forward. (*  mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward. (* p_reset = mtable->reset; *)
forward_call (* p_reset(p); *)
      (p, @nil Z).
(* Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).
deadvars!. clear.

(* 5. second method-call *)
unfold object_mpred.
Intros instance mtable0.
forward.  (* mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward.   (* p_twiddle = mtable->twiddle; *)
assert_PROP (p<>Vundef) by entailer!.
forward_call (* i = p_twiddle(p,3); *)
      (p, 3, @nil Z).
  simpl. computable.
Intros i.
simpl in H0.
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [3] p instance mtable0).
deadvars!.
simpl in H1.

(* DD *)

(* 6. return *)
forward.  (* return i; *)
Exists i; entailer!.
Qed.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e191m19_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e129m25_5limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e452m3_9limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e196m15_7limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e196m15_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e191m19_3limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e401m31_7limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import ssreflect ssrbool ssrfun eqtype ssrnat div prime.
Require Import fintype bigops ssralg finset.
Require Import groups morphisms automorphism normal action gprod.
Require Import commutators cyclic center pgroups sylow nilpotent maximal.

(* Require Import seq paths connect finfun perm. *)

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

Import GroupScope.

Theorem Gaschutz : forall (gT : finGroupType) (G H P : {group gT}),
  H <| G -> H \subset P -> P \subset G -> abelian H -> coprime #|H| #|G : P| ->
    [splits G, over H] = [splits P, over H]
 /\ {in [complements to H in G] &, forall K L : {group gT},
     K :&: P = L :&: P -> exists2 x, x \in H & L :=: K :^ x}.
Proof.
move=> gT G H P nsHG sHP sPG abelH coHiPG.
have [sHG nHG] := andP nsHG.
(* set up H as a ZG-module *)
have mulHC : @commutative (subg_of H) mulg.
  by case=> x Hx [y Hy]; apply: val_inj; rewrite /= (centsP abelH).
pose rTm := ZmodMixin (@mulgA _) mulHC (@mul1g _) (@mulVg _).
pose rT := ZmodType rTm; hnf in rT.
have valM: forall a b : rT, sgval (a + b)%R = sgval a * sgval b by [].
have valV: forall a : rT, sgval (- a)%R = (sgval a)^-1 by [].
have valX: forall (a : rT) n, sgval (a *+ n)%R = sgval a ^+ n.
  by move=> a [] //; elim=> // n IHn; congr (_ * _).
pose to (a : rT) y : rT := subg H (sgval a ^ y).
have valA: forall a y, y \in G -> sgval (to a y) = sgval a ^ y.
  by move=> a y Gy; rewrite subgK // memJ_norm ?subgP ?(subsetP nHG).
have to0: forall y, y \in G -> (to 0 y = 0)%R.
  by move=> y Gy; apply: val_inj; rewrite /= valA //= conj1g.
have toM: forall y, y \in G -> {morph to^~ y : a b / a + b}%R.
  by move=> a b y Gy; apply: val_inj; rewrite /= !valA //= conjMg.
have toX: forall a n y, y \in G -> (to (a *+ n) y = to a y *+ n)%R.
  by move=> a n y Gy; apply: val_inj; rewrite /= !(valX, valA) // conjXg.
pose toB y Gy := big_morph (to^~ y) (toM y Gy) (to0 y Gy).
(* Action on right cosets *)
have act_Cayley: forall K L : {group gT}, [acts (L | 'Msr) on rcosets K L].
  move=> K L; apply/subsetP=> x Lx; rewrite 2!inE; apply/subsetP=> X.
  case/rcosetsP=> y Ly ->{X}; rewrite inE /= rcosetE -rcosetM -rcosetE.
  by rewrite mem_imset ?groupM.
(* Get m == 1 / #|G : P| [mod #|H|] *)
have [m mK]: exists m, forall a : rT, (a *+ (#|G : P| * m) = a)%R.
  case: (bezoutl #|H| (indexg_gt0 G P))=> m' _; rewrite gcdnC (eqnP coHiPG).
  case/dvdnP=> m inv_m; exists m => a.
  rewrite mulnC -inv_m /= mulnC GRing.mulrS GRing.mulrnA /=.
  suff ->: (a *+ #|H| = 0)%R by rewrite GRing.mul0rn GRing.addr0.
  apply: val_inj; rewrite /= !valX /=; apply/eqP; rewrite -order_dvdn.
  by rewrite order_dvdG ?subgP.
split=> [|K L].
  apply/splitsP/splitsP=> [[K] | [Q]].
    case/complP=> trHK eqHK; exists (K :&: P)%G.
    rewrite inE setICA (setIidPl sHP) setIC trHK eqxx group_modl // eqHK.
    by rewrite (sameP eqP setIidPr).
  case/complP=> trHQ eqHQ.
  have sQP: Q \subset P by rewrite -eqHQ mulG_subr.
  pose rP x := repr (P :* x); pose pP x := x * (rP x)^-1.
  have PpP: pP _ \in P.
    by move=> x; rewrite -mem_rcoset rcoset_repr rcoset_refl.
  have rPmul : forall x y, x \in P -> rP (x * y) = rP y.
    by move=> x y Px; rewrite /rP rcosetM rcoset_id.
  pose pQ x := remgr H Q x; pose rH x := pQ (pP x) * rP x.
  have pQhq: {in H & Q, forall h q, pQ (h * q) = q} by exact: remgrMid.
  have pQmul: {in P &, {morph pQ : x y / x * y}}.
    apply: remgrM; [exact/complP | exact: normalS nsHG].
  have HrH: forall x, rH x \in H :* x.
    move=> x; rewrite rcoset_sym mem_rcoset invMg mulgA mem_divgr //.
    by rewrite eqHQ PpP.
  have GrH: forall x, x \in G -> rH x \in G.
    move=> x Gx; case/rcosetP: (HrH x) => y Hy ->.
    by rewrite groupM // (subsetP sHG).
  have rH_Pmul: forall x y, x \in P -> rH (x * y) = pQ x * rH y.
    by move=> *; rewrite /rH mulgA -pQmul; first by rewrite /pP rPmul ?mulgA.
  have rH_Hmul: forall h y, h \in H -> rH (h * y) = rH y.
    by move=> h y Hh; rewrite rH_Pmul ?(subsetP sHP) // -(mulg1 h) pQhq ?mul1g.
  pose mu x y : rT := subg H ((rH x * rH y)^-1 * rH (x * y)).
  pose nu y := (\sum_(Px \in rcosets P G) mu (repr Px) y)%R.
  have rHmul : {in G &, forall x y, rH (x * y) = rH x * rH y * sgval (mu x y)}.
    move=> x y Gx Gy; rewrite /= subgK ?mulKVg // -mem_lcoset lcoset_sym.
    rewrite -norm_rlcoset; last by rewrite (subsetP nHG) ?GrH ?groupM.
    rewrite (rcoset_transl (HrH _)) -rcoset_mul ?(subsetP nHG) ?GrH //.
    by rewrite mem_mulg.
  have to_rH : forall a x, x \in G -> to a (rH x) = to a x.
    move=> a x Gx; apply: val_inj; rewrite /= !valA ?GrH //.
    case/rcosetP: (HrH x) => b; move/subgK=> <- ->; rewrite conjgM.
    by congr (_ ^ _); rewrite conjgE -valV -!valM (GRing.addrC a) GRing.addKr.
  have mu_Pmul: forall x y z, x \in P -> mu (x * y) z = mu y z.
    move=> x y z Px; congr subg; rewrite -mulgA !(rH_Pmul x) ?rPmul //.
    by rewrite -mulgA invMg -mulgA mulKg.
  have mu_Hmul: forall x y z, x \in G -> y \in H -> mu x (y * z) = mu x z.
    move=> x y z Gx Hy; congr subg.
    rewrite (mulgA x) (conjgCV x) -mulgA 2?rH_Hmul //.
    by rewrite -mem_conjg (normP _) ?(subsetP nHG).
  have{mu_Hmul} nu_Hmul: forall y z, y \in H -> nu (y * z) = nu z.
    move=> y z Hy; apply: eq_bigr => Px; case/rcosetsP=> x Gx ->{Px}.
    apply: mu_Hmul y z _ Hy.
    by rewrite -(groupMl _ (subsetP sPG _ (PpP x))) mulgKV.
  have cocycle_mu: {in G & &, forall x y z,
    mu (x * y)%g z + to (mu x y) z = mu y z + mu x (y * z)%g}%R.
  - move=> x y z Gx Gy Gz; apply: val_inj.
    apply: (mulgI (rH x * rH y * rH z)).
    rewrite -(to_rH _ _ Gz) GRing.addrC /= valA ?GrH //.
    rewrite mulgA -(mulgA _ (rH z)) -conjgC mulgA -!rHmul ?groupM //.
    by rewrite mulgA -mulgA -2!(mulgA (rH x)) -!rHmul ?groupM.
  move: mu => mu in rHmul mu_Pmul cocycle_mu nu nu_Hmul.
  have{cocycle_mu} cocycle_nu : {in G &, forall y z,
     nu z + to (nu y) z = mu y z *+ #|G : P| + nu (y * z)%g}%R.
  - move=> y z Gy Gz; rewrite /= (toB z Gz).
    have ->: (nu z = \sum_(Px \in rcosets P G) mu (repr Px * y)%g z)%R.
      rewrite /nu (reindex ('Msr%act^~ y)); last first.
        by exists ('Msr%act^~ y^-1) => Px _; rewrite (actK, actKV).
      symmetry; apply: eq_big => Px; first by rewrite (actsP (act_Cayley P G)).
      case/rcosetsP=> x Gx /= ->{Px}; rewrite rcosetE -rcosetM.
      case: repr_rcosetP=> p1 Pp1; case: repr_rcosetP=> p2 Pp2.
      by rewrite -mulgA [x * y]lock !mu_Pmul.
    rewrite -GRing.sumr_const -!big_split /=; apply: eq_bigr => Px.
    case/rcosetsP=> x Gx ->{Px}; rewrite -cocycle_mu //.
    by case: repr_rcosetP=> p1 Pp1; rewrite groupMr // (subsetP sPG).
  move: nu => nu in nu_Hmul cocycle_nu.
  pose f x := rH x * sgval (nu x *+ m)%R.
  have{cocycle_nu} fM: {in G &, {morph f : x y / x * y}}.
    move=> x y Gx Gy; rewrite /f ?rHmul // -3!mulgA; congr (_ * _).
    rewrite (mulgA _ (rH y)) (conjgC _ (rH y)) -mulgA -valA ?GrH ?to_rH //.
    congr (_ * _); rewrite -!valM -(mK (mu x y)) toX //.
    by rewrite GRing.mulrnA -!GRing.mulrn_addl -cocycle_nu // GRing.addrC.
  exists (Morphism fM @* G)%G; apply/complP; split.
    apply/trivgP; apply/subsetP=> x; case/setIP=> Hx.
    case/morphimP=> y _ Gy eq_x.
    apply/set1P; move: Hx; rewrite {x}eq_x /= groupMr ?subgP //.
    rewrite -{1}(mulgKV y (rH y)) groupMl -?mem_rcoset // => Hy.
    rewrite -(mulg1 y) /f nu_Hmul // rH_Hmul //; exact: (morph1 (Morphism fM)).
  apply/setP=> x; apply/mulsgP/idP=> [[h y Hh fy ->{x}] | Gx].
    rewrite groupMl; last exact: (subsetP sHG).
    case/morphimP: fy => z _ Gz ->{x Hx y}.
    by rewrite /= /f groupMl ?GrH // (subsetP sHG) ?subgP.
  exists (x * (f x)^-1) (f x); last first; first by rewrite mulgKV.
    by apply/morphimP; exists x.
  rewrite -groupV invMg invgK -mulgA (conjgC (val _)) mulgA.
  by rewrite groupMl -(mem_rcoset, mem_conjg) // (normsP nHG) // subgP.
case/complP=> trHK eqHK cpHL; case/complP: (cpHL) => trHL eqHL KPeqLP.
pose nu x : rT := subg H (divgr H L x); pose Q := (K :&: P)%G.
have sKG: {subset K <= G} by apply/subsetP; rewrite -eqHK mulG_subr.
have sLG: {subset L <= G} by apply/subsetP; rewrite -eqHL mulG_subr.
have val_nu: forall x, x \in G -> sgval (nu x) = divgr H L x.
  by move=> x Gx; rewrite subgK // mem_divgr // eqHL.
have nu_cocycle: {in G &, forall x y, nu (x * y) = (to (nu y) x^-1%g + nu x)%R}.
  move=> x y Gx Gy; apply: val_inj => /=.
  rewrite valA ?groupV // !(val_nu, groupM, groupV) // /divgr (remgrM cpHL) //.
  by rewrite mulgA -conjgCV -!mulgA -invMg.
have nuL: forall x, x \in L -> nu x = 0%R.
  move=> x Lx; apply: val_inj; rewrite /= val_nu ?sLG //.
  by rewrite /divgr remgr_id ?mulgV.
exists (sgval ((\sum_(X \in rcosets Q K) nu (repr X)^-1%g) *+ m)%R).
  exact: subgP.
apply/eqP; rewrite eq_sym eqEcard; apply/andP.
split; last first.
  by rewrite cardJg -(leq_pmul2l (cardG_gt0 H)) -!TI_cardMg // eqHL eqHK.
apply/subsetP=> /= x_nu; case/imsetP=> x Kx ->{x_nu}.
rewrite conjgE mulgA (conjgC _ x).
have Gx: x \in G by rewrite sKG.
rewrite conjVg -mulgA -valA // -valV -valM (_ : _ + _ = nu x^-1%g)%R.
  rewrite /= val_nu ?groupV //.
  by rewrite mulKVg groupV mem_remgr // eqHL groupV.
rewrite toX // GRing.oppr_muln -GRing.mulrn_addl (toB x Gx).
rewrite GRing.addrC (reindex ('Msr%act^~ x)) /=; last first.
  by exists ('Msr%act^~ x^-1) => Px _; rewrite (actK, actKV).
rewrite (eq_bigl (mem (rcosets Q K))) => [/=|X]; last first.
  by rewrite (actsP (act_Cayley Q K)).
rewrite -GRing.sumr_sub /= (eq_bigr (fun _ => nu x^-1)) => [|X]; last first.
  case/imsetP=> y Ky ->{X}; rewrite !rcosetE.
  set yx1 := repr _; have: yx1 \in Q :* y :* x.
    by apply: (mem_repr (y * x)); rewrite -rcosetM rcoset_refl.
  case/rcosetP=> y1 Qyy1 ->{yx1}; move: (repr _) (mem_repr _ Qyy1) => y2 Qyy2.
  have Gy2: y2 \in G.
    by case/rcosetP: Qyy2 => z2; case/setIP=> Kz2 _ ->; rewrite sKG ?groupM.
  move: Qyy1; rewrite -(rcoset_transl Qyy2) /= KPeqLP; case/rcosetP=> z1.
  case/setIP=> Lz1 _ ->{y1}.
  rewrite !invMg 2?nu_cocycle ?groupM ?groupV // ?sLG // !invgK.
  rewrite (nuL z1^-1) ?groupV // to0 // GRing.add0r (GRing.addrC (to _ x)).
  by rewrite GRing.addrK.
rewrite GRing.sumr_const -GRing.mulrnA (_ : #|_| = #|G : P|) ?mK //.
rewrite -[#|_|]divgS ?subsetIl // -(divn_pmul2l (cardG_gt0 H)).
rewrite -!TI_cardMg //; last by rewrite setIA setIAC (setIidPl sHP).
by rewrite group_modl // eqHK (setIidPr sPG) divgS.
Qed.

Module AfterGaschutz.
End AfterGaschutz.

Theorem SchurZass_split : forall (gT : finGroupType) (G H : {group gT}),
  Hall G H -> H <| G -> [splits G, over H].
Proof.
move=> gT G; move: {2}_.+1 (ltnSn #|G|) => n.
elim: n gT G => // n IHn gT G; rewrite ltnS => Gn H hallH nsHG.
have [sHG nHG] := andP nsHG.
case: (trivgVpdiv H) => [H1 | [p pr_p pH]].
  by apply/splitsP; exists G; rewrite inE H1 -subG1 subsetIl mul1g eqxx.
have [P sylP] := Sylow_exists p H.
case nPG: (P <| G); last first.
  pose N := ('N_G(P))%G.
  have sNG: N \subset G by rewrite subsetIl.
  have eqHN_G: H * N = G by exact: Frattini_arg sylP.
  pose H' := (H :&: N)%G.
  have nH'N: H' <| N.
    rewrite /(_ <| N) subsetIr; apply/subsetP=> x Nx.
    rewrite inE; apply/subsetP=> y; rewrite conjIg (conjGid Nx) (normP _) //.
    by apply: (subsetP nHG); case/setIP: Nx.
  have eq_iH: #|G : H| = #|N| %/ #|H'|.
    rewrite -divgS // -(divn_pmul2l (cardG_gt0 H')) mulnC -eqHN_G.
    by rewrite -mul_cardG (mulnC #|H'|) divn_pmul2l // cardG_gt0.
    have hallH': Hall N H'.
    have sH'H: H' \subset H by exact: subsetIl.
    case/andP: hallH => _; rewrite eq_iH -(LaGrange sH'H) coprime_mull.
    by rewrite /Hall divgS subsetIr //; case/andP.
  have: [splits N, over H'].
    apply: IHn hallH' nH'N; apply: {n}leq_trans Gn.
    rewrite ltn_neqAle subset_leq_card // andbT; apply/eqP=> eqNG.
    case/andP: nPG; rewrite (subset_trans _ sHG); last by case/andP: sylP.
    suff <-: N :=: G by rewrite subsetIr.
    by apply/setP; exact/subset_cardP.
  case/splitsP=> K; case/complP=> trKN eqH'K.
  have sKN: K \subset N by rewrite -(mul1g K) -eqH'K mulSg ?sub1set.
  apply/splitsP; exists K; rewrite inE -subG1; apply/andP; split.
    apply/subsetP=> x; case/setIP=> Hx Kx.
    by rewrite -trKN 2!inE Hx (subsetP sKN) Kx.
  rewrite eqEsubset -eqHN_G mulgS // -eqH'K mulgA mulSg //.
  by rewrite mul_subG ?subsetIl.
pose Z := ('Z(P))%G; have iZ: 'Z(P) = Z by [].
have sZP: Z \subset P by exact: center_sub.
have sZH: Z \subset H by case/andP: sylP; move/(subset_trans sZP).
have sZG: Z \subset G by exact: subset_trans sHG.
have nZG: Z <| G by apply: char_normal_trans nPG; exact: center_char.
have nZH: Z <| H by exact: normalS nZG.
pose Gbar := (G / Z)%G; have iGbar: G / Z = Gbar by [].
pose Hbar := (H / Z)%G; have iHbar: H / Z = Hbar by [].
have nHGbar: Hbar <| Gbar by exact: morphim_normal.
have hallHbar: Hall Gbar Hbar.
  by apply: morphim_Hall; first case/andP: nZH.
have: [splits Gbar, over Hbar].
  apply: IHn => //; apply: {n}leq_trans Gn.
  rewrite card_quotient; last by case/andP: nZG.
  rewrite -(divgS sZG) ltn_Pdiv ?cardG_gt0 // ltnNge -trivg_card_le1.
  apply/eqP; move/(trivg_center_pgroup (pHall_pgroup sylP)); move/eqP.
  rewrite trivg_card1 (card_Hall sylP) p_part -(expn0 p).
  by rewrite eqn_exp2l ?prime_gt1 // lognE pH pr_p cardG_gt0.
case/splitsP=> Kbar; case/complP=> trHKbar eqHKbar.
have: Kbar \subset Gbar by rewrite -eqHKbar mulG_subr.
case/inv_quotientS=> //= ZK quoZK sZZK sZKG.
have nZZK: Z <| ZK by exact: normalS nZG.
have cardZK: #|ZK| = (#|Z| * #|G : H|)%N.
  rewrite -(LaGrange sZZK); congr (_ * _)%N.
  rewrite -card_quotient -?quoZK; last by case/andP: nZZK.
  rewrite -(divgS sHG) -(LaGrange sZG) -(LaGrange sZH) divn_pmul2l //.
  rewrite -!card_quotient; try by [case/andP: nZG | case/andP: nZH].
  by rewrite iGbar -eqHKbar (TI_cardMg trHKbar) mulKn.
have: [splits ZK, over Z].
  case: (Gaschutz nZZK _ sZZK) => // [||-> _].
  - apply: subset_trans (centS sZP); exact: subsetIr.
  - rewrite -divgS // cardZK mulKn //.
    by case/andP: hallH=> _; rewrite -(LaGrange sZH) coprime_mull; case/andP.
  by apply/splitsP; exists [1 gT]%G; rewrite inE -subG1 subsetIr mulg1 eqxx.
case/splitsP=> K; case/complP=> trZK eqZK.
have sKZK: K \subset ZK by rewrite -(mul1g K) -eqZK mulSg ?sub1set.
have trHK: H :&: K = 1.
  apply/trivgP; apply/subsetP=> x; case/setIP=> Hx Kx; rewrite -trZK.
  have Nx: x \in 'N(Z) by apply: subsetP (x) Hx; case/andP: nZH.
  rewrite inE Kx andbT coset_idr //; apply/set1gP.
  rewrite -trHKbar quoZK inE !mem_imset // inE Nx //; exact: (subsetP sKZK).
apply/splitsP; exists K; rewrite inE trHK ?eqEcard subxx leqnn /=.
rewrite mul_subG ?(subset_trans sKZK) //= TI_cardMg // -(@mulKn #|K| #|Z|) //.
by rewrite -TI_cardMg // eqZK cardZK mulKn // LaGrange.
Qed.

Module SchurZassCP1. End SchurZassCP1.

Theorem SchurZass_trans_sol : forall (gT : finGroupType) (H K K1 : {group gT}),
    solvable H -> K \subset 'N(H) -> K1 \subset H * K ->
    coprime #|H| #|K| -> #|K1| = #|K| ->
  exists2 x, x \in H & K1 :=: K :^ x.
Proof.
move=> gT H; move: {2}_.+1 (ltnSn #|H|) => n; elim: n => // n IHn in gT H *.
rewrite ltnS => leHn K K1 solH nHK; case: (eqsVneq H 1) => [H1 |].
  rewrite H1 mul1g => sK1K _ eqK1K.
  exists (1 : gT); first exact: set11.
  by apply/eqP; rewrite conjsg1 eqEcard sK1K eqK1K /=.
pose G := (H <*> K)%G.
have defG: G :=: H * K by rewrite -normC // -norm_mulgenEl // mulgenC.
have sHG: H \subset G by rewrite -gen_subG genS // subsetUl.
have sKG: K \subset G by rewrite -gen_subG genS // subsetUr.
have nHG: H <| G by rewrite /(H <| G) sHG gen_subG subUset nHK normG.
case/(solvable_norm_abelem solH nHG)=> M [sMH nMG ntM].
case/andP=> abelM _; rewrite -defG => sK1G coHK oK1K.
have nMsG: forall L : {set gT}, L \subset G -> L \subset 'N(M).
  by move=> L; move/subset_trans; apply; case/andP: nMG.
have [coKM coHMK]: coprime #|M| #|K| /\ coprime #|H / M| #|K|.
  by apply/andP; rewrite -coprime_mull card_quotient ?nMsG ?LaGrange.
have oKM: forall K' : {group gT},
  K' \subset G -> #|K'| = #|K| -> #|K' / M| = #|K|.
- move=> K' sK'G oK'.
  rewrite -quotient_mulg -?norm_mulgenEl ?card_quotient ?nMsG //; last first.
    by rewrite gen_subG subUset sK'G; case/andP: nMG.
  rewrite -divgS /=; last by rewrite -gen_subG genS ?subsetUr.
  rewrite norm_mulgenEl ?nMsG // coprime_cardMg ?mulnK //.
  by rewrite oK' coprime_sym.
have [xb]: exists2 xb, xb \in H / M & K1 / M = (K / M) :^ xb.
  apply: IHn; try by rewrite (quotient_sol, morphim_norms, oKM K) ?(oKM K1).
    apply: leq_trans leHn; rewrite card_quotient ?nMsG //.
    rewrite -(ltn_pmul2l (cardG_gt0 M)) LaGrange // -{1}(mul1n #|H|).
    by rewrite ltnNge leq_pmul2r // -trivg_card_le1.
  by rewrite -morphimMl ?nMsG // -defG morphimS.
case/morphimP=> x nMx Hx ->{xb} eqK1Kx; pose K2 := (K :^ x)%G.
have{eqK1Kx} eqK12: K1 / M = K2 / M by rewrite quotientJ.
suff [y My ->]: exists2 y, y \in M & K1 :=: K2 :^ y.
  exists (x * y); first by rewrite groupMl // (subsetP sMH).
  by rewrite conjsgM.
have nMK1: K1 \subset 'N(M) by case/andP: nMG => _; exact: subset_trans.
have defMK: M * K1 = M <*> K1 by rewrite -normC // -norm_mulgenEl // mulgenC.
have sMKM: M \subset M <*> K1 by rewrite -defMK mulG_subl.
have nMKM: M <| M <*> K1 by rewrite /(_ <| _) sMKM gen_subG subUset normG.
have trMK1: M :&: K1 = 1 by rewrite coprime_TIg ?oK1K.
have trMK2: M :&: K2 = 1 by rewrite coprime_TIg ?cardJg ?oK1K.
case: (Gaschutz nMKM _ sMKM) => //= [|_].
  by rewrite -divgS //= -defMK coprime_cardMg oK1K // mulKn.
apply; first 1 last; first by rewrite inE defMK trMK1 ?eqxx /=.
  by rewrite -!(setIC M) trMK1.
rewrite inE trMK2 eqxx eq_sym eqEcard /= -defMK andbC.
rewrite !coprime_cardMg ?cardJg ?oK1K // leqnn.
rewrite -{2}(mulGid M) -mulgA mulgS //.
by move/eqP: eqK12; rewrite eqEsubset morphimSK // ker_coset; case/andP.
Qed.


Require Import Thread0 Echo3 Bootstrap.

Module Type S.
  Variable heapSize : nat.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := (heapSize + 50) * 4.
  Definition globalSock : W := globalSched ^+ $4.
End M'.

Import M'.

Module E := Echo3.Make(M').
Import E.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 2.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 2.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "test"!"main" @ [E.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREmain[_] globalSched =?> 2 * 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSock =?> 1 * globalSched =?> 1 * mallocHeap 0];;

        Goto "test"!"main"
      end
    }}.

  Ltac t := unfold globalSched, localsInvariantMain, M'.globalSock, M'.globalSched; genesis.

  Theorem ok0 : moduleOk boot.
    vcgen; abstract (unfold globalSched, localsInvariantMain, M'.globalSock, M'.globalSched; genesis).
  Qed.

  Definition m1 := link boot E.T.m.
  Definition m := link E.m m1.

  Lemma ok1 : moduleOk m1.
    link ok0 E.T.ok.
  Qed.

  Theorem ok : moduleOk m.
    link E.ok ok1.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $(size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok.
  Qed.
End boot.

End Make.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e521m1_17limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e338m15_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e152m17_5limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Definition synth (y : lst) : lst := y.


(* MLTT Lifting and substitution *)

From Coq Require Import Utf8 List Nat Lia.
Require Import Util TAst.

Import ListNotations.

Declare Scope t_scope.
Delimit Scope t_scope with t.

Fixpoint lift n k t : term :=
  match t with
  | var i => var (if Nat.leb k i then (n + i) else i)
  | lam A t => lam (lift n k A) (lift n (S k) t)
  | app u v => app (lift n k u) (lift n k v)
  | Prod A B => Prod (lift n k A) (lift n (S k) B)
  | zero => zero
  | succ t => succ (lift n k t)
  | elim_nat P z s t =>
    elim_nat (lift n k P) (lift n k z) (lift n k s) (lift n k t)
  | Nat => Nat
  | lnil A => lnil (lift n k A)
  | lcons A a l => lcons (lift n k A) (lift n k a) (lift n k l)
  | elim_list A P e c l =>
    elim_list (lift n k A) (lift n k P)
              (lift n k e) (lift n k c) (lift n k l)
  | List A => List (lift n k A)
  | refl A u => refl (lift n k A) (lift n k u)
  | coe A P u v e t =>
    coe
      (lift n k A) (lift n k P)
      (lift n k u) (lift n k v) (lift n k e)
      (lift n k t)
  | Eq A u v => Eq (lift n k A) (lift n k u) (lift n k v)
  | exfalso A p => exfalso (lift n k A) (lift n k p)
  | Empty => Empty
  | axiom n => axiom n
  | univ s => univ s
  end.

Notation lift0 n := (lift n 0).

Fixpoint subst s k u :=
  match u with
  | var n =>
    if Nat.leb k n then
      match nth_error s (n - k) with
      | Some b => lift0 k b
      | None => var (n - List.length s)
      end
    else var n
  | lam A t => lam (subst s k A) (subst s (S k) t)
  | app u v => app (subst s k u) (subst s k v)
  | Prod A B => Prod (subst s k A) (subst s (S k) B)
  | zero => zero
  | succ t => succ (subst s k t)
  | elim_nat P z sc t =>
    elim_nat (subst s k P) (subst s k z) (subst s k sc) (subst s k t)
  | Nat => Nat
  | lnil A => lnil (subst s k A)
  | lcons A a l => lcons (subst s k A) (subst s k a) (subst s k l)
  | elim_list A P e c l =>
    elim_list (subst s k A) (subst s k P)
              (subst s k e) (subst s k c) (subst s k l)
  | List A => List (subst s k A)
  | refl A u => refl (subst s k A) (subst s k u)
  | coe A P u v e t =>
    coe
      (subst s k A) (subst s k P)
      (subst s k u) (subst s k v) (subst s k e)
      (subst s k t)
  | Eq A u v => Eq (subst s k A) (subst s k u) (subst s k v)
  | exfalso A p => exfalso (subst s k A) (subst s k p)
  | Empty => Empty
  | axiom n => axiom n
  | univ s => univ s
  end.

(** Substitutes [t1 ; .. ; tn] in u for [Rel 0; .. Rel (n-1)] *in parallel* *)
Notation subst0 t := (subst t 0).
Definition subst1 t k u := subst [t] k u.
Notation subst10 t := (subst1 t 0).
Notation "M { j := N }" :=
  (subst1 N j M) (at level 10, right associativity) : t_scope.

Lemma subst_empty :
  ∀ k u,
    subst [] k u = u.
Proof.
  intros k u.
  induction u in k |- *.
  all: try solve [
    cbn ;
    rewrite ?IHu, ?IHu1, ?IHu2, ?IHu3, ?IHu4, ?IHu5, ?IHu6 ;
    reflexivity
  ].
  cbn. destruct (k <=? n).
  - rewrite nth_error_nil. f_equal. lia.
  - reflexivity.
Qed.

Lemma lift_0 :
  ∀ k t, lift 0 k t = t.
Proof.
  intros k t.
  induction t in k |- *.
  all: try reflexivity.
  all: try solve [ cbn ; f_equal ; intuition eauto ].
  cbn. destruct (k <=? n). all: reflexivity.
Qed.

Lemma lift_lift :
  ∀ k n m t,
    lift n k (lift m k t) = lift (n + m) k t.
Proof.
  intros k p m t.
  induction t in k, p, m |- *.
  all: try reflexivity.
  all: try solve [ cbn ; f_equal ; intuition eauto ].
  cbn. destruct (k <=? n) eqn:e.
  - destruct (k <=? m + n) eqn:e'.
    2:{
      eapply Compare_dec.leb_complete in e.
      eapply Compare_dec.leb_complete_conv in e'.
      lia.
    }
    f_equal. lia.
  - rewrite e. reflexivity.
Qed.


(*******************************************************************

 The comprehension bicategory of fibrations

 Contents
 1. The comprehension pseudofunctor
 2. Preservation of cartesian 1-cells
 3. Preservation of cartesian 2-cells
 4. The comprehension bicategory

 *******************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain.
Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving.
Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.FibrationCleaving.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits.
Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.Logic.ComprehensionBicat.

Local Open Scope cat.

(**
 1. The comprehension pseudofunctor
 *)
Definition cleaving_comprehension_data
  : disp_psfunctor_data
      disp_bicat_of_cleaving
      (cod_disp_bicat bicat_of_univ_cats)
      (id_psfunctor bicat_of_univ_cats).
Proof.
  simple refine (_ ,, _ ,, _ ,, _ ,, _).
  - exact (λ C D, total_univalent_category (pr1 D) ,, pr1_category _).
  - intros C₁ C₂ F D₁ D₂ FF.
    use make_disp_1cell_cod.
    + exact (total_functor (pr1 FF)).
    + use nat_z_iso_to_invertible_2cell.
      exact (total_functor_commute_z_iso (pr1 FF)).
  - intros C₁ C₂ F G α D₁ D₂ FF GG αα.
    use make_disp_2cell_cod.
    + exact (total_nat_trans (pr1 αα)).
    + abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ;
         rewrite id_left, id_right ;
         apply idpath).
  - intros C D.
    simple refine (_ ,, _).
    + use make_disp_2cell_cod.
      * exact (total_functor_identity (pr11 D)).
      * abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           intros x ;
           cbn ;
           rewrite !id_left ;
           apply idpath).
    + use is_disp_invertible_2cell_cod.
      use is_nat_z_iso_to_is_invertible_2cell.
      intro x.
      apply identity_is_z_iso.
  - intros C₁ C₂ C₃ F G D₁ D₂ D₃ FF GG.
    simple refine (_ ,, _).
    + use make_disp_2cell_cod.
      * exact (total_functor_comp (pr1 FF) (pr1 GG)).
      * abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           intros x ;
           cbn ;
           rewrite !id_left, !id_right ;
           apply functor_id).
    + use is_disp_invertible_2cell_cod.
      use is_nat_z_iso_to_is_invertible_2cell.
      intro x.
      apply identity_is_z_iso.
Defined.

Definition cleaving_comprehension_is_disp_psfunctor
  : is_disp_psfunctor
      disp_bicat_of_cleaving
      (cod_disp_bicat bicat_of_univ_cats)
      (id_psfunctor bicat_of_univ_cats)
      cleaving_comprehension_data.
Proof.
  repeat split ; intro ; intros ;
    (use subtypePath ; [ intro ; apply cellset_property | ]).
  - refine (_ @ !(transportb_cell_of_cod_over _ _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    apply idpath.
  - refine (_ @ !(transportb_cell_of_cod_over _ _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    apply idpath.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lunitor _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite functor_id, !id_right ;
         apply idpath).
    + rewrite !id_right_disp.
      rewrite disp_functor_id.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_runitor _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite !id_right ;
         apply idpath).
    + rewrite !id_right_disp.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over
                    (psfunctor_lassociator _ _ _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite functor_id, !id_right ;
         apply idpath).
    + rewrite !id_right_disp, !id_left_disp.
      rewrite disp_functor_id.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over
                    (psfunctor_lwhisker _ _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite !id_right, !id_left ;
         apply idpath).
    + rewrite !id_right_disp, !id_left_disp.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over
                    (psfunctor_rwhisker _ _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite !id_right, !id_left ;
         apply idpath).
    + rewrite !id_right_disp, !id_left_disp.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
Qed.

Definition cleaving_comprehension
  : disp_psfunctor
      disp_bicat_of_cleaving
      (cod_disp_bicat bicat_of_univ_cats)
      (id_psfunctor bicat_of_univ_cats).
Proof.
  simple refine (_ ,, _).
  - exact cleaving_comprehension_data.
  - exact cleaving_comprehension_is_disp_psfunctor.
Defined.

(**
 2. Preservation of cartesian 1-cells
 *)
Definition global_cartesian_cleaving_comprehension
  : global_cartesian_disp_psfunctor cleaving_comprehension.
Proof.
  use preserves_global_lifts_to_cartesian.
  - exact univalent_cat_is_univalent_2.
  - exact (cod_disp_univalent_2 _ univalent_cat_is_univalent_2).
  - exact cleaving_of_cleaving_global_cleaving.
  - intros C₁ C₂ F D₁.
    use is_pb_to_cartesian_1cell.
    apply reindexing_has_pb_ump.
    apply is_isofibration_from_is_fibration.
    exact (pr2 D₁).
Defined.

(**
 3. Preservation of cartesian 2-cells
 *)
Section LocalCartesianFibration.
  Context {C₁ C₂ : bicat_of_univ_cats}
          {F₁ F₂ : C₁ --> C₂}
          (α : F₁ ==> F₂)
          {D₁ : disp_bicat_of_cleaving C₁}
          {D₂ : disp_bicat_of_cleaving C₂}
          {FF₁ : D₁ -->[ F₁ ] D₂}
          {FF₂ : D₁ -->[ F₂ ] D₂}
          (αα : disp_2cells α FF₁ FF₂)
          (Hαα : ∏ (x : C₁ : univalent_category)
                   (xx : (pr1 D₁ : disp_univalent_category _) x),
                 is_cartesian ((pr11 αα) x xx))
          (G : bicat_of_univ_cats
                 ⟦ total_univalent_category (pr1 D₁)
                   ,
                   total_univalent_category (pr1 D₂) ⟧)
          (γ : G ==> total_functor (pr1 FF₂))
          (δp : (G ∙ pr1_category (pr11 D₂) : bicat_of_univ_cats ⟦ _ , _ ⟧)
                ==>
                total_functor (pr1 FF₁) ∙ pr1_category (pr11 D₂))
          (q : post_whisker γ (pr1_category (pr11 D₂))
               =
               nat_trans_comp
                 _ _ _
                 δp
                 (post_whisker (total_nat_trans (pr1 αα)) (pr1_category _))).

  Definition local_cartesian_cleaving_lift_data
    : nat_trans_data
        (pr1 G)
        (total_functor (pr1 FF₁)).
  Proof.
    refine (λ x, pr1 δp x ,, _) ; cbn.
    refine (cartesian_factorisation (Hαα (pr1 x) (pr2 x)) _ _).
    exact (transportf
             (λ z, _ -->[ z ] _)
             (nat_trans_eq_pointwise q x)
             (pr2 (pr1 γ x))).
  Defined.

  Definition local_cartesian_cleaving_lift_is_nat_trans
    : is_nat_trans _ _ local_cartesian_cleaving_lift_data.
  Proof.
    intros x y f ; cbn.
    use total2_paths_f.
    - exact (nat_trans_ax δp x y f).
    - use (cartesian_factorisation_unique (Hαα (pr1 y) (pr2 y))).
      cbn.
      rewrite assoc_disp_var.
      rewrite mor_disp_transportf_postwhisker.
      rewrite assoc_disp_var.
      rewrite transport_f_f.
      rewrite cartesian_factorisation_commutes.
      rewrite mor_disp_transportf_prewhisker.
      rewrite transport_f_f.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply maponpaths.
        apply disp_nat_trans_ax.
      }
      unfold transportb.
      rewrite mor_disp_transportf_prewhisker.
      rewrite transport_f_f.
      rewrite assoc_disp.
      rewrite cartesian_factorisation_commutes.
      unfold transportb.
      rewrite mor_disp_transportf_postwhisker.
      rewrite !transport_f_f.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        exact (fiber_paths (nat_trans_ax γ _ _ f)).
      }
      rewrite transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  Qed.

  Definition local_cartesian_cleaving_lift
    : G ==> total_functor (pr1 FF₁).
  Proof.
    use make_nat_trans.
    - exact local_cartesian_cleaving_lift_data.
    - exact local_cartesian_cleaving_lift_is_nat_trans.
  Defined.

  Definition local_cartesian_cleaving_lift_over
    : local_cartesian_cleaving_lift ▹ _ = δp.
  Proof.
    use nat_trans_eq ; [ apply homset_property | ].
    intro x.
    apply idpath.
  Qed.

  Definition local_cartesian_cleaving_lift_comm
    : local_cartesian_cleaving_lift • total_nat_trans (pr1 αα)
      =
      γ.
  Proof.
    use nat_trans_eq ; [ apply homset_property | ].
    intro x.
    cbn.
    use total2_paths_f.
    - exact (!(nat_trans_eq_pointwise q x)).
    - cbn.
      rewrite cartesian_factorisation_commutes.
      rewrite transport_f_f.
      apply transportf_set.
      apply homset_property.
  Qed.

  Definition local_cartesian_cleaving_lift_unique
    : isaprop
        (∑ δ,
         δ ▹ _ = δp
         ×
         δ • total_nat_trans (pr1 αα) = γ).
  Proof.
    use invproofirrelevance.
    intros φ₁ φ₂.
    use subtypePath.
    {
      intro.
      apply isapropdirprod ; apply cellset_property.
    }
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    use total2_paths_f.
    - exact (nat_trans_eq_pointwise (pr12 φ₁) x
             @ !(nat_trans_eq_pointwise (pr12 φ₂) x)).
    - use (cartesian_factorisation_unique (Hαα (pr1 x) (pr2 x))).
      rewrite mor_disp_transportf_postwhisker.
      etrans.
      {
        apply maponpaths.
        exact (transportb_transpose_right
                 (fiber_paths (nat_trans_eq_pointwise (pr22 φ₁) x))).
      }
      refine (!_).
      etrans.
      {
        exact (transportb_transpose_right
                 (fiber_paths (nat_trans_eq_pointwise (pr22 φ₂) x))).
      }
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  Qed.
End LocalCartesianFibration.

Definition local_cartesian_cleaving_comprehension
  : local_cartesian_disp_psfunctor cleaving_comprehension.
Proof.
  intros C₁ C₂ F₁ F₂ α D₁ D₂ FF₁ FF₂ αα Hαα.
  apply is_cartesian_2cell_sfib_to_is_cartesian_2cell ; cbn.
  pose (cleaving_of_cleaving_cartesian_2cell_is_pointwise_cartesian _ Hαα) as p.
  intros G γ δp q.
  use iscontraprop1.
  - exact (local_cartesian_cleaving_lift_unique α αα p G γ δp).
  - simple refine (_ ,, _ ,, _).
    + exact (local_cartesian_cleaving_lift α αα p G γ δp q).
    + exact (local_cartesian_cleaving_lift_over α αα p G γ δp q).
    + exact (local_cartesian_cleaving_lift_comm α αα p G γ δp q).
Defined.

(**
 4. The comprehension bicategory
 *)
Definition cleaving_comprehension_bicat_structure
  : comprehension_bicat_structure bicat_of_univ_cats.
Proof.
  use make_comprehension_bicat_structure.
  - exact disp_bicat_of_cleaving.
  - exact cleaving_comprehension.
  - exact cleaving_of_cleaving_global_cleaving.
  - exact global_cartesian_cleaving_comprehension.
Defined.

Definition cleaving_comprehension_is_contravariant
  : is_contravariant cleaving_comprehension_bicat_structure.
Proof.
  repeat split.
  - exact cleaving_of_cleaving_local_cleaving.
  - exact cleaving_of_cleaving_lwhisker_cartesian.
  - exact cleaving_of_cleaving_rwhisker_cartesian.
  - exact local_cartesian_cleaving_comprehension.
Defined.

Definition cleaving_contravariant_comprehension_bicat
  : contravariant_comprehension_bicat
  := _ ,, _ ,, cleaving_comprehension_is_contravariant.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall H K O L Hprime Kprime Oprime Lprime Kprimeprime Lprimeprime I Iprime : Universe, ((wd_ Oprime Kprimeprime /\ (wd_ Oprime Kprime /\ (wd_ Oprime Lprimeprime /\ (wd_ Oprime Lprime /\ (wd_ O H /\ (wd_ O I /\ (wd_ Oprime Iprime /\ (wd_ Iprime Lprimeprime /\ (wd_ O K /\ (wd_ O L /\ (col_ Oprime Kprime Kprimeprime /\ (col_ Oprime Lprime Lprimeprime /\ (col_ Oprime Iprime Hprime /\ (col_ O I H /\ col_ Oprime Kprimeprime Lprimeprime)))))))))))))) -> col_ Kprime Oprime Lprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^230 - 27
Base: 23
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 23;
    bitwidth := 32;
    s := 2^230;
    c := [(1, 27)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(* A token-asset exchange contract based on Dexter
   https://gitlab.com/camlcase-dev/dexter/-/blob/f4ef07ea672a1397b58c2134b3437bb5ef69bcaa/dexter-contracts-ligo/dexter.ligo *)
From Coq Require Import ZArith_base.
From Coq Require Import List. Import ListNotations.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Examples.EIP20 Require EIP20Token.

(* A liquidity exchange contract inspired by the Dexter contract.
   Allows for exchanging tokens to money, and allows the owner to add tokens to the
   reserve held by this contract. *)
Section Dexter.
  Context {BaseTypes : ChainBase}.
  Set Primitive Projections.
  Set Nonrecursive Elimination Schemes.
  Open Scope N_scope.

  Record exchange_param :=
    build_exchange_param {
      exchange_owner : Address;
      tokens_sold : N;
    }.

  Inductive Msg :=
    | tokens_to_asset : exchange_param -> Msg
    | add_to_tokens_reserve : Msg.

  Record Setup :=
    build_setup {
      token_caddr_ : Address;
      token_pool_ : N;
    }.

  Record State :=
    build_state {
      token_pool : N;
      price_history : list Amount;
      token_caddr : Address;
    }.

  Definition Error : Type := nat.
  Definition default_error : Error := 1%nat.

  MetaCoq Run (make_setters State).
  MetaCoq Run (make_setters Setup).

  Section Serialization.

    Global Instance exchange_paramserializable : Serializable exchange_param :=
      Derive Serializable exchange_param_rect <build_exchange_param>.

    Global Instance DexterMsg_serializable : Serializable Msg :=
      Derive Serializable Msg_rect <tokens_to_asset, add_to_tokens_reserve>.

    Global Instance setup_serializable : Serializable Setup :=
      Derive Serializable Setup_rect <build_setup>.

    Global Instance state_serializable : Serializable State :=
      Derive Serializable State_rect <build_state>.

  End Serialization.

  (* calculates exchange rate *)
  Open Scope Z_scope.
  Definition getInputPrice (tokens_to_be_sold : Amount)
                           (tokens_reserve : Amount)
                           (asset_reserve : Amount) :=
    Z.div (tokens_to_be_sold * 997 * asset_reserve)
          (tokens_reserve * 1000 + tokens_to_be_sold * 997).

  Definition begin_exchange_tokens_to_assets (dexter_asset_reserve : Amount)
                                             (caller : Address)
                                             (params : exchange_param)
                                             (dexter_caddr : Address)
                                             (state : State)
                                             : result (State * (list ActionBody)) Error :=
    do _ <- throwIf (address_neqb caller params.(exchange_owner)) default_error;
    let tokens_to_sell := Z.of_N params.(tokens_sold) in
    let tokens_price := getInputPrice tokens_to_sell (Z.of_N state.(token_pool)) dexter_asset_reserve in
    (* send out asset transfer to transfer owner, and send a token transfer message to the FA2 token *)
    let asset_transfer_msg := act_transfer params.(exchange_owner) tokens_price in
    let token_transfer_param :=
      EIP20Token.transfer_from params.(exchange_owner) dexter_caddr params.(tokens_sold) in
    let token_transfer_msg := act_call state.(token_caddr) 0%Z (@serialize EIP20Token.Msg _ (token_transfer_param)) in
    let new_state := state<|token_pool := N.add state.(token_pool) params.(tokens_sold)|>
                          <| price_history := state.(price_history) ++ [tokens_price]|> in
    Ok (new_state, [asset_transfer_msg; token_transfer_msg]).

  Open Scope Z_scope.
  Definition receive (chain : Chain)
                     (ctx : ContractCallContext)
                     (state : State)
                     (maybe_msg : option Msg)
                     : result (State * list ActionBody) Error :=
    let sender := ctx.(ctx_from) in
    let caddr := ctx.(ctx_contract_address) in
    let dexter_balance := ctx.(ctx_contract_balance) in
    match maybe_msg with
    | Some (tokens_to_asset params) =>
        begin_exchange_tokens_to_assets dexter_balance sender params caddr state
    (* Ignore any other type of call to this contract *)
    | _ => Ok (state, [])
    end.

  Definition init (chain : Chain)
                  (ctx : ContractCallContext)
                  (setup : Setup)
                  : result State Error :=
    Ok {|
      token_pool := setup.(token_pool_);
      token_caddr := setup.(token_caddr_);
      price_history := []
    |}.

  Definition contract : Contract Setup Msg State Error :=
    build_contract init receive.

End Dexter.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj2synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult lv0 lv1) (mult lv0 lv2)).
Admitted.
QuickChick conj2synthconj3.