Require Import HahnBase.

Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import printer.printer_files.compiled_format.
Require Import printer.verified_printer.Format.
Require Import Coq.Strings.Ascii.
Require Import format_specs.
Require Import format_std_proof.
Require Import list_specs.

Lemma less_components_fact1:
  forall (x y : nat),
    (0 <= (Z.of_nat x) <= Int.max_unsigned) ->
    (0 <= (Z.of_nat y) <= Int.max_unsigned) ->
    Val.of_bool (Z.of_nat x <=? Z.of_nat y) =
    Val.of_bool (negb (Int.ltu (Int.repr (Z.of_nat y)) (Int.repr (Z.of_nat x)))).
Proof.
  intros.
  f_equal.
  remember (Z.of_nat x <=? Z.of_nat y) as comp.
  destruct comp.
  { remember (Z.of_nat y) as Y.
    remember (Z.of_nat x) as X.
    assert (X <= Y \/  X > Y) as AA. lia.
    destruct AA.
    { remember (Int.ltu (Int.repr Y) (Int.repr X)) as b eqn:AA.
      destruct b.
      symmetry in AA.
      apply ltu_inv in AA.
      repeat rewrite Int.unsigned_repr in AA by auto.
      all: lia.
    }
    remember (Int.ltu (Int.repr Y) (Int.repr X)).
    destruct b.
    2: now lia.
    destruct (Z.leb_spec0 X Y); lia.

  }
  remember (Z.of_nat y) as Y.
  remember (Z.of_nat x) as X.
  assert (X <= Y \/  X > Y) as AA. lia.
  destruct AA.
  { remember (Int.ltu (Int.repr Y) (Int.repr X)) as b eqn:AA.
    destruct b. lia.
    symmetry in AA.
    apply ltu_false_inv in AA.
    repeat rewrite Int.unsigned_repr in AA by auto.
    destruct (Z.leb_spec0 X Y); lia.
  }
  remember (Int.ltu (Int.repr Y) (Int.repr X)) as b eqn:AA.
  destruct b. lia.
  symmetry in AA.
  apply ltu_false_inv in AA.
  repeat rewrite Int.unsigned_repr in AA by auto.
  lia.
Qed.

Lemma less_components_fact2:
  forall (x y : nat),
  ((Z.of_nat x)) <=? (Z.of_nat y) = (Nat.leb x y).
Proof.
  intros.
  destruct (Nat.leb_spec0 x y).
  { apply inj_le in l.
    destruct (Z.leb_spec0 (Z.of_nat x) (Z.of_nat y)); auto. }
  destruct (Z.leb_spec0 (Z.of_nat x) (Z.of_nat y)); auto.
  apply Nat2Z.inj_le in l. lia.
Qed.

Lemma body_less_components: semax_body Vprog Gprog f_less_components less_components_spec.
Proof.
  start_function.
  do 2 forward.
  getnw. rename FMT_MP into FMT_MP'. getnw.
  destruct FMT_MP, FMT_MP'.
  forward_if(
    EX t1: bool,
    PROP(<< first_comp_eq : t1 = andb
      ((Z.of_nat (height G)) <=? Z.of_nat (height F))
      ((Z.of_nat (first_line_width G)) <=? Z.of_nat (first_line_width F)) >>
    )
    LOCAL(temp _t'1 (Val.of_bool t1); temp _G pointer_G; temp _F pointer_F)
    SEP(
      concrete_mformat G pointer_G sigmaG pG;
      concrete_mformat F pointer_F sigmaF pF
    )
  ).

  { do 3 forward.
    Exists ((Z.of_nat (first_line_width G)) <=? (Z.of_nat (first_line_width F))).
    unfold concrete_mformat.
    unnw. entailer!. split.
    { apply less_components_fact1; lia. }
    split; apply mk_format_mp; auto. }
  { forward.
    Exists false.
    unfold concrete_mformat; unnw.
    entailer!.
    split; apply mk_format_mp; auto. }

  Intros first_comp.
  forward_if(
    EX t2: bool,
    PROP(<< second_comp_eq : t2 = andb first_comp
      (((Z.of_nat (middle_width G))) <=?
      (Z.of_nat (middle_width F))) >>)
    LOCAL(temp _t'2 (Val.of_bool t2); temp _G pointer_G; temp _F pointer_F)
    SEP(concrete_mformat G pointer_G sigmaG pG; concrete_mformat F pointer_F sigmaF pF)
  ).
  { do 3 forward.
    Exists (first_comp && ((Z.of_nat (middle_width G)) <=? (Z.of_nat (middle_width F))))%bool.
    getnw.
    unfold concrete_mformat. unnw. subst. entailer!.
    remember ((Z.of_nat (height G) <=? Z.of_nat (height F)) &&
    (Z.of_nat (first_line_width G) <=? Z.of_nat (first_line_width F)))%bool as comp eqn:AA.
    clear AA. subst.
    simpl. apply less_components_fact1; lia. }
  { forward.
    Exists false.
    entailer!. }

  Intros second_comp.
  forward_if(
    EX t3: bool,
    PROP(<< third_comp_eq : t3 = andb second_comp
      (((Z.of_nat (last_line_width G))) <=?
       (Z.of_nat (last_line_width F))) >>)
    LOCAL(temp _t'3 (Val.of_bool t3); temp _G pointer_G; temp _F pointer_F)
    SEP(concrete_mformat G pointer_G sigmaG pG; concrete_mformat F pointer_F sigmaF pF)
  ).
  { do 3 forward.
    Exists (second_comp && (((Z.of_nat (last_line_width G))) <=? (Z.of_nat (last_line_width F))))%bool.
    unfold concrete_mformat. entailer!. simpl.
    apply less_components_fact1; lia. }
  { forward.
    Exists false.
    entailer!. }
  Intros third_comp.
  forward.
  Exists (less_components G F).
  entailer!.
  f_equal; unfold less_components; getnw; subst.
  repeat rewrite less_components_fact2; auto.
Qed.

Lemma is_less_than_fact1 x y :
    (x <> y)%nat <-> (x =? y)%nat = false.
Proof.
  remember (Nat.eqb_spec x y) eqn:AA. clear AA. split.
  { intros. destruct r; easy. }
  intros. destruct r; auto. lia.
Qed.

Lemma nat_eq_iff_int_eq x y
    (XBOUND : 0 <= (Z.of_nat x) <= Int.max_unsigned)
    (YBOUND : 0 <= (Z.of_nat y) <= Int.max_unsigned) :
    (x =? y)%nat = Int.eq (Int.repr (Z.of_nat x)) (Int.repr (Z.of_nat y)).
Proof.
  destruct (Nat.eqb_spec x y).
  { subst. rewrite Int.eq_true. auto. }
  remember(Int.eq (Int.repr (Z.of_nat x)) (Int.repr (Z.of_nat y))) as b eqn:AA.
  destruct b.
  2: lia.
  symmetry in AA. apply Int.same_if_eq in AA.
  apply repr_inj_unsigned in AA; auto. lia.
Qed.

Lemma body_is_less_than: semax_body Vprog Gprog f_is_less_than is_less_than_spec.
Proof.
  start_function.
  forward.
  getnw. destruct FMT_MP.
  forward_if(
    EX t1: bool,
    PROP(t1 = andb (negb (Nat.eqb (height G) 1%nat)) (Nat.eqb (height F) 1))
    LOCAL(temp _t'2 (Val.of_bool t1); temp _G pointer_G; temp _F pointer_F)
    SEP(concrete_mformat G pointer_G sigmaG pG; concrete_mformat F pointer_F sigmaF pF)
  ).
  { do 2 forward.
    Exists (negb (height G =? 1)%nat && (height F =? 1)%nat)%bool.
    entailer!.
    2: { unfold concrete_mformat. entailer!. unnw. apply mk_format_mp; auto. }
    f_equal.
    assert ((Nat.eqb (height G) 1) = false) as AA.
    { destruct (eq_dec (height G) 1%nat).
      { rewrite e in *. simpl in *. list_solve. }
      apply is_less_than_fact1. auto.
    }
    rewrite AA. simpl. apply nat_eq_iff_int_eq.
    { getnw; destruct FMT_MP; lia. }
    unfold Int.max_unsigned; ins; lia. }
  { forward.
    Exists false.
    entailer!.
    2: { unfold concrete_mformat. entailer!. unnw. apply mk_format_mp; auto. }
    replace (height G) with 1%nat by lia; ins. }

  unfold concrete_mformat.
  Intros first_comp.
  getnw. destruct FMT_MP.
  forward_if(
    EX t2: bool,
    PROP(t2 = orb first_comp (andb (Nat.eqb (height G) 1%nat) (negb (Nat.eqb (height F) 1%nat))))
    LOCAL(temp _t'3 (Val.of_bool t2); temp _G pointer_G; temp _F pointer_F)
    SEP(concrete_mformat G pointer_G sigmaG pG; concrete_mformat F pointer_F sigmaF pF)
  ).
  { forward.
    Exists (first_comp || (height G =? 1)%nat && negb (height F =? 1)%nat)%bool.
    entailer!.
    2: { unfold concrete_mformat. entailer!. unnw. apply mk_format_mp; auto. }
    remember (negb (height G =? 1)%nat && (height F =? 1)%nat)%bool as comp eqn:AA.
    clear AA. subst.
    list_solve. }
  { forward.
    forward_if(
      EX t3: bool,
      PROP(t3 = andb (Nat.eqb (height G) 1%nat) (negb (Nat.eqb (height F) 1%nat)))
      LOCAL(temp _t'3 (Val.of_bool t3); temp _G pointer_G; temp _F pointer_F)
      SEP(concrete_mformat G pointer_G sigmaG pG; concrete_mformat F pointer_F sigmaF pF)
    ).
    { do 3 forward.
      Exists ((height G =? 1)%nat && negb (height F =? 1)%nat)%bool.
      entailer!.
      2: { unfold concrete_mformat. entailer!. unnw. apply mk_format_mp; auto. }
      f_equal. replace (height G) with 1%nat by list_solve.
      simpl. f_equal.
      apply nat_eq_iff_int_eq; lia. }
    { forward.
      Exists false.
      entailer!.
      2: { unfold concrete_mformat. entailer!. unnw.
           apply mk_format_mp; auto. }
      assert (height G <> 1%nat). list_solve.
      destruct (Nat.eqb_spec (height G) 1%nat); easy. }
    Intros second_comp.
    Exists (first_comp || second_comp)%bool.
    entailer!.
    replace (negb (height G =? 1)%nat && (height F =? 1)%nat)%bool
      with false; auto. }
  Intros all_comp.
  forward_if.
  { forward.
    Exists false.
    unfold is_less_than.
    destruct (height G) eqn:AA.
    { destruct (height F) eqn:BB.
      { entailer!; ins. }
      entailer!.
      destruct n; ins. }
    entailer!.
    desf. }

  forward_call(G, F, pointer_G, pointer_F, sigmaG, sigmaF, pG, pF).
  Intros ans; forward.
  Exists (less_components G F).
  entailer!.
  unfold is_less_than; desf.
Qed.

Lemma body_empty: semax_body Vprog Gprog f_empty empty_spec.
Proof.
  start_function.
  forward_call(t_format, gv).
  Intros empty_pointer.
  dest_ptr empty_pointer.
  do 6 forward.

  Exists empty_pointer.
  entailer!.
  unfold mformat.
  Exists ([] : (list (Z * list byte))) (Vlong (Int64.repr 0)).
  unfold concrete_mformat.
  entailer!.
  { now apply mk_format_mp. }
  unfold listrep. entailer!.
Qed.

Lemma list_byte_to_string_length:
  forall (s : list byte),
    Z.of_nat (String.length (list_byte_to_string s)) = Zlength s.
Proof.
  ins.
  induction s.
  { list_solve. }
  unff list_byte_to_string.
  ins. list_solve.
Qed.

Lemma list_byte_to_list_byte_eq:
  forall (s : list byte),
    string_to_list_byte (list_byte_to_string s) = s.
Proof.
  intros.
  induction s.
  { list_solve. }
  unfold list_byte_to_string; fold list_byte_to_string.
  unfold string_to_list_byte; fold string_to_list_byte.
  rewrite IHs.
  assert (Byte.unsigned a < 256).
  { remember (Byte.unsigned_range a).
    unfold Byte.modulus in a0.
    assert(two_power_nat Byte.wordsize = 256 ). list_solve.
    lia. }
  assert ((Z.to_N (Byte.unsigned a) < 256)%N) by list_solve.
  assert ((N_of_ascii (ascii_of_N (Z.to_N (Byte.unsigned a)))) = Z.to_N (Byte.unsigned a)) as AA.
  { now apply N_ascii_embedding. }
  rewrite AA.
  rewrite Z2N.id.
  rewrite Byte.repr_unsigned; auto.
  apply Byte.unsigned_range.
Qed.

Lemma empty_string_app:
  forall (s : string),
    (s ++ "")%string = s.
Proof.
  ins. induction s; ins.
  unfold append; fold append. now rewrite IHs.
Qed.

Lemma string_to_list_byte_app (l1 l2 : string) :
  string_to_list_byte (l1 ++ l2) =
    string_to_list_byte l1 ++ string_to_list_byte l2.
Proof.
  induction l1; ins.
  now rewrite IHl1.
Qed.

Lemma body_line: semax_body Vprog Gprog f_line line_spec.
Proof.
  start_function.
  forward_call(t_format, gv).
  Intros format_pointer.
  dest_ptr format_pointer.
  forward. forward_call(Ews, sigma, p).
  forward. forward_call(Ews, sigma, p).
  forward. forward_call(Ews, sigma, p).
  forward. forward_call(t_list, gv).
  Intros to_text_pointer.
  destruct (eq_dec to_text_pointer nullval).
  { do 2 forward.
    forward_if(to_text_pointer <> nullval).
    { forward_call. entailer!. }
    { forward. entailer!. }
    now Intros. }
  Intros.
  do 2 forward.
  forward_if(to_text_pointer <> nullval).
  { forward_call. entailer!. }
  { forward. entailer. }

  do 7 forward.
  Exists format_pointer.
  unfold mformat. unfold cstring.
  Exists ([(0, sigma)]) to_text_pointer.
  entailer!. unfold concrete_mformat.
  entailer!.
  {
    unnw. apply mk_format_mp.
    { unfold to_text_eq. unfold to_text. simpl.
      intros x line.
      rewrite string_to_list_byte_app.
      rewrite list_byte_to_list_byte_eq.
      auto.
    }
    { apply mk_list_mp; auto.
      { simpl. unfold Int.max_unsigned. simpl. lia. }
      list_simplify; simpl; lia.
    }
    all: unfold line; simpl.
    { unfold Int.max_unsigned. simpl. lia. }
    4: ins.
    all: rewrite list_byte_to_string_length; list_solve.
  }
  unfold listrep.
  unfold cstring.
  Exists (Vlong (Int64.repr 0)) p.
  entailer!.
  unfold line; simpl.
  repeat rewrite list_byte_to_string_length.
  entailer!.
Qed.

Lemma sp_fact1 (n : Z):
  Zrepeat (Byte.repr 32) n = sp_byte (Z.to_nat n).
Proof.
  unfold Zrepeat.
  remember (Z.to_nat n) as m eqn:AA.
  clear AA. clear n.
  induction m; ins.
Qed.

Lemma sp_fact2 (n : nat):
  ~In Byte.zero (sp_byte n).
Proof.
  induction n.
  { list_solve. }
  unfold not in *. unfold sp; fold sp. simpl.
  intros AA. destruct AA as [AA | AA]; auto.
  inv AA.
Qed.

Lemma body_sp : semax_body Vprog Gprog f_sp sp_spec.
Proof.
  start_function.
  forward_call((Tarray tschar (n + 1) noattr), gv).
  { unfold Int.max_unsigned, Ptrofs.max_unsigned in *.
    ins. lia. }
  Intros result_pointer.
  dest_ptr result_pointer.
  forward.
  forward_loop (
    EX i : Z,
    PROP(0 <= i <= n)
    LOCAL(temp _i (Vptrofs (Ptrofs.repr i)); temp _space (Vint (Int.repr 32));
          temp _result result_pointer; temp _n (Vptrofs (Ptrofs.repr n)))
    SEP(data_at Ews (Tarray tschar (n + 1) noattr) (map Vbyte (Zrepeat (Byte.repr 32) i) ++ Zrepeat Vundef (n + 1 - i)) result_pointer;
        malloc_token Ews (Tarray tschar (n + 1) noattr) result_pointer;
        mem_mgr gv)
  ) break: (
    PROP()
    LOCAL(temp _result result_pointer; temp _n (Vptrofs (Ptrofs.repr n)))
    SEP(data_at Ews (Tarray tschar (n + 1) noattr) (map Vbyte (Zrepeat (Byte.repr 32) n) ++ [Vundef]) result_pointer;
        malloc_token Ews (Tarray tschar (n + 1) noattr) result_pointer;
        mem_mgr gv)
  ).
  { forward. Exists 0. entailer!.
    autorewrite with sublist norm.
    unfold data_at_, data_at, field_at_. entailer!. }
  { Intros i.
    forward_if.
    { forward. forward. Exists (i + 1). entailer!. list_solve. }
    forward.
    entailer!.
    autorewrite with sublist norm.
    list_solve.
  }
  do 2 forward.
  Exists result_pointer.
  unfold cstring.
  entailer!.
  { remember (sp_fact2 (Z.to_nat n)) as AA. auto. }
  repeat rewrite <- sp_fact1.
  autorewrite with sublist norm.
  list_solve.
Qed.

Lemma sp_byte_length (n : nat) :
  Zlength (sp_byte n) = Z.of_nat n.
Proof.
  induction n; unfold sp_byte; ins.
  autorewrite with sublist.
  unfold sp_byte in *; ins. lia.
Qed.

Lemma shifted_text_from_length_element_relation (sigma : list (Z * list byte)) (p : (Z * list byte)) (shift : Z) :
  (<<LIST_MP : list_mp sigma>>) ->
  0 <= fst p <= Int.max_unsigned ->
  0 <= Zlength (snd p) + 1 <= Int.max_unsigned ->
  0 <= shift ->
  Zlength sigma = 0 \/ Zlength sigma = 1 \/
  Zlength (shifted_text_from (sigma ++ [p]) (Z.to_nat shift)) =
  Zlength (shifted_text_from sigma (Z.to_nat shift)) +
  (1 + (fst p) + shift + Zlength (snd p)).
Proof.
  intros.
  induction sigma.
  { list_solve. }
  right; ins.
  destruct a.
  assert (list_mp sigma) as AA.
  { getnw.
    destruct LIST_MP.
    apply mk_list_mp; list_solve. }
  apply IHsigma in AA.
  destruct AA as [AA | AA].
  { left. list_solve. }
  destruct AA as [AA | AA].
  { destruct sigma.
    { list_solve. }
    right.
    replace (sigma) with ([] : list (Z * list byte)) by list_solve.
    simpl.
    unfold shifted_text_from.
    destruct p0. destruct p.
    autorewrite with sublist norm.
    repeat rewrite sp_byte_length.
    simpl in *.
    getnw. destruct LIST_MP.
    unfold newline_byte.
    list_solve. }
  right; ins.
  unfold shifted_text_from; fold shifted_text_from; ins.
  destruct sigma; ins.
  { unfold shifted_text_from.
    destruct p; ins.
    autorewrite with sublist norm.
    repeat rewrite sp_byte_length.
    list_solve. }
  autorewrite with sublist norm.
  rewrite AA.
  list_solve.
Qed.

Lemma text_from_length_element_relation (sigma : list (Z * list byte)) (p : (Z * list byte)) (shift : Z) (line : list byte) :
  (<<LIST_MP : list_mp sigma>>) ->
  0 <= fst p <= Int.max_unsigned ->
  0 <= Zlength (snd p) + 1 <= Int.max_unsigned ->
  0 <= shift ->
  sigma = [] \/
  Zlength (text_from (sigma ++ [p]) (Z.to_nat shift) (list_byte_to_string line)) =
  Zlength (text_from sigma (Z.to_nat shift) (list_byte_to_string line)) +
  (1 + (fst p) + shift + Zlength (snd p)).
Proof.
  intros.
  getnw. destruct LIST_MP.
  destruct sigma; [left|right]; auto.
  unfold text_from; ins.
  destruct p0.
  destruct sigma; ins.
  { unfold shifted_text_from.
    destruct p.
    autorewrite with sublist norm.
    repeat rewrite list_byte_to_list_byte_eq.
    repeat rewrite sp_byte_length.
    ins. list_solve. }
  destruct sigma; ins.
  { simpl. unfold shifted_text_from.
    destruct p0. destruct p.
    autorewrite with sublist norm.
    simpl in *.
    repeat rewrite sp_byte_length.
    repeat rewrite list_byte_to_list_byte_eq.
    unfold newline_byte.
    list_solve.
  }
  autorewrite with sublist norm.
  simpl in *.
  assert (
    Zlength (shifted_text_from (p0 :: p1 :: sigma ++ [p]) (Z.to_nat shift)) =
    Zlength (shifted_text_from (p0 :: p1 :: sigma) (Z.to_nat shift)) +
    (1 + fst p + shift + Zlength (snd p))
  ) as AA.
  {
    remember (shifted_text_from_length_element_relation (p0 :: p1 :: sigma) p shift).
    assert (list_mp (p0 :: p1 :: sigma)) as AA.
    { apply mk_list_mp.
      { list_solve. }
      { inversion list_mp_forall_fst. auto. }
      inversion list_mp_forall_snd. auto.
    }
    assert (0 <= fst p <= Int.max_unsigned) by lia.
    assert (0 <= Zlength (snd p) + 1 <= Int.max_unsigned) by lia.
    assert (0 <= shift) by lia.
    apply o in AA; auto.
    destruct AA as [AA | AA]; [list_solve|]; auto.
    destruct AA as [AA | AA]; [list_solve|]; auto. }
  rewrite AA.
  repeat rewrite sp_byte_length.
  repeat rewrite list_byte_to_list_byte_eq.
  list_solve.
Qed.

Lemma text_from_length_relation (sigma : list (Z * list byte)) (i : Z) (shift : Z) (line : list byte) :
  0 <= i < Zlength sigma ->
  (<<LIST_MP : list_mp sigma>>) ->
  0 <= shift ->
  i = 0 \/
  Zlength (text_from (sublist 0 (i + 1) sigma) (Z.to_nat shift) (list_byte_to_string line)) =
  Zlength (text_from (sublist 0 i sigma) (Z.to_nat shift) (list_byte_to_string line)) +
  (1 + (fst (Znth i sigma)) + shift + Zlength (snd (Znth i sigma))).
Proof.
  intros.
  getnw.
  destruct LIST_MP.
  remember (Z.to_nat i) as n.
  replace i with (Z.of_nat n) in * by lia .
  clear Heqn.
  destruct n.
  { left. auto. }
  right.
  replace ((sublist 0 (Z.of_nat (S n) + 1) sigma) ) with
    ((sublist 0 (Z.of_nat (S n)) sigma) ++ [Znth (Z.of_nat (S n)) sigma]) by list_solve.
  enough (
    Zlength (text_from
     (sublist 0 (Z.of_nat (S n)) sigma ++ [Znth (Z.of_nat (S n)) sigma])
     (Z.to_nat shift) (list_byte_to_string line)) =
    Zlength (text_from (sublist 0 (Z.of_nat (S n)) sigma) (Z.to_nat shift) (list_byte_to_string line)) +
    (1 + (fst (Znth (Z.of_nat (S n)) sigma)) + shift + Zlength (snd (Znth (Z.of_nat (S n)) sigma)))) as AA.
  { now rewrite AA. }
  remember (text_from_length_element_relation (sublist 0 (Z.of_nat (S n)) sigma) (Znth (Z.of_nat (S n)) sigma) shift line).
  assert (list_mp (sublist 0 (Z.of_nat (S n)) sigma)) as AA.
  { apply mk_list_mp; list_solve. }
  apply o in AA.
  all: try destruct AA; auto.
  all: list_solve.
Qed.

Lemma body_get_applied_length: semax_body Vprog Gprog f_get_applied_length get_applied_length_spec.
Proof.
  start_function. getnw. destruct LIST_MP.
  forward_if (p <> nullval).
  { forward_call(Ews, line, q). forward.
    getnw. desf.
    assert (sigma = []) as AA.
    { list_solve. }
    subst.
    Exists (Zlength line). entailer!.
    unfold text_from.
    rewrite list_byte_to_list_byte_eq. auto.
  }
  { forward. entailer!. }

  destruct sigma.
  { unfold listrep. Intros. contradiction. }

  Intros.
  unfold listrep; fold listrep.
  destruct p0 as (first_el_shift, first_el_line).
  inversion list_mp_forall_fst as [tmp | tmp1 tmp2 first_el_shift_cond shift_sigma_cond tmp3 ].
  simpl in first_el_shift_cond.
  inversion list_mp_forall_snd as [tmp | tmp10 tmp20 first_el_line_cond line_sigma_cond tmp30].
  simpl in first_el_line_cond.
  Intros to_text_tail_ptr first_el_line_ptr.
  forward.
  forward_call(Ews, first_el_line, first_el_line_ptr).
  do 3 forward.
  { entailer!. getnw. desf. }
  remember ((first_el_shift, first_el_line)::sigma) as big_sigma eqn:eqn_big_sigma.
  forward_call(Ews, line, q).
  forward.

  forward_loop (
    EX i : Z, EX cur_to_text_ptr : val,
    PROP (1 <= i < Zlength big_sigma + 1)
    LOCAL (temp _total_length (Vptrofs (Ptrofs.repr (Zlength (text_from (sublist 0 i big_sigma) (Z.to_nat shift) (list_byte_to_string line)))));
          temp _to_text_cpy cur_to_text_ptr;
          temp _shift (Vptrofs (Ptrofs.repr shift)))
    SEP( listrep (sublist i (Zlength big_sigma) big_sigma) cur_to_text_ptr;
        lseg (sublist 0 i big_sigma) p cur_to_text_ptr; cstring Ews line q
    )).
  { Exists 1 to_text_tail_ptr.
    entailer!.
    { split.
      { list_solve. }
      do 3 f_equal.
      replace (sublist 0 1 ((first_el_shift, first_el_line) :: sigma)) with
        [(first_el_shift, first_el_line)] by list_solve.
      unfold text_from. rewrite list_byte_to_list_byte_eq.
      autorewrite with sublist. rewrite sp_byte_length.
      list_solve.
    }
    replace ((sublist 1 (Zlength ((first_el_shift, first_el_line) :: sigma)) ((first_el_shift, first_el_line) :: sigma))) with
      sigma by list_solve.
    replace (sublist 0 1 ((first_el_shift, first_el_line) :: sigma)) with
      [(first_el_shift, first_el_line)] by list_solve.
    entailer!.
    unfold lseg.
    Exists to_text_tail_ptr first_el_line_ptr.
    entailer!.
  }
  { entailer!. }
  { assert (i = Zlength big_sigma \/ i < Zlength big_sigma) as AA by lia.
    destruct AA as [AA | AA].
    { subst i.
      replace (sublist (Zlength big_sigma) (Zlength big_sigma) big_sigma) with ([] : list (Z * list byte)) by list_solve.
      unfold listrep. Intros.
      contradiction.
    }
    replace (sublist i (Zlength big_sigma) big_sigma) with (Znth i big_sigma :: (sublist (i + 1) (Zlength big_sigma) big_sigma)) by list_solve.
    unfold listrep; fold listrep.
    destruct (Znth i big_sigma) as (ith_shift, ith_line) eqn:eqn_ith_element.
    Intros ith_tail_ptr ith_line_ptr.
    forward.
    forward_call(Ews, ith_line, ith_line_ptr).
    do 3 forward.
    { entailer!. unnw. desf. }
    Exists (i + 1, ith_tail_ptr).
    entailer!.
    { split.
      { list_solve. }
      do 2 f_equal.
      remember ((first_el_shift, first_el_line) :: sigma) as big_sigma.
      remember (text_from_length_relation big_sigma i shift line).
      assert (0 <= i < Zlength big_sigma) as AE1 by list_solve.
      apply o in AE1.
      3: now lia.
      2: { apply mk_list_mp; try list_solve. }
      destruct AE1 as [AE | AE].
      { list_solve. }
      rewrite AE. rewrite eqn_ith_element.
      simpl.
      list_solve.
    }
    entailer!.
    assert (
      cstring Ews ith_line ith_line_ptr
      * malloc_token Ews (Tarray tschar (Zlength ith_line + 1) noattr) ith_line_ptr
      * malloc_token Ews t_list cur_to_text_ptr
      * data_at Ews t_list (Vlong (Int64.repr ith_shift), (ith_line_ptr, ith_tail_ptr)) cur_to_text_ptr
      * lseg (sublist 0 i ((first_el_shift, first_el_line) :: sigma)) p cur_to_text_ptr
      |--
      lseg (sublist 0 i ((first_el_shift, first_el_line) :: sigma)) p cur_to_text_ptr
      * (malloc_token Ews (Tarray tschar (Zlength ith_line + 1) noattr) ith_line_ptr
      * cstring Ews ith_line ith_line_ptr
      * malloc_token Ews t_list cur_to_text_ptr
      * data_at Ews t_list (Vlong (Int64.repr ith_shift), (ith_line_ptr, ith_tail_ptr)) cur_to_text_ptr )
    ).
    { entailer!. }
    eapply (derives_trans _ _ _); eauto.
    assert  (
      lseg (sublist 0 i ((first_el_shift, first_el_line) :: sigma)) p cur_to_text_ptr
      * lseg (sublist i (i + 1) ((first_el_shift, first_el_line) :: sigma)) cur_to_text_ptr ith_tail_ptr
      |-- lseg (sublist 0 (i + 1) ((first_el_shift, first_el_line) :: sigma)) p ith_tail_ptr
    ).
    { remember (lseg_lseg (sublist 0 i ((first_el_shift, first_el_line) :: sigma))
      (sublist i (i + 1) ((first_el_shift, first_el_line) :: sigma)) p cur_to_text_ptr ith_tail_ptr) as BB.
      replace ((sublist 0 (i + 1) ((first_el_shift, first_el_line) :: sigma))) with
      ((sublist 0 i ((first_el_shift, first_el_line) :: sigma)) ++ (sublist i (i + 1) ((first_el_shift, first_el_line) :: sigma)))
      by list_solve.
      apply BB.
    }
    eapply (derives_trans _ _ _). 2: eauto.
    entailer!.
    replace (sublist i (i + 1) ((first_el_shift, first_el_line) :: sigma))
      with [Znth i ((first_el_shift, first_el_line) :: sigma)] by list_solve.

    unfold lseg.
    rewrite eqn_ith_element.
    Exists ith_tail_ptr ith_line_ptr.
    entailer!.
  }
  forward.
  remember ((first_el_shift, first_el_line) :: sigma) as big_sigma.
  assert (i < Zlength big_sigma \/ i = Zlength big_sigma) as BB by lia.
  destruct BB.
  { replace ((sublist i (Zlength big_sigma) big_sigma)) with
      (Znth i big_sigma :: ((sublist (i + 1) (Zlength big_sigma) big_sigma)))
        by list_solve.
    unfold listrep; fold listrep.
    destruct (Znth i big_sigma).
    Intros x y.
    entailer!.
  }
  subst i.
  replace (sublist (Zlength big_sigma) (Zlength big_sigma) big_sigma)
    with ([] : list (Z * list byte)) by list_solve.
  replace (sublist 0 (Zlength big_sigma) big_sigma)
    with big_sigma by list_solve.
  unfold listrep; fold listrep.
  Intros.
  Exists (Zlength (text_from big_sigma (Z.to_nat shift) (list_byte_to_string line))).
  entailer!.
  apply lseg_null_listrep.
Qed.

Lemma body_format_copy: semax_body Vprog Gprog f_format_copy format_copy_spec.
Proof.
  start_function.
  forward_call(t_format, gv).
  Intros new_format_ptr.
  destruct(eq_dec new_format_ptr nullval).
  { forward_if(new_format_ptr <> nullval).
    { forward_call. entailer!. }
    { forward. entailer!. }
    now Intros.
  }
  forward_if(new_format_ptr <> nullval).
  { forward_call. entailer!. }
  { forward. entailer!. }

  Intros.
  do 9 forward.
  prove_ptr.

  getnw. destruct FMT_MP. destruct format_mp_list_mp.
  forward_call(Ews, pG, sigmaG, gv).
  { list_solve. }

  Intros new_list_ptr.
  do 2 forward.
  Exists new_format_ptr.
  entailer!.
  unfold mformat.
  unfold concrete_mformat.
  Exists sigmaG new_list_ptr; entailer!.
  split; apply mk_format_mp; auto; apply mk_list_mp; auto.
Qed.

Lemma text_from_concat (s1 s2 : list (Z * list byte)) (shift : nat) (line : string):
  s1 <> [] -> s2 <> [] ->
  text_from (s1 ++ s2) shift line =
  text_from s1 shift EmptyString ++ [Byte.repr 10] ++ shifted_text_from s2 shift ++ string_to_list_byte line.
Proof.
  ins.
  induction s1.
  { ins. }
  ins.
  desf.
  { autorewrite with sublist.
    replace s2 with (p :: l0) by list_solve.
    list_solve. }
  autorewrite with sublist.
  assert (p0 :: l1 <> []) as I by vauto.
  apply IHs1 in I.
  unfold text_from in I.
  desf.
  { inversion Heq. subst.
    replace (shifted_text_from [] shift ) with ([] : list  byte).
    2: { unfold shifted_text_from; auto. }
    autorewrite with sublist.
    list_solve. }
  { autorewrite with sublist in *.
    inversion Heq.
    subst.
    assert (shifted_text_from [(z0, l2)] shift =
      sp_byte (Z.to_nat z0 + shift) ++ l2) as F.
    { unfold shifted_text_from; auto. }
    rewrite F.
    assert (shifted_text_from ((z0, l2) :: p :: l3) shift =
      sp_byte (Z.to_nat z0 + shift) ++ l2 ++ [Byte.repr 10] ++ (shifted_text_from (p :: l3) shift)) as G.
    { reflexivity. }
    rewrite G.
    list_solve. }
  inversion Heq.
  subst.
  autorewrite with sublist norm in *.
  rewrite <- app_assoc in I; apply app_inv_head in I.
  rewrite <- app_assoc in I; apply app_inv_head in I.
  rewrite <- app_assoc in I; apply app_inv_head in I.
  assert (
    shifted_text_from (p :: l4) shift ++ Byte.repr 10 :: shifted_text_from s2 shift ++ string_to_list_byte line =
    (shifted_text_from (p :: l4) shift ++ Byte.repr 10 :: shifted_text_from s2 shift) ++ string_to_list_byte line
  ) as K.
  { apply (app_assoc
  (shifted_text_from (p :: l4) shift)
  (Byte.repr 10 :: shifted_text_from s2 shift )
  (string_to_list_byte line)
  ). }
  rewrite K in I.
  apply app_inv_tail in I.
  clear K IHs1 Heq H.
  rewrite <- app_assoc; apply app_inv_head_iff.
  rewrite <- app_assoc; apply app_inv_head_iff.
  assert (
    (Byte.repr 10 :: shifted_text_from ((z0, l2) :: p :: l4) shift) ++
    Byte.repr 10 :: shifted_text_from s2 shift ++ string_to_list_byte line =
    ((Byte.repr 10 :: shifted_text_from ((z0, l2) :: p :: l4) shift) ++
    Byte.repr 10 :: shifted_text_from s2 shift) ++ string_to_list_byte line
  ) as K.
  { apply (app_assoc
      (Byte.repr 10 :: shifted_text_from ((z0, l2) :: p :: l4) shift)
      (Byte.repr 10 :: shifted_text_from s2 shift)
      (string_to_list_byte line)
    ). }
  rewrite K.
  clear K.
  assert (Byte.repr 10 :: shifted_text_from ((z0, l2) :: p :: l4 ++ s2) shift ++
     string_to_list_byte line =
     (Byte.repr 10 :: shifted_text_from ((z0, l2) :: p :: l4 ++ s2) shift ) ++
     string_to_list_byte line) as K.
  { list_solve. }
  rewrite K.
  apply app_inv_tail_iff.
  clear K.
  replace (shifted_text_from ((z0, l2) :: p :: l4 ++ s2) shift)
    with (sp_byte (Z.to_nat z0 + shift) ++ l2 ++ [Byte.repr 10] ++ shifted_text_from (p :: l4 ++ s2) shift)
   by reflexivity.
  replace (shifted_text_from ((z0, l2) :: p :: l4) shift)
    with (sp_byte (Z.to_nat z0 + shift) ++ l2 ++ [Byte.repr 10] ++ shifted_text_from (p :: l4) shift)
    by reflexivity.
  rewrite I.
  list_solve.
Qed.

Lemma text_from_line (s : list (Z * list byte)) (shift : nat) (line : string):
  s <> [] ->
  text_from s shift line = text_from s shift EmptyString ++ string_to_list_byte line.
Proof.
  destruct s.
  { ins. }
  ins.
  desf.
  { autorewrite with sublist; list_solve. }
  list_solve.
Qed.

Lemma sp_eq_sp_byte (n : nat):
  string_to_list_byte (sp n) = sp_byte n.
Proof.
  induction n.
  { reflexivity. }
  unfold sp_byte; ins.
  rewrite IHn.
  unfold sp_byte; auto.
Qed.

Lemma sp_byte_app (n m : nat):
  sp_byte (n + m) = sp_byte n ++ sp_byte m.
Proof.
  unfold sp_byte.
  apply repeat_app.
Qed.

Lemma text_from_shifted_text_from_iff (s : list (Z * list byte)) (shift : nat):
  s <> [] ->
  sp_byte shift ++ text_from s shift EmptyString = shifted_text_from s shift.
Proof.
  destruct s.
  { ins. }
  ins; desf.
  { unfold shifted_text_from.
    autorewrite with sublist.
    rewrite app_assoc.
    apply app_inv_tail_iff.
    rewrite <- sp_byte_app.
    f_equal; lia. }
  autorewrite with sublist.
  replace (shifted_text_from ((z, l) :: p :: l0) shift) with
    (sp_byte (Z.to_nat z + shift) ++ l ++ [Byte.repr 10] ++ shifted_text_from (p :: l0) shift) by auto.
  rewrite Nat.add_comm.
  rewrite sp_byte_app.
  list_solve.
Qed.


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

(** Small example of interleave to compare
    our tailored fixpoint technique with
    "Program Fixpoint" and "Equations"

    You need Coq 8.9 + Equations installed for
    this to work *)

(** Summary:

    We have both the ability to prove properties of our defined
    function AND the extraction that we want.

    0) Function fails because no single argument
       decreases.

    1) Equations provides a framework where
       term are easy to define and the "simp" tactic
       gives the equations you want BUT
       extraction contains parasitic structures
       which are perhaps impossible to get rid of.

    2) Program Fixpoint allows easy definition
       with full specs but extraction presents
       the same problems as the Equations package.

    3) With induction ... on inlining a fixpoint,
       we can get equations and the intended
       extraction

 *)

From Equations Require Import Equations Signature.
Require Import List Arith Omega Wellfounded Program Extraction.

Require Import wf_utils.

Set Implicit Arguments.

Section interleave_naive.

  (** Naive implementation of interleave which does not
      respect the intended algorithm *)

  Variable (X : Type).

  Implicit Types (l m : list X).

  Fixpoint itl_triv l m :=
    match l, m with
      | nil, _       => m
      | x::l', y::m' => x::y::itl_triv l' m'
      | _, _         => l
    end.

  Fact itl_triv_fix_0 m : itl_triv nil m = m.
  Proof. trivial. Qed.

  Fact itl_triv_fix_1 x l m : itl_triv (x::l) m = x::itl_triv m l.
  Proof.
    revert m x.
    induction l as [ | a l IHl ];
    induction m as [ | b m IHm ]; intros x; try (simpl; auto; fail).
    simpl itl_triv at 2; rewrite <- IHl; auto.
  Qed.

  Section interleave_equations.

    Variable (f : list X -> list X -> list X) (Hf : forall l m, f l m = itl_triv l m).

    Fact interleave_eq_triv_0 m : f nil m = m.
    Proof. rewrite Hf, itl_triv_fix_0; trivial. Qed.

    Fact interleave_eq_triv_1 x l m : f (x::l) m = x :: f m l.
    Proof.
      do 2 rewrite Hf; apply itl_triv_fix_1.
    Qed.

  End interleave_equations.

End interleave_naive.

Section interleave_trials.

  Variable (X : Type).

  Implicit Types (l m : list X).

  (** Implementation of interleave using Program Fixpoint *)

  Section itl_pfix.

    Program Fixpoint itl_pfix_full l m { measure (length l+length m) } : { k | k = itl_triv l m } :=
      match l with
        | nil  => m
        | x::l => x::itl_pfix_full m l
      end.
    Obligation 2. simpl; omega. Qed.
    Obligation 3.
      destruct m; simpl; f_equal.
      * f_equal; apply (@proj2_sig _).
      * rewrite <- itl_triv_fix_1.
        apply (@proj2_sig _).
    Qed.

    Definition itl_pfix l m := proj1_sig (itl_pfix_full l m).

    Fact itl_pfix_spec l m : itl_pfix l m = itl_triv l m.
    Proof. apply (proj2_sig (itl_pfix_full l m)). Qed.

  End itl_pfix.

  (** Implementation of interleave using Equations, needs Coq v8.9 *)

  Section itl_eqs.

    Equations itl_eqs l m : list X by wf (length l + length m) lt :=
      itl_eqs nil     m  := m;
      itl_eqs (cons x l) m  with itl_eqs m l => { | r := x::r }.
    Obligation 1. omega. Qed.

    Fact itl_eqs_fix_0 m : itl_eqs nil m = m.
    Proof. trivial. Qed.

    Fact itl_eqs_fix_1 x l m : itl_eqs (x::l) m = x::itl_eqs m l.
    Proof. simp itl_eqs; trivial. Qed.

    Fact itl_eqs_triv l m : itl_eqs l m = itl_triv l m.
    Proof.
      revert m.
      induction l as [ | x l IHl ]; intros m.
      + rewrite itl_eqs_fix_0; trivial.
      + rewrite itl_eqs_fix_1, itl_triv_fix_1; f_equal.
        destruct m as [ | y m ].
        * rewrite itl_eqs_fix_0; trivial.
        * rewrite itl_eqs_fix_1, itl_triv_fix_1; f_equal; auto.
    Qed.

  End itl_eqs.

End interleave_trials.

Extract Inductive list => "list" [ "[]" "(::)" ].

Extraction Inline itl_pfix_full itl_pfix_full_func.

Extraction itl_triv.

Extraction itl_pfix.
Extraction itl_eqs.

Section itl_induction_on.

  Variable (X : Type).

  Implicit Types (l m : list X).

  (** Implementation of interleave using our tailored "induction on" tactic *)

  Definition itl_on_full l m : { k | k = itl_triv l m }.
  Proof.
    induction on l m as loop with measure (length l+length m).
    revert loop; refine (match l with
      | nil   => fun _    => exist _ m _
      | x::w => fun loop => let (r,Hr) := loop m w _ in exist _ (x::r) _
    end).
    * trivial.
    * simpl; omega.
    * subst; rewrite itl_triv_fix_1; trivial.
  Defined.

  Definition itl_on l m := proj1_sig (itl_on_full l m).

  Fact itl_on_spec l m : itl_on l m = itl_triv l m.
  Proof. apply (proj2_sig (itl_on_full _ _)). Qed.

  Hint Immediate itl_on_spec.

  Fact itl_on_fix_0 m : itl_on nil m = m.
  Proof. apply interleave_eq_triv_0; auto. Qed.

  Fact itl_on_fix_1 x l m : itl_on (x::l) m = x::itl_on m l.
  Proof. apply interleave_eq_triv_1; auto. Qed.

End itl_induction_on.

Extraction Inline itl_on_full.

Extraction itl_on.


Set Implicit Arguments.

Require Import set.
Require Import equiv.
Require Import subset_reflexive.

Proposition equiv_reflexive: forall (a:set), equiv a a.
Proof.
  intro a. unfold equiv. simpl. split. apply subset_reflexive.
  apply subset_reflexive.
Qed.


From Coq Require Import
  Lia Nat BinPos Pnat BinNat BinIntDef
  Arith ZArith.Int Numbers.BinNums
  NArith.Nnat.
Import PeanoNat.Nat.
Require Import ProofIrrelevance.
Import EqNotations.
Import BinInt.Z(of_nat, to_nat, opp,
                sub, add, mul, pow,
                leb, le, ltb, lt).

(*Don't know where to put these.*)
Theorem rew_id : forall A (P : A -> Type) (a : A) (e : a = a) (k : P a),
  rew [fun x : A => P x] e in k = k.
Proof.
  intros A P a e k.
  replace e with (Logic.eq_refl a).
  - reflexivity.
  - apply proof_irrelevance.
Qed.

Theorem rew_f_bubble :
  forall A (P : A -> Type) (Q : A -> Type) (f : forall x, P x -> Q x)
  (a b : A) (e : a = b) (k : P a),
  f _ (rew [fun x : A => P x] e in k) =
  rew [fun x : A => Q x] e in (f _ k).
Proof. intros A P Q f a b []; reflexivity. Qed.

Theorem subset_eq_proj1 :
  forall {A} {P : A -> Prop} (k1 k2 : { x | P x }),
  proj1_sig k1 = proj1_sig k2 -> k1 = k2.
Proof.
  intros A P [k1 k1P] [k2 k2P].
  simpl. intros eq.
  apply subset_eq_compat.
  assumption.
Qed.

Theorem depEqLem :
  forall (B : Type)
         (F : B -> Type)
         (P : forall b : B, F b -> Prop)
         (b1 b2 : B) (eqb : b1 = b2)
         (p1 : F b1) (p2 : F b2),
         (rew eqb in p1 = p2) ->
         P b1 p1 ->
         P b2 p2.
Proof.
  intros B F P b1 b2 eqb.
  destruct eqb.
  intros p1 p2 eqp.
  destruct eqp.
  intros Pp.
  exact Pp.
Qed.

Theorem dep_if_true :
  forall x (P : Set)
           (t : forall (e : x = true), P)
           (f : forall (e: x = false), P)
           (eq : x = true),
  ( if x as b return (x = b -> P)
    then t
    else f ) Logic.eq_refl
  = t eq.
Proof.
  intros x P t f eq.
  destruct x.
  - f_equal; apply proof_irrelevance.
  - discriminate eq.
Qed.

Theorem dep_if_false :
  forall x (P : Set)
           (t : forall (e : x = true), P)
           (f : forall (e: x = false), P)
           (eq : x = false),
  ( if x as b return (x = b -> P)
    then t
    else f ) Logic.eq_refl
  = f eq.
Proof.
  intros x P t f eq.
  destruct x.
  - discriminate eq.
  - f_equal; apply proof_irrelevance.
Qed.

Theorem plus_reg_r : forall n m p : nat, n + p = m + p -> n = m.
Proof.
  intros n m p.
  induction p as [|p IHp].
  + repeat rewrite add_0_r; trivial.
  + repeat rewrite <- plus_n_Sm.
    intro eq.
    injection eq as eq2.
    apply IHp.
    exact eq2.
Qed.

Definition lt_sub:
  forall {n m}, n < m -> {p : nat | m = p + n /\ 0 < p}.
    intros n m.
    generalize dependent n.
    induction m as [|m IHm]; intros n lnm.
    - destruct (nlt_0_r _ lnm).
    - destruct n as [|n].
      + exists (S m).
        lia.
      + apply Lt.lt_S_n in lnm.
        destruct (IHm n lnm).
        exists x.
        lia.
Defined.

Definition le_sub:
  forall {n m}, n <= m -> {p : nat | m = p + n /\ 0 <= p}.
  intros n m.
  generalize dependent n.
  induction m as [|m IHm]; intros n lnm.
  - exists 0.
    lia.
  - destruct n as [|n].
    + exists (S m).
      lia.
    + apply Le.le_S_n in lnm.
      destruct (IHm n lnm).
      exists x.
      lia.
Defined.

Theorem log2_upS_Slog2 : forall x,
  x > 1 -> log2_up (S x) = S (log2 x).
Proof.
  intro x; destruct x; [ lia | ].
  reflexivity.
Qed.

Theorem log2_up_ajoint_lem : forall {x}, ~ (2 ^ x < 1).
Proof.
  intro x; induction x as [|x IHx].
  - simpl; lia.
  - intro. apply IHx.
    transitivity (2 ^ S x); [ | assumption ].
    simpl; lia.
Qed.

(* Adjoint theorem/Galois connection defining ceiling log2 *)
Theorem log2_up_lt_pow2 : forall (x y : nat),
  (2 ^ x < y) <-> (x < log2_up y).
Proof.
  intros x y.
  destruct (0 <? y) eqn:g0y.
  - apply log2_up_lt_pow2.
    rewrite ltb_lt in g0y.
    assumption.
  - rewrite ltb_ge in g0y.
    destruct y; [ | lia ].
    split; [ lia | ].
    unfold log2_up; simpl.
    lia.
Qed.

Theorem mod_2_0or1 : forall n, (n mod 2 = 0) \/ (n mod 2 = 1).
Proof.
  intro.
  induction n as [|n IHn].
  - auto.
  - replace (S n) with (1 + n); [ | reflexivity ].
    rewrite add_mod; [ | lia ].
    destruct IHn.
    + right.
      rewrite H.
      reflexivity.
    + left.
      rewrite H.
      reflexivity.
Qed.

Theorem neq0_div_lt : forall a b c,
  b <> 0 -> a < c -> a / b < c.
Proof.
  intros.
  apply div_lt_upper_bound; [ assumption | ].
  apply (lt_le_trans _ c); [ assumption | ].
  destruct (Mult.mult_O_le c b).
  + destruct (H H1).
  + exact H1.
Qed.

Theorem add_sub_distr: forall n m p : nat,
  p <= m -> m <= n ->
  n - (m - p) = n - m + p.
Proof.
  intros n m p lpm lmpn.
  apply add_sub_eq_r.
  rewrite <- add_assoc.
  rewrite le_plus_minus_r; [ | assumption ].
  rewrite sub_add; trivial.
Qed.

Theorem div_bet_1 :
  forall {n m}, m <= n < 2 * m -> n / m = 1.
Proof.
  intros n m [lmn ln2m].
  assert (m <> 0); [ lia | ].
  apply (div_le_mono _ _ _ H) in lmn.
  rewrite div_same in lmn; [ | lia ].
  rewrite mul_comm in ln2m.
  apply (div_lt_upper_bound _ _ _ H) in ln2m.
  lia.
Qed.

Theorem zero2pow : forall n, 0 < 2 ^ n.
Proof.
  destruct n. { simpl; lia. }
  change 0 with (0 ^ S n); apply pow_lt_mono_l; lia.
Qed.

Theorem opp_sub_swap : forall n m, opp (sub n m) = sub m n.
Proof.
  intros n m.
  rewrite <- BinInt.Z.opp_involutive.
  repeat rewrite BinInt.Z.opp_sub_distr.
  rewrite BinInt.Z.opp_add_distr.
  rewrite BinInt.Z.opp_involutive.
  rewrite BinInt.Z.add_comm.
  reflexivity.
Qed.

Theorem negb_inj : forall x y, negb x = negb y -> x = y.
Proof.
  destruct x, y; trivial; simpl; intro H; discriminate H.
Qed.

Theorem Z_ltb_lt : forall n m : Z, (ltb n m) = true <-> lt n m.
Proof.
  intros n m; split.
  - destruct n, m; intro H; unfold ltb in H; simpl in H; try lia;
    unfold lt; simpl; destruct (BinPos.Pos.compare _ _); trivial;
    discriminate H.
  - destruct n, m; intro H; unfold ltb; simpl; try lia;
    unfold lt in H; simpl in H; destruct (BinPos.Pos.compare _ _); trivial;
    discriminate H.
Qed.

Theorem Z_leb_le : forall n m : Z, (leb n m) = true <-> le n m.
Proof.
  intros n m; split.
  - destruct n, m; intro H; unfold leb in H; simpl in H; try lia;
    unfold le; simpl; destruct (BinPos.Pos.compare _ _); trivial;
    try discriminate H; intro H2; discriminate H2.
  - destruct n, m; intro H; unfold leb; simpl; try lia;
    unfold le in H; simpl in H;
    repeat destruct (BinPos.Pos.compare _ _); simpl; trivial;
    try discriminate H; destruct (H (Logic.eq_refl _)).
Qed.

Theorem Z_nltb_ge : forall n m : Z, (ltb n m) = false <-> le m n.
Proof.
  intros n m.
  transitivity ((leb m n) = true). 2: { apply Z_leb_le. }
  split; intro; apply negb_inj.
  - rewrite <- BinInt.Z.ltb_antisym.
    exact H.
  - rewrite <- BinInt.Z.leb_antisym.
    exact H.
Qed.

Theorem Z_nleb_gt : forall n m : Z, (leb n m) = false <-> lt m n.
Proof.
  intros n m.
  transitivity ((ltb m n) = true). 2: { apply Z_ltb_lt. }
  split; intro; apply negb_inj.
  - rewrite <- BinInt.Z.leb_antisym.
    exact H.
  - rewrite <- BinInt.Z.ltb_antisym.
    exact H.
Qed.

Theorem opp_le_swap_r: forall n m : Z, le n (opp m) <-> le m (opp n).
Proof.
  intros n m.
  rewrite <- (BinInt.Z.opp_involutive n) at 1.
  rewrite <- BinInt.Z.opp_le_mono.
  reflexivity.
Qed.

Theorem opp_le_swap_l: forall n m : Z, le (opp n) m <-> le (opp m) n.
Proof.
  intros n m.
  rewrite <- (BinInt.Z.opp_involutive m) at 1.
  rewrite <- BinInt.Z.opp_le_mono.
  reflexivity.
Qed.

Theorem opp_lt_swap_l: forall n m : Z, lt (opp n) m <-> lt (opp m) n.
Proof.
  intros n m.
  rewrite <- (BinInt.Z.opp_involutive m) at 1.
  rewrite <- BinInt.Z.opp_lt_mono.
  reflexivity.
Qed.

Theorem Z_inj_pow : forall x y,
  pow (of_nat x) (of_nat y) = of_nat (x ^ y).
Proof.
  intros x y.
  induction y.
  - reflexivity.
  - rewrite Znat.Nat2Z.inj_succ, BinInt.Z.pow_succ_r.
    2: { apply Zorder.Zle_0_nat. }
    rewrite IHy.
    simpl; rewrite Znat.Nat2Z.inj_mul.
    reflexivity.
Qed.

Theorem Z2_inj_pow : forall x y,
  le Z0 x -> le Z0 y ->
  to_nat (pow x y) = to_nat x ^ to_nat y.
Proof.
  intros x y l0x l0y.
  rewrite <- (Znat.Z2Nat.id x), <- (Znat.Z2Nat.id y) at 1; try assumption.
  rewrite Z_inj_pow, Znat.Nat2Z.id.
  reflexivity.
Qed.

Theorem le_opp_intro_l : forall n m,
  le Z0 n ->
  le m Z0 ->
  le n m -> le (opp m) n.
Proof. intros n m npos mneg lnm; lia. Qed.

Theorem le_opp_elim_l : forall n m,
  le Z0 m ->
  le n Z0 ->
  le (opp m) n -> le n m.
Proof. intros n m npos mneg lnm; lia. Qed.

Theorem le_opp_intro_r : forall n m,
  le Z0 n ->
  le m Z0 ->
  le n m -> le m (opp n).
Proof. intros n m npos mneg lnm; lia. Qed.

Theorem le_opp_elim_r : forall n m,
  le Z0 m ->
  le n Z0 ->
  le m (opp n) -> le n m.
Proof. intros n m npos mneg lnm; lia. Qed.

Theorem le_opp_mul_mul : forall p1 p2 t1 t2,
  le (opp p1) t1 -> le (opp p2) t2 ->
  lt t1 p1 -> lt t2 p2 ->
  le (opp (mul p1 p2)) (mul t1 t2).
Proof.
  intros.
  assert (lt Z0 p1); [ lia | ].
  assert (lt Z0 p2); [ lia | ].
  destruct (ltb t1 Z0) eqn:zt1;
  destruct (ltb t2 Z0) eqn:zt2;
  try rewrite Z_ltb_lt in zt1;
  try rewrite Z_ltb_lt in zt2;
  try rewrite Z_nltb_ge in zt1;
  try rewrite Z_nltb_ge in zt2;
  try lia.
  - rewrite opp_le_swap_l, <- BinInt.Z.mul_opp_l.
    apply BinInt.Z.mul_le_mono_nonneg; lia.
  - rewrite opp_le_swap_l, <- BinInt.Z.mul_opp_r.
    apply BinInt.Z.mul_le_mono_nonneg; lia.
Qed.

Theorem lt_opp_mul_mul : forall p1 p2 t1 t2,
  lt (opp p1) t1 -> lt (opp p2) t2 ->
  lt t1 p1 -> lt t2 p2 ->
  lt (opp (mul p1 p2)) (mul t1 t2).
Proof.
  intros.
  assert (lt Z0 p1); [ lia | ].
  assert (lt Z0 p2); [ lia | ].
  destruct (ltb t1 Z0) eqn:zt1;
  destruct (ltb t2 Z0) eqn:zt2;
  try rewrite Z_ltb_lt in zt1;
  try rewrite Z_ltb_lt in zt2;
  try rewrite Z_nltb_ge in zt1;
  try rewrite Z_nltb_ge in zt2;
  try lia.
  - rewrite opp_lt_swap_l, <- BinInt.Z.mul_opp_l.
    apply BinInt.Z.mul_lt_mono_nonneg; lia.
  - rewrite opp_lt_swap_l, <- BinInt.Z.mul_opp_r.
    apply BinInt.Z.mul_lt_mono_nonneg; lia.
Qed.

Theorem lt_mul_mul : forall p1 p2 t1 t2,
  lt (opp p1) t1 -> lt (opp p2) t2 ->
  lt t1 p1 -> lt t2 p2 ->
  lt (mul t1 t2) (mul p1 p2).
Proof.
  intros.
  assert (lt Z0 p1); [ lia | ].
  assert (lt Z0 p2); [ lia | ].
  destruct (ltb t1 Z0) eqn:zt1;
  destruct (ltb t2 Z0) eqn:zt2;
  try rewrite Z_ltb_lt in zt1;
  try rewrite Z_ltb_lt in zt2;
  try rewrite Z_nltb_ge in zt1;
  try rewrite Z_nltb_ge in zt2;
  try lia.
  - rewrite <- BinInt.Z.mul_opp_opp.
    apply BinInt.Z.mul_lt_mono_nonneg; lia.
  - apply BinInt.Z.mul_lt_mono_nonneg; try lia.
Qed.

Theorem le_mul_mul : forall p1 p2 t1 t2,
  le (opp p1) t1 -> le (opp p2) t2 ->
  lt t1 p1 -> lt t2 p2 ->
  le (mul t1 t2) (mul p1 p2).
Proof.
  intros.
  assert (lt Z0 p1); [ lia | ].
  assert (lt Z0 p2); [ lia | ].
  destruct (ltb t1 Z0) eqn:zt1;
  destruct (ltb t2 Z0) eqn:zt2;
  try rewrite Z_ltb_lt in zt1;
  try rewrite Z_ltb_lt in zt2;
  try rewrite Z_nltb_ge in zt1;
  try rewrite Z_nltb_ge in zt2;
  try lia.
  - rewrite <- BinInt.Z.mul_opp_opp.
    apply BinInt.Z.mul_le_mono_nonneg; lia.
  - apply BinInt.Z.mul_le_mono_nonneg; try lia.
Qed.

(* Some binary nat theorems which aren't present in
   the Coq version that ITrees likes. *)

Theorem Nat2N_inj_pow:
  forall n n' : nat,
  N.of_nat (n ^ n') =
  (N.of_nat n ^ N.of_nat n')%N.
Proof.
  intros.
  generalize dependent n.
  induction n';[reflexivity|].
  intro.
  rewrite Nnat.Nat2N.inj_succ.
  rewrite N.pow_succ_r'.
  rewrite <- IHn'.
  rewrite PeanoNat.Nat.pow_succ_r'.
  apply Nnat.Nat2N.inj_mul.
Qed.

Theorem N2Nat_inj_pow:
  forall n n' : N,
  N.to_nat (n ^ n') =
  (N.to_nat n ^ N.to_nat n').
Proof.
  intros.
  rewrite <- Nat2N.id.
  rewrite Nat2N_inj_pow.
  repeat rewrite N2Nat.id.
  reflexivity.
Qed.

Lemma inj_compare a a' :
 (a ?= a')%N = (N.to_nat a ?= N.to_nat a').
Proof.
 destruct a as [|p], a' as [|p']; simpl; trivial.
 - now destruct (Pos2Nat.is_succ p') as (n,->).
 - now destruct (Pos2Nat.is_succ p) as (n,->).
 - apply Pos2Nat.inj_compare.
Qed.

Theorem N2Nat_inj_mod n n' :
  n' <> N0 ->
  N.to_nat (n mod n') =
  (N.to_nat n mod N.to_nat n').
Proof.
  intros.
  destruct n' as [|n']; [now destruct n|].
  apply PeanoNat.Nat.mod_unique
   with (N.to_nat (n / (N.pos n'))).
  - apply PeanoNat.Nat.compare_lt_iff.
    rewrite <- inj_compare.
    apply N.mod_lt.
    intro H0; discriminate H0.
  - now rewrite <- N2Nat.inj_mul, <- N2Nat.inj_add, <- N.div_mod.
Qed.

Theorem Nat2N_inj_mod:
  forall n n' : nat,
  n' <> 0 ->
  N.of_nat (n mod n') =
  (N.of_nat n mod N.of_nat n')%N.
Proof.
  intros.
  apply N2Nat.inj.
  rewrite N2Nat_inj_mod;[|lia].
  now repeat rewrite Nat2N.id.
Qed.

Theorem N2Nat_inj_div n n' :
  n' <> N0 ->
  N.to_nat (n / n') =
  (N.to_nat n / N.to_nat n').
Proof.
  intros.
  destruct n' as [|n']; [now destruct n|].
  apply PeanoNat.Nat.div_unique
  with (N.to_nat (n mod (N.pos n'))).
  - apply PeanoNat.Nat.compare_lt_iff.
    rewrite <- inj_compare.
    apply N.mod_lt; lia.
  - now rewrite <- N2Nat.inj_mul, <- N2Nat.inj_add, <- N.div_mod.
Qed.

Theorem Nat2N_inj_div:
  forall n n' : nat,
  n' <> 0 ->
  N.of_nat (n / n') =
  (N.of_nat n / N.of_nat n')%N.
Proof.
  intros.
  apply N2Nat.inj.
  rewrite N2Nat_inj_div;[|lia].
  now repeat rewrite Nat2N.id.
Qed.

Theorem N2Nat_inj_lt:
  forall n m : N, (n < m)%N <-> (N.to_nat n < N.to_nat m)%nat.
Proof.
 destruct n as [|p], m as [|p']; simpl.
 - split.
   + intro H.
     apply (N.lt_irrefl _) in H.
     contradiction.
   + intro H.
     apply (lt_irrefl _) in H.
     contradiction.
 - destruct (Pos2Nat.is_succ p') as (n,->).
   split.
   + intro H.
     apply lt_0_succ.
   + intro H.
     now apply (N.ltb_lt 0 (N.pos p')).
 - destruct (Pos2Nat.is_succ p) as (n,->).
   split.
   + intro H.
     apply (N.ltb_lt (N.pos p) 0) in H.
     inversion H.
   + intro H.
     apply (ltb_lt (S n) 0) in H.
     inversion H.
 - apply Pos2Nat.inj_lt.
Qed.

Theorem N2Nat_inj_le:
  forall n m : N, (n <= m)%N <-> (N.to_nat n <= N.to_nat m)%nat.
Proof.
 destruct n as [|p], m as [|p']; simpl.
 - split.
   + intro H.
     apply le_refl.
   + intro H.
     apply N.le_refl.
 - destruct (Pos2Nat.is_succ p') as (n,->).
   split.
   + intro H.
     apply le_0_l.
   + intro H.
     now apply (N.leb_le 0 (N.pos p')).
 - destruct (Pos2Nat.is_succ p) as (n,->).
   split.
   + intro H.
     apply (N.leb_le (N.pos p) 0) in H.
     inversion H.
   + intro H.
     apply (leb_le (S n) 0) in H.
     inversion H.
 - apply Pos2Nat.inj_le.
Qed.

Theorem mod_2_div : forall k, k mod 2 = 0 -> k / 2 = S k / 2.
Proof.
  assert (forall k,
            (k mod 2 = 0 -> k / 2 = S k / 2) /\
            (k mod 2 = 1 -> S k / 2 = S (S k) / 2));[|
  intro k; destruct (H k); assumption].
  induction k;[simpl;lia|destruct IHk];
  split; intro.
  - apply H0.
    change k with (0 + k).
    rewrite <- H1 at 1.
    rewrite PeanoNat.Nat.add_mod_idemp_l;[|lia].
    replace (S k + k) with (1 + 2 * k);[|lia].
    rewrite <- PeanoNat.Nat.add_mod_idemp_r;[|lia].
    rewrite PeanoNat.Nat.mul_comm, PeanoNat.Nat.mod_mul;simpl;lia.
  - assert (forall k, S (S k) / 2 = S (k / 2));[
        intro k2;change (S (S k2)) with (1 * 2 + k2);
        rewrite PeanoNat.Nat.div_add_l; lia|].
    repeat rewrite H2.
    f_equal.
    apply H.
    change (S k) with (1 + k) in H1.
    replace 0 with ((2 + k) mod 2) at 2;[|
      replace (2 + k) with (1 + (1 + k));[|lia];
      rewrite <- PeanoNat.Nat.add_mod_idemp_r, H1;
      simpl; lia].
    rewrite <- PeanoNat.Nat.add_mod_idemp_l; simpl; lia.
Qed.

Theorem nmod_2_0 : forall k, k mod 2 <> 0 -> k mod 2 = 1.
Proof.
  assert (forall k,
            (k mod 2 <> 0 -> k mod 2 = 1) /\
            (k mod 2 <> 1 -> k mod 2 = 0));[|
  intro k; destruct (H k); assumption].
  induction k;[simpl;lia|destruct IHk];
  split; intro;
  change (S k) with (1 + k);
  rewrite <- PeanoNat.Nat.add_mod_idemp_r;
  try lia.
  - rewrite H0;[reflexivity|].
    intro.
    change (S k) with (1 + k) in H1.
    rewrite <- PeanoNat.Nat.add_mod_idemp_r in H1.
    rewrite H2 in H1; simpl in H1.
    all: lia.
  - rewrite H;[reflexivity|].
    intro.
    change (S k) with (1 + k) in H1.
    rewrite <- PeanoNat.Nat.add_mod_idemp_r in H1.
    rewrite H2 in H1; simpl in H1.
    all: lia.
Qed.


Require Import Lia.
Lemma arith : forall a, a = 0 <-> S a = 1. Proof. lia. Qed.


Definition NtoB := nat -> bool.

Definition NtoB_eqv (g h : NtoB) : Prop := forall i, g i = h i.

Parameter f : nat -> NtoB.
Axiom f_surjective : forall (g : NtoB), exists n, NtoB_eqv (f n) g.

Definition task := False.


Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma prime14139308836963 : prime 14139308836963.
Proof.
 apply (Pocklington_refl
         (Pock_certif 14139308836963 2 ((10607, 1)::(2,1)::nil) 6921)
        ((Proof_certif 10607 prime10607) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Qed.

Lemma prime6789012345678901234567903: prime  6789012345678901234567903.
apply (Pocklington_refl

(SPock_certif
6789012345678901234567903
2
((14139308836963, 1)::nil))
( (Proof_certif 14139308836963 prime14139308836963) :: nil)).
vm_cast_no_check (refl_equal true).
Time Qed.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Section Berardis_paradox.

Hypothesis EM : forall P:Prop, P \/ ~ P.

Definition IFProp (P B:Prop) (e1 e2:P) :=
match EM B with
| or_introl _ => e1
| or_intror _ => e2
end.

Lemma AC_IF :
forall (P B:Prop) (e1 e2:P) (Q:P -> Prop),
(B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2).
Proof. hammer_hook "Berardi" "Berardi.AC_IF".
intros P B e1 e2 Q p1 p2.
unfold IFProp.
case (EM B); assumption.
Qed.

Variable Bool : Prop.
Variable T : Bool.
Variable F : Bool.

Definition pow (P:Prop) := P -> Bool.

Section Retracts.

Variables A B : Prop.

Record retract : Prop :=
{i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}.
Record retract_cond : Prop :=
{i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}.

Lemma AC : forall r:retract_cond, retract -> forall a:A, r.(j2) (r.(i2) a) = a.
Proof. hammer_hook "Berardi" "Berardi.AC".   intros r. exact r.(inv2). Qed.

End Retracts.

Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B).
Proof. hammer_hook "Berardi" "Berardi.L1".
intros A B.
destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf].
exists f0 g0; trivial.
exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros;
destruct hf; auto.
Qed.

Definition U := forall P:Prop, pow P.

Definition f (u:U) : pow U := u U.

Definition g (h:pow U) : U :=
fun X => let lX := j2 (L1 X U) in let rU := i2 (L1 U U) in lX (rU h).

Lemma retract_pow_U_U : retract (pow U) U.
Proof. hammer_hook "Berardi" "Berardi.retract_pow_U_U".
exists g f.
intro a.
unfold f, g; simpl.
apply AC.
exists (fun x:pow U => x) (fun x:pow U => x).
trivial.
Qed.

Definition Not_b (b:Bool) := IFProp (b = T) F T.

Definition R : U := g (fun u:U => Not_b (u U u)).

Lemma not_has_fixpoint : R R = Not_b (R R).
Proof. hammer_hook "Berardi" "Berardi.not_has_fixpoint".
unfold R at 1.
unfold g.
rewrite AC.
trivial.
exists (fun x:pow U => x) (fun x:pow U => x).
trivial.
Qed.

Theorem classical_proof_irrelevence : T = F.
Proof. hammer_hook "Berardi" "Berardi.classical_proof_irrelevence".
generalize not_has_fixpoint.
unfold Not_b.
apply AC_IF.
intros is_true is_false.
elim is_true; elim is_false; trivial.

intros not_true is_true.
elim not_true; trivial.
Qed.

End Berardis_paradox.


Require Import Coq.Program.Equality.
Require Import Coqlib.
Require Import ParserArg.
Import MIPS_PARSER_ARG.

Set Implicit Arguments.

Inductive void : Type := .

(** Syntax for the types returned by a grammar *)
Inductive xtype : Type :=
| xUnit_t : xtype
| xChar_t : xtype
| xVoid_t : xtype
| xPair_t : xtype -> xtype -> xtype
| xSum_t : xtype -> xtype -> xtype
| xList_t : xtype -> xtype.

Definition type_dec : forall (t1 t2:xtype), {t1=t2} + {t1<>t2}.
  decide equality.
Defined.

(** Interpret the type syntax as a Coq type. *)
Fixpoint xt_interp (t:xtype) : Type :=
  match t with
    | xUnit_t => unit
    | xChar_t => char_p
    | xVoid_t => void
    | xPair_t t1 t2 => (xt_interp t1) * (xt_interp t2)
    | xSum_t t1 t2 => (xt_interp t1) + (xt_interp t2)
    | xList_t t1 => list (xt_interp t1)
  end%type.

(** Syntax for transforms (functions) that map from one type to
      another.  This little first-order language uses a variable-
      free representation (similar to sequents) to avoid messing with
      issues around lambda representations. *)
Reserved Notation "t1 ->> t2" (left associativity, at level 69, t2 at next level).
Inductive xform : xtype -> xtype -> Type :=
| Xid    : forall {t}, t ->> t
| Xzero  : forall {t}, xVoid_t ->> t
| Xcomp  : forall {t1 t2 t3}, (t1 ->> t2) -> (t2 ->> t3) -> (t1 ->> t3)
| Xchar  : forall {t}, char_p -> t ->> xChar_t
| Xunit  : forall {t}, t ->> xUnit_t
| Xempty : forall {t1 t2}, t1 ->> xList_t t2
| Xpair  : forall {t t1 t2}, (t ->> t1) -> (t ->> t2) -> (t ->> xPair_t t1 t2)
| Xfst   : forall {t1 t2}, (xPair_t t1 t2) ->> t1
| Xsnd   : forall {t1 t2}, (xPair_t t1 t2) ->> t2
| Xinl   : forall {t1 t2}, t1 ->> (xSum_t t1 t2)
| Xinr   : forall {t1 t2}, t2 ->> (xSum_t t1 t2)
| Xmatch : forall {t t1 t2},  (t1 ->> t) -> (t2 ->> t) -> (xSum_t t1 t2 ->> t)
| Xcons  : forall {t1 t2}, (t1 ->> t2) -> (t1 ->> xList_t t2) -> (t1 ->> xList_t t2)
| Xfoldr : forall {t1 t2 t3},
             (xPair_t t1 t2 ->> t2) -> (t3 ->> t2) -> (t3 ->> xList_t t1) -> t3 ->> t2
where "t1 ->> t2" := (xform t1 t2).

(** These declarations ensure that the types will be erased upon extraction.
    But we must make sure not to ever eliminate these types... *)
Extraction Implicit Xid [t].
Extraction Implicit Xzero [t].
Extraction Implicit Xcomp [t1 t2 t3].
Extraction Implicit Xchar [t].
Extraction Implicit Xunit [t].
Extraction Implicit Xempty [t1 t2].
Extraction Implicit Xpair [t t1 t2].
Extraction Implicit Xfst [t1 t2].
Extraction Implicit Xsnd [t1 t2].
Extraction Implicit Xinl [t1 t2].
Extraction Implicit Xinr [t1 t2].
Extraction Implicit Xmatch [t1 t2 t].
Extraction Implicit Xcons [t1 t2].
Extraction Implicit Xfoldr [t1 t2 t3].

(** Interpret the transform syntax as a Coq function.  Note that
      this is really a "compiler" of sorts in that we are able to
      translate all of the sub-terms at compile-time, so we don't
      pay the pattern-match cost at run-time.
 *)
Fixpoint xinterp {t1 t2} (x: t1 ->> t2) : xt_interp t1 -> xt_interp t2 :=
  match x in t1 ->> t2 return xt_interp t1 -> xt_interp t2 with
    | Xid => fun x => x
    | Xzero => fun (x:xt_interp xVoid_t) => match x with end
    | Xcomp f1 f2 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      fun x => f2' (f1' x)
    | Xchar c => fun _ => c
    | Xunit => fun _ => tt
    | Xempty => fun x => nil
    | Xpair f1 f2 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      fun x => (f1' x, f2' x)
    | Xfst => fst
    | Xsnd => snd
    | Xinl => inl
    | Xinr => inr
    | Xmatch f1 f2 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      fun x =>
        match x with
          | inl x1 => f1' x1
          | inr x2 => f2' x2
        end
    | Xcons f1 f2 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      fun x => (f1' x)::(f2' x)
    | Xfoldr f1 f2 f3 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      let f3' := xinterp f3 in
      fun x => List.fold_right (fun a b => f1' (a,b)) (f2' x) (f3' x)
  end.
Extraction Implicit xinterp [t1 t2].

(** * Optimize an [xform]. *)

(* Here are the optimizations we do on transforms.  I'm using ";" to
     abbreviate composition, and the other abbreviations should be obvious.
     Our primary goal is to get rid of obvious reductions like constructing
     a pair, and then immediately projecting out the first component.  Along
     the way, we effectively get rid of composition (similar to cut-elimination)
     so that as many of the reductions fire as possible.  We also do some
     "eta-like" reductions (e.g., (fst,snd) = id), but not all of those that
     are possible yet.

     id ; f => f
     zero ; f => zero

     f ; id => f
     f ; (f1 ; f2) => (f ; f1) ; f2
     f ; char c => char c
     f ; unit => unit
     f ; empty => empty
     f ; (g1, g2) => (f;g1, f;g2)
     f ; g1::g2 => (f;g1)::(f;g2)
     f ; foldr g1 g2 g3 => foldr g1 (f ; g2) (f ; g3)

     (f1,f2) ; fst => f1
     (f1,f2) ; snd => f2
     inl ; match f1 f2 => f1
     inr ; match f1 f2 => f2
     foldr f1 f2 empty => f2
     foldr f1 f2 (f3::f4) => (f3, foldr f1 f2 f4) ; f1

     foldr f1 f2 zero => zero
     foldr f1 zero f3 => zero
     pair zero f => zero
     pair f zero => f
     cons zero f => zero
     cons f zero => zero

     (fst, snd) => id
     match inl inr => id

     I'd like to add support for the "eta" rule for lists:
       foldr (fst::snd) empty f => f
     but haven't bothered to yet.

     Finally, it may be necessary to call the rewriting multiple times
     to get a normal form, since I wasn't able to make all of the
     reductions mutually recursive as they need to be.
   *)

(** Need some explicit casting to get things to type-check. *)
Definition xcoerce t1 t2 t3 t4 (x:xform t1 t2) : t1 = t3 -> t2 = t4 -> xform t3 t4.
  intros. subst. apply x.
Defined.
Extraction Implicit xcoerce [t1 t2 t3 t4].

(** A note:  It would be much more natural to index [grammar] and [xform] by
    the corresponding Coq [Type]s instead of my own internal [type] syntax,
    which then has to be interpreted.  In particular, I could get rid of
    the need to use [Extraction Implicit] which is a bit of a hack for
    getting rid of the [type]s in the extracted code.  However, I wouldn't
    be able to prove these crucial injectivity properties of sums and
    products. *)
Definition eq_pair_fst t1 t2 t3 t4 : (xPair_t t1 t2 = xPair_t t3 t4) -> t3 = t1.
  intros ; injection H. intros. apply (eq_sym H1).
Defined.
Definition eq_pair_snd t1 t2 t3 t4 : (xPair_t t1 t2 = xPair_t t3 t4) -> t4 = t2.
  intros ; injection H. intros. apply (eq_sym H0).
Defined.
Definition eq_sum_fst t1 t2 t3 t4 : (xSum_t t1 t2 = xSum_t t3 t4) -> t3 = t1.
  intros ; injection H. intros. apply (eq_sym H1).
Defined.
Definition eq_sum_snd t1 t2 t3 t4 : (xSum_t t1 t2 = xSum_t t3 t4) -> t4 = t2.
  intros ; injection H. intros. apply (eq_sym H0).
Defined.
Definition list_t_eq : forall t1 t2, (xList_t t1 = xList_t t2) -> t2 = t1.
  intros. injection H. intro. apply (eq_sym H0).
Defined.
Definition pair_eq_snd t1 t2 t3 t4 : xPair_t t3 t4 = xPair_t t1 t2 ->
                                     xPair_t t1 t2 = xPair_t t1 t4.
Proof. intros. injection H. intros ; subst. auto.
Defined.
Definition pair_eq_fst t1 t2 t3 : t1 = t2 -> xPair_t t1 t3 = xPair_t t2 t3.
Proof. intro. subst. auto. Defined.
Definition sum_eq tf th td tc : xSum_t tf th = xSum_t td tc -> xSum_t td th = xSum_t td tc.
  intro. injection H. intros. subst. auto.
Defined.
Lemma two_pair {w tb tc u2 u3} :
  (w = xPair_t tb tc) -> (w = xPair_t u2 u3) -> xPair_t tb tc = xPair_t tb u3.
  intros. subst. injection H0. intros ; subst. auto.
Defined.

(** Define some "smart" constructors for transforms that do the reductions
      as we build them. *)

Definition xid {t} : t ->> t := Xid.
Definition xzero {t} : xVoid_t ->> t := Xzero.
Definition xchar {t} (c:char_p) : t ->> xChar_t := Xchar c.
Definition xunit {t} : t ->> xUnit_t := Xunit.
Definition xempty {t1 t2} : t1 ->> xList_t t2 := Xempty.
Definition xinl {t1 t2} : t1 ->> xSum_t t1 t2 := Xinl.
Definition xinr {t1 t2} : t2 ->> xSum_t t1 t2 := Xinr.
Definition xfst {t1 t2} : xPair_t t1 t2 ->> t1 := Xfst.
Definition xsnd {t1 t2} : xPair_t t1 t2 ->> t2 := Xsnd.

Extraction Implicit xid [t].
Extraction Implicit xzero [t].
Extraction Implicit xchar [t].
Extraction Implicit xunit [t].
Extraction Implicit xempty [t1 t2].
Extraction Implicit xinl [t1 t2].
Extraction Implicit xinr [t1 t2].
Extraction Implicit xfst [t1 t2].
Extraction Implicit xsnd [t1 t2].

(** These next two functions reduce [Xpair Xfst Xsnd] to [Xid].
    It's incredibly tedious to propagate the right types and equations around,
    so I had to break it into two functions. *)
Definition xpair_fst ta tc (x2:ta->>tc):forall t1 t2,
  (ta = xPair_t t1 t2) -> ta ->>(xPair_t t1 tc) :=
  match x2 in ta->>tc return forall t1 t2,ta=xPair_t t1 t2 -> ta->>(xPair_t t1 tc) with
    | @Xsnd t3 t4 => fun t1 t2 H => xcoerce Xid (eq_sym H) (pair_eq_snd H)
    | Xzero => fun t1 t2 H => Xzero
    | x2 => fun t1 t2 H => Xpair (xcoerce Xfst (eq_sym H) (eq_refl _)) x2
  end.
Extraction Implicit xpair_fst [ta tc t1 t2].

Definition xpair_r ta tb tc (x2:ta ->> tc) : (ta ->> tb) -> ta ->> (xPair_t tb tc) :=
  match x2 in ta ->> tc return ta->>tb -> ta->>(xPair_t tb tc) with
    | @Xzero _ => fun x1 => Xzero
    | x2 => fun x1 => Xpair x1 x2
  end.
Extraction Implicit xpair_r [ta tb tc].

Definition xpair ta tb tc (x1:ta ->> tb) (x2:ta ->> tc) : ta ->> (xPair_t tb tc) :=
 match x1 in ta ->> tb return ta->>tc -> ta->>(xPair_t tb tc) with
   | Xfst => fun x2 => xpair_fst x2 (eq_refl _)
   | Xzero => fun x2 => Xzero
   | x1 => fun x2 => xpair_r x2 x1
  end x2.
Extraction Implicit xpair [ta tb tc].

(** The [xpair] optimization preserves meaning. *)
Lemma xpair_r_corr ta tb tc (x2:ta ->> tc) (x1:ta->>tb) v :
  xinterp (xpair_r x2 x1) v = xinterp (Xpair x1 x2) v.
Proof.
  destruct x2 ; simpl in * ; auto. destruct v.
Qed.

Lemma xpair_corr ta tb tc (x1:ta->>tb) (x2:ta->>tc) v :
  xinterp (xpair x1 x2) v = xinterp (Xpair x1 x2) v.
Proof.
  Ltac xpair_corr_simp :=
    match goal with | [ H : void |- _ ] => destruct H | _ => auto end.
  destruct x1 ; simpl in * ; auto ; intros ; xpair_corr_simp ;
  dependent destruction x2 ; simpl in * ; xpair_corr_simp.
  destruct v. auto.
Qed.

Definition xmatch_inl :forall t1 t2 tb tc (x2:tb->>tc),
  (tc=xSum_t t1 t2) -> xSum_t t1 tb ->> xSum_t t1 t2.
refine (fun t1 t2 tb tc x2 =>
  match x2 in tb->>tc return (tc=xSum_t t1 t2) -> xSum_t t1 tb ->> xSum_t t1 t2 with
    | Xinr => fun H => xcoerce Xid _ H
    | x2' => fun H => Xmatch Xinl (xcoerce x2' (eq_refl _) H)
  end
). injection H ; intros ; subst. auto.
Defined.
Extraction Implicit xmatch_inl [t1 t2 tb tc].

Definition xmatch_empty {tb t} (x2:tb->>t) :
  forall {t1 t2}, (t = xList_t t2) -> xSum_t t1 tb ->> xList_t t2 :=
  match x2 in tb->>t return forall {t1 t2}, (t = xList_t t2) -> xSum_t t1 tb ->> xList_t t2
  with
    | Xempty => fun t1 t2 H => Xempty
    | x2' => fun t1 t2 H => (Xmatch Xempty (xcoerce x2' eq_refl H))
  end.
Extraction Implicit xmatch_empty [tb t t1 t2].

(** This function and the two above implement the reduction
    [match x with inl a => inl a | inr b => inr b end = id]. *)
Definition xmatch ta tb tc (x1:ta->>tc) (x2:tb->>tc) : xSum_t ta tb ->> tc :=
  match x1 in ta->>tc return tb->>tc -> xSum_t ta tb ->> tc with
    | Xinl => fun x2' => xmatch_inl x2' (eq_refl _)
    | Xempty => fun x2' => xmatch_empty x2' (eq_refl _)
    | x1' => Xmatch x1'
  end x2.
Extraction Implicit xmatch [ta tb tc].

(** Correctness of eta-reduction for sums. *)
Lemma xmatch_corr ta tb tc (x1:ta->>tc) (x2:tb->>tc) v :
  xinterp (xmatch x1 x2) v = xinterp (Xmatch x1 x2) v.
Proof.
  destruct x1 ; simpl ; auto ; intros; dependent destruction x2 ; simpl ; destruct v ;
  auto.
Qed.

(** These next few functions implement specific reductions for when a particular
    combinator is composed with another.
*)
(** (f1, f2) o id = (f1, f2)
    (f1, f2) o (char c) = char c
    (f1, f2) o unit = unit
    (f1, f2) o empty = empty
    (f1, f2) o fst = f1
    (f1, f2) o snd = f2
    (f1, f2) o (g1, g2) = ((f1, f2) o g1, (f1, f2) o g2)
*)
Fixpoint xcomp_pair t21 t22 (x2:t21 ->> t22) :
  forall ta tb tc (x11:ta->>tb) (x12:ta->>tc), (xPair_t tb tc = t21) -> ta ->> t22 :=
    match x2 in t21 ->> t22 return
      forall ta tb tc (x11:ta->>tb) (x12:ta->>tc), (xPair_t tb tc = t21) -> ta ->> t22 with
      | Xid => fun ta tb tc x11 x12 H => xcoerce (Xpair x11 x12) (eq_refl _) H
      | Xchar c => fun ta tb tc x11 x12 H => Xchar c
      | Xunit => fun ta tb tc x11 x12 H => Xunit
      | Xempty => fun ta tb tc x11 x12 H => Xempty
      | Xfst =>
        fun ta tb tc x11 x12 H => xcoerce x11 (eq_refl _) (eq_pair_fst (eq_sym H))
      | Xsnd =>
        fun ta tb tc x11 x12 H => xcoerce x12 (eq_refl _) (eq_pair_snd (eq_sym H))
      | Xpair x21 x22 =>
        fun ta tb tc x11 x12 H =>
          xpair (xcomp_pair x21 x11 x12 H) (xcomp_pair x22 x11 x12 H)
      | x2' =>
        fun ta tb tc x11 x12 H =>
          Xcomp (xpair x11 x12) (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_pair [t21 t22 ta tb tc].

(** [xcomp_pair] is correct. *)
Lemma xcomp_pair_corr :
  forall t21 t22 (x2:t21->>t22) ta tb tc (x11:ta->>tb) (x12:ta->>tc) H v,
  xinterp (xcomp_pair x2 x11 x12 H) v =
  xinterp (Xcomp (Xpair x11 x12) (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  induction x2 ; simpl ; intros ; subst ; simpl ; auto ; try discriminate ;
  try rewrite xpair_corr ; simpl ; auto. rewrite IHx2_1. rewrite IHx2_2.
  auto. injection H ; intros ; subst. rewrite (proof_irrelevance _ H (eq_refl _)).
  auto. injection H ; intros ; subst ; rewrite (proof_irrelevance _ H (eq_refl _)). auto.
Qed.

(**  inl o id = inl
     inl o (char c) = char c
     inl o unit = unit
     inl o empty = empty
     inl o (match f1 f2) = f1
*)
Definition xcomp_inl t21 t22 (x2:t21 ->> t22) :
  forall ta tb, (xSum_t ta tb = t21) -> ta ->> t22 :=
    match x2 in t21->>t22 return
      forall ta tb, (xSum_t ta tb = t21) -> ta ->> t22 with
      | Xid => fun ta tb H => xcoerce Xinl (eq_refl _) H
      | Xchar c => fun ta tb H => Xchar c
      | Xunit => fun ta tb H => Xunit
      | Xempty => fun ta tb H => Xempty
      | Xmatch x21 x22 =>
        fun ta tb H => xcoerce x21 (eq_sum_fst H) (eq_refl _)
      | x2' =>
        fun ta tb H => Xcomp Xinl (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_inl [t21 t22 ta tb].

(** [xcomp_inl] is correct *)
Lemma xcomp_inl_corr t21 t22 (x2:t21->>t22) ta tb (H:xSum_t ta tb = t21) v:
  xinterp (xcomp_inl x2 H) v =
  xinterp (Xcomp Xinl (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  destruct x2 ; simpl ; intros ; subst ; simpl ; auto. injection H ; intros ; subst.
  rewrite (proof_irrelevance _ H (eq_refl _)). auto.
Qed.

(**  inr o id = inr f
     inr o (char c) = char c
     inr o unit = unit
     inr o empty = empty
     inr o (match f1 f2) = f2
*)
Definition xcomp_inr t21 t22 (x2:t21 ->> t22) :
  forall ta tb, (xSum_t ta tb = t21) -> tb ->> t22 :=
    match x2 in t21->>t22 return
      forall ta tb, (xSum_t ta tb = t21) -> tb ->> t22 with
      | Xid => fun ta tb H => xcoerce Xinr (eq_refl _) H
      | Xchar c => fun ta tb H => Xchar c
      | Xunit => fun ta tb H => Xunit
      | Xempty => fun ta tb H => Xempty
      | Xmatch x21 x22 =>
        fun ta tb H => xcoerce x22 (eq_sum_snd H) (eq_refl _)
      | x2' =>
        fun ta tb H => Xcomp Xinr (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_inr [t21 t22 ta tb].

(** [xcomp_inr] is correct. *)
Lemma xcomp_inr_corr t21 t22 (x2:t21->>t22) ta tb (H:xSum_t ta tb = t21) v:
  xinterp (xcomp_inr x2 H) v =
  xinterp (Xcomp Xinr (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  destruct x2 ; simpl ; intros ; subst ; simpl ; auto. injection H ; intros ; subst.
  rewrite (proof_irrelevance _ H (eq_refl _)). auto.
Qed.

(** empty o id = id
    empty o (char c) = char c
    empty o unit = unit
    empty o empty = empty
    empty o (map f) = empty
*)
Definition xcomp_empty t21 t22 (x2:t21 ->> t22) :
  forall ta tb, (xList_t tb = t21) -> ta ->> t22 :=
    match x2 in t21 ->> t22 return forall ta tb, (xList_t tb = t21) -> ta ->> t22 with
      | Xid => fun ta tb H => xcoerce Xempty (eq_refl _) H
      | Xchar c => fun ta tb H => Xchar c
      | Xunit => fun ta tb H => Xunit
      | Xempty => fun ta tb H => Xempty
      | x2' => fun ta tb H => Xcomp Xempty (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_empty [t21 t22 ta tb].

(** [xcomp_empty] is correct. *)
Lemma xcomp_empty_corr t21 t22 (x2:t21->>t22) ta tb (H:xList_t tb = t21) v :
  xinterp (xcomp_empty x2 ta H) v =
  xinterp (Xcomp Xempty (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  destruct x2 ; simpl ; intros ; subst ; simpl ; auto.
Qed.

Definition xcons' t1 t (x2:t1->>t) :
  forall t2, (t = xList_t t2) -> (t1->>t2) -> (t1 ->> xList_t t2) :=
  match x2 in t1->>t return forall t2, (t = xList_t t2) -> (t1->>t2) -> (t1 ->> xList_t t2)
  with
    | Xzero => fun t2 H x1 => Xzero
    | x2' => fun t2 H x1 => Xcons x1 (xcoerce x2' eq_refl H)
  end.
Extraction Implicit xcons' [t1 t t2].

Lemma xcons'_corr t1 t (x2:t1->>t) :
  forall t2 (H:t=xList_t t2) x1 v,
    xinterp (xcons' x2 H x1) v = xinterp (Xcons x1 (xcoerce x2 eq_refl H)) v.
Proof.
  induction x2 ; intros ; auto. destruct v.
Qed.

Definition xcons t1 t2 (x1:t1->>t2) : (t1 ->> xList_t t2) -> (t1 ->> xList_t t2) :=
  match x1 in t1->>t2 return (t1 ->> xList_t t2) -> (t1 ->> xList_t t2) with
    | Xzero => fun _ => Xzero
    | x1' => fun x2 => xcons' x2 eq_refl x1'
  end.
Extraction Implicit xcons [t1 t2].

Lemma xcons_corr t1 t2 (x1:t1->>t2) (x2:t1 ->> xList_t t2) v :
  xinterp (xcons x1 x2) v = xinterp (Xcons x1 x2) v.
Proof.
  induction x1 ; try apply xcons'_corr. destruct v.
Qed.

(** (cons f1 f2) o id = (cons f1 f2)
    (cons f1 f2) o (char c) = char c
    (cons f1 f2) o unit = unit
    (cons f1 f2) o empty = empty
    (cons f1 f2) o (map f) = cons (f1 o f) (f2 o (map f))
*)
Definition xcomp_cons t21 t22 (x2:t21 ->> t22) :
  forall ta tb (x11:ta->>tb) (x12:ta->>xList_t tb), (xList_t tb = t21) -> ta ->> t22 :=
    match x2 in t21 ->> t22 return
      forall ta tb (x11:ta->>tb) (x12:ta->>xList_t tb), (xList_t tb = t21) -> ta ->> t22 with
      | Xid => fun ta tb x11 x12 H => xcoerce (Xcons x11 x12) (eq_refl _) H
      | Xchar c => fun ta tb x11 x12 H => Xchar c
      | Xunit => fun ta tb x11 x12 H => Xunit
      | Xempty => fun ta tb x11 x12 H => Xempty
      | x2' => fun ta tb x11 x21 H =>
        Xcomp (xcons x11 x21) (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_cons [t21 t22 ta tb].

(** [xcomp_cons] is correct. *)
Lemma xcomp_cons_corr t21 t22 (x2:t21->>t22) ta tb (x11:ta->>tb) (x12:ta->>xList_t tb) H v:
  xinterp (xcomp_cons x2 x11 x12 H) v = xinterp (Xcomp (Xcons x11 x12) (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  destruct x2 ; simpl ; intros ; subst ; try rewrite xcons_corr ; simpl ; auto.
Qed.

(** foldr f1 f2 zero => zero
      foldr f1 f2 empty => f1
      foldr f1 f2 (fhd::ftl) => (fhd, foldr f1 f2 ftl) ; f2
 *)
Fixpoint xfoldr' {t3 u} (x3:t3->>u) {struct x3} :
  forall {t1 t2}, (u = xList_t t1) -> (xPair_t t1 t2 ->> t2) -> (t3 ->> t2) -> t3 ->> t2 :=
  match x3 in t3->>u return
        forall {t1 t2}, (u = xList_t t1) -> (xPair_t t1 t2 ->> t2) -> (t3 ->> t2) -> t3 ->> t2
  with
    | Xempty => fun t1 t2 H x1 x2 => x2
    | Xcons x31 x32 =>
      fun t1 t2 H x1 x2 =>
        (Xcomp (xpair (xcoerce x31 eq_refl (list_t_eq (eq_sym H)))
                            (xfoldr' x32 eq_refl
                                     (xcoerce x1 (pair_eq_fst _ (list_t_eq H)) eq_refl) x2))
                     x1)
    | Xzero => fun t1 t2 H x1 x2 => Xzero
    | Xmatch x31 x32 =>
      fun t1 t2 H x1 x2 => Xmatch (xfoldr' x31 H x1 (Xcomp Xinl x2))
                                  (xfoldr' x32 H x1 (Xcomp Xinr x2))
    (* still missing the "eta" rule for xfoldr *)
    | x3' => fun t1 t2 H x1 x2 => Xfoldr x1 x2 (xcoerce x3' eq_refl H)
  end.
Extraction Implicit xfoldr' [t3 u t1 t2].

Lemma xfoldr'_corr t3 u (x3:t3->>u) :
  forall t1 t2 (H:u=xList_t t1) (x1:xPair_t t1 t2->>t2) (x2:t3->>t2)
         (v:xt_interp t3),
    xinterp (xfoldr' x3 H x1 x2) v =
    xinterp (Xfoldr x1 x2 (xcoerce x3 eq_refl H)) v.
Proof.
  induction x3 ; intros ; auto ; try (destruct v ; fail). injection H ; intros ;
  subst ; rewrite (proof_irrelevance _ H eq_refl) ; auto.
  subst. simpl. fold xt_interp. destruct v. rewrite IHx3_1. auto.
  rewrite IHx3_2 ; auto. injection H ; intros ; subst.
  rewrite (proof_irrelevance _ H eq_refl). simpl. fold xt_interp.
  rewrite xpair_corr. simpl. rewrite IHx3_2. auto.
Qed.

Definition xfoldr {t1 t2 t3}
           (x1:xPair_t t1 t2 ->> t2)(x2:t3 ->> t2)(x3:t3 ->> xList_t t1) : t3 ->> t2 :=
  xfoldr' x3 eq_refl x1 x2.

Lemma xfoldr_corr t1 t2 t3 (x1:xPair_t t1 t2 ->>t2)(x2:t3->>t2)(x3:t3->>xList_t t1) v :
  xinterp (xfoldr x1 x2 x3) v = xinterp (Xfoldr x1 x2 x3) v.
Proof.
  unfold xfoldr ; rewrite xfoldr'_corr ; auto.
Qed.
Extraction Implicit xfoldr [t1 t2 t3].

(** Cut eliminations on the right here:
     f o id = f
     f o (char c) = char c
     f o unit = unit
     f o empty = empty
*)
Fixpoint xcomp_r t21 t22 (x2:t21 ->> t22) : forall t11, t11 ->> t21 -> t11 ->> t22 :=
  match x2 in t21 ->> t22 return forall t11, t11 ->> t21 -> t11 ->> t22 with
    | Xid => fun t1 x1 => x1
    | Xchar c => fun t1 x1 => Xchar c
    | Xunit => fun t1 x1 => Xunit
    | Xempty => fun t1 x1 => Xempty
    | Xpair x21 x22 => fun t1 x1 => xpair (xcomp_r x21 x1) (xcomp_r x22 x1)
    | Xcons x21 x22 => fun t1 x1 => xcons (xcomp_r x21 x1) (xcomp_r x22 x1)
    | Xfoldr x21 x22 x23 => fun t1 x1 => xfoldr x21 (xcomp_r x22 x1) (xcomp_r x23 x1)
    | x2' => fun t1 x1 => Xcomp x1 x2'
  end.
Extraction Implicit xcomp_r [t21 t22 t11].

(** [xcomp_r] is correct. *)
Lemma xcomp_r_corr t21 t22 (x2:t21->>t22) t11 (x1:t11->>t21) v :
  xinterp (xcomp_r x2 x1) v = xinterp (Xcomp x1 x2) v.
Proof.
  induction x2 ; simpl ; intros ; auto.
  rewrite xpair_corr. simpl. rewrite IHx2_1. rewrite IHx2_2. auto.
  rewrite xcons_corr. simpl. rewrite IHx2_1. rewrite IHx2_2. auto.
  rewrite xfoldr_corr. simpl. fold xt_interp. rewrite IHx2_2. rewrite IHx2_3. auto.
Qed.

(** Optimization for composition of combinators, takes advantage
    of all of the specialized functions above, plus a few more:
     id o f = f
     zero o f = zero
     (f1 o f2) o f3 = f1 o (f2 o f3)
     (match f1 f2) o f3 = match (f1 o f3) (f2 o f3)
     plus the reductions in the functions above
*)
Fixpoint xcomp t11 t12 (x1:t11 ->> t12) : forall t22, t12 ->> t22 -> t11 ->> t22 :=
    match x1 in t11 ->> t12 return forall t22, t12 ->> t22 -> t11 ->> t22 with
      | Xid => fun t22 x2 => x2
      | Xzero => fun t22 x2 => Xzero
      | Xcomp x11 x12 =>
        fun t22 x2 => xcomp x11 (xcomp x12 x2)
      | Xpair x11 x12 =>
        fun t22 x2 => xcomp_pair x2 x11 x12 (eq_refl _)
      | Xinl => fun t22 x2 => xcomp_inl x2 (eq_refl _)
      | Xinr => fun t22 x2 => xcomp_inr x2 (eq_refl _)
      | Xempty => fun t22 x2 => xcomp_empty x2 _ (eq_refl _)
      | Xcons x11 x12 => fun t22 x2 => xcomp_cons x2 x11 x12 (eq_refl _)
      | Xmatch x11 x12 => fun t22 x2 => xmatch (xcomp x11 x2) (xcomp x12 x2)
      | x1' => fun t22 x2 => xcomp_r x2 x1'
    end.
Extraction Implicit xcomp [t11 t12 t22].

(** [xcomp] is correct. *)
Lemma xcomp_corr t1 t2 (x1:t1->>t2) t3 (x2:t2->>t3) v :
  xinterp (xcomp x1 x2) v = xinterp (Xcomp x1 x2) v.
Proof.
  induction x1 ; simpl in * ; intros ; auto ;
  match goal with
    | [ v : void |- _ ] => destruct v
    | [ |- xinterp (xcomp_r ?x2 ?x1) ?v = _ ] => apply (xcomp_r_corr x2 x1 v)
    | _ => idtac
  end.
  rewrite <- IHx1_2. rewrite <- IHx1_1. auto.
  apply xcomp_empty_corr. apply xcomp_pair_corr.  apply xcomp_inl_corr.
  apply xcomp_inr_corr. destruct v ; auto. rewrite xmatch_corr ; simpl ; auto.
  rewrite xmatch_corr ; simpl ; auto.
  apply xcomp_cons_corr.
Qed.

(** The [xcomp'] function is an extra loop to try to get more reductions
    to fire. *)
Fixpoint xcomp' tb tc (x2:tb->>tc) : forall ta, ta->>tb -> ta->>tc :=
  match x2 in tb->>tc return forall ta, ta->>tb -> ta->>tc with
    | Xcomp x21 x22 => fun ta x1 => xcomp' x22 (xcomp' x21 x1)
    | Xpair x21 x22 => fun ta x1 => xpair (xcomp' x21 x1) (xcomp' x22 x1)
    | Xcons x21 x22 => fun ta x1 => xcons (xcomp' x21 x1) (xcomp' x22 x1)
    | Xfoldr x21 x22 x23 => fun ta x1 => xfoldr x21 (xcomp' x22 x1) (xcomp' x23 x1)
    | x2' => fun ta x1 => xcomp x1 x2'
  end.
Extraction Implicit xcomp' [tb tc ta].

Lemma xcomp'_corr tb tc (x2:tb->>tc) ta (x1:ta->>tb) v :
  xinterp (xcomp' x2 x1) v = xinterp (Xcomp x1 x2) v.
Proof.
  induction x2 ; simpl ; intros ; auto ; try (rewrite xcomp_corr ; auto).
  rewrite IHx2_2. simpl. rewrite IHx2_1. auto. rewrite xpair_corr. simpl.
  rewrite IHx2_1. rewrite IHx2_2. auto. rewrite xcons_corr ; simpl ;
  rewrite IHx2_1 ; rewrite IHx2_2 ; auto.
  rewrite xfoldr_corr. simpl. rewrite IHx2_2. rewrite IHx2_3. auto.
Qed.

(** Optimize an [xform].  Most of the reductions are in the
    [Xcomp] (composition) case, though there are a couple of
    eta reductions for [Xpair] and [Xmatch] respectively. *)
Fixpoint xopt t1 t2 (x:t1 ->> t2) : t1 ->> t2 :=
  match x with
    | Xpair x1 x2 => xpair (xopt x1) (xopt x2)
    | Xmatch x1 x2 => xmatch (xopt x1) (xopt x2)
    | Xcomp x1 x2 => xcomp' (xopt x2) (xopt x1)
    | Xcons x1 x2 => xcons (xopt x1) (xopt x2)
    | Xfoldr x1 x2 x3 => xfoldr (xopt x1) (xopt x2) (xopt x3)
    | x' => x'
  end.
Extraction Implicit xopt [t1 t2].

(** [xopt] is correct. *)
Lemma xopt_corr t1 t2 (x:t1 ->> t2) : xinterp (xopt x) = xinterp x.
Proof.
  induction x ; simpl ; intros ; auto ; try (rewrite <- IHx ; auto) ;
    try (rewrite <- IHx1 ; rewrite <- IHx2 ; auto) ; apply extensionality ; intros.
  apply xcomp'_corr. apply xpair_corr. apply xmatch_corr. apply xcons_corr.
  rewrite <- IHx3 ; apply xfoldr_corr.
Qed.

(** Derived Transforms *)

(** Map a transform over a list. *)
Definition xmap {t1 t2} (f:t1 ->> t2) : xList_t t1 ->> xList_t t2 :=
  xopt (xfoldr (xcons (xcomp xfst f) xsnd) xempty xid).
Extraction Implicit xmap [t1 t2].

Lemma xmap_corr t1 t2 (f:t1 ->> t2) (vs:xt_interp (xList_t t1)) :
  xinterp (xmap f) = List.map (xinterp f).
Proof.
  eapply extensionality. intro x. unfold xmap. rewrite xopt_corr.
  induction x. auto. simpl. rewrite xcons_corr. simpl. rewrite xcomp_r_corr. simpl.
  rewrite <- IHx. auto.
Qed.

(** Append a pair of lists. *)
Definition xapp {t} : xPair_t (xList_t t) (xList_t t) ->> xList_t t :=
  xopt (xfoldr (xcons xfst xsnd) xsnd xfst).
Extraction Implicit xapp [t].

Lemma xapp_corr t (vs1 vs2: xt_interp (xList_t t)) :
  xinterp xapp (vs1,vs2) = vs1 ++ vs2.
Proof.
  unfold xapp. rewrite xopt_corr.
  induction vs1. simpl. auto. simpl. rewrite <- IHvs1. auto.
Qed.

(** Similar to Map but draws from the environment. *)
Definition xmapenv {t1 t2 t3} (f:xPair_t t1 t2 ->> t3) : xPair_t t1 (xList_t t2)->>xList_t t3 :=
  xopt (xcomp (xfoldr (xpair (xcomp xsnd xfst)
                       (xcons (xcomp (xpair (xcomp xsnd xfst) xfst) f)
                              (xcomp xsnd xsnd))) (xpair xfst xempty) xsnd) xsnd).
Extraction Implicit xmapenv [t1 t2 t3].

Lemma xmapenv_corr {t1 t2 t3} (f:xPair_t t1 t2->>t3) v :
  xinterp (xmapenv f) v = List.map (fun x => xinterp f (fst v,x)) (snd v).
Proof.
  assert (H: xinterp (xmapenv f) v =
          xinterp (Xcomp (Xfoldr (Xpair (Xcomp Xsnd Xfst)
                                        (Xcons (Xcomp (xpair (Xcomp Xsnd Xfst) Xfst) f)
                                               (Xcomp Xsnd Xsnd))) (Xpair Xfst Xempty) Xsnd)
                         Xsnd) v).
    unfold xmapenv. rewrite xopt_corr. rewrite xcomp_corr.
    simpl. repeat f_equal.
    eapply extensionality; intros.
    eapply extensionality; intros.
    rewrite xpair_r_corr.
    simpl.
    rewrite xcons_corr.
    f_equal.
    simpl.
    rewrite xcomp_pair_corr.
    auto.
  rewrite H. clear H.
  destruct v. induction x0. auto.
  simpl in *. rewrite IHx0.
  replace (fst
             (fold_right
                (fun (a0 : xt_interp t2) (b : xt_interp t1 * list (xt_interp t3)) =>
                   (fst b, xinterp f (fst b, a0) :: snd b))
                (x, nil) x0)) with x ; auto.
  clear IHx0. induction x0 ; auto.
Qed.

(** Flatten a list of lists. *)
Definition xflatten {t} : xList_t (xList_t t) ->> xList_t t :=
  xopt (xfoldr xapp xempty xid).
Extraction Implicit xflatten [t].

Lemma xflatten_corr {t} (vs : xt_interp (xList_t (xList_t t))) :
  xinterp xflatten vs =
  List.fold_right (fun a b => List.fold_right (fun x y => x::y) b a) nil vs.
Proof.
  unfold xflatten. rewrite xopt_corr.
  induction vs ; simpl ; fold xt_interp in *; auto.
Qed.

Lemma xflatten_corr2 {t} (vs: xt_interp (xList_t (xList_t t))) :
  xinterp xflatten vs = Coqlib.list_flatten vs.
Proof.
  rewrite xflatten_corr. fold xt_interp.
  assert ((fun a b : list (xt_interp t) =>
            fold_right (fun x y => x :: y) b a) = @List.app (xt_interp t)).
  apply Coqlib.extensionality. intro. apply Coqlib.extensionality. intro y.
  generalize x ; clear x. induction y. induction x ; auto.
  simpl. rewrite IHx. auto. induction x. auto. simpl. rewrite IHx. auto.
  rewrite H. auto.
Qed.

(** A singleton list *)
Definition xsingleton {t} : t ->> xList_t t := @xcons t t xid xempty.
Extraction Implicit xsingleton [t].

(** Compute the cross product of two lists.  For instance, the
      cross product of (1::2::nil, true::false::nil) is
      (1,true)::(1,false)::(2,true)::(2,false)::nil.
 *)
Definition xcross {t1 t2} : xPair_t (xList_t t1) (xList_t t2) ->> xList_t (xPair_t t1 t2) :=
  xopt (xcomp (xcomp (xpair xsnd xfst)
                     (xmapenv (xcomp (xpair xsnd xfst) (xmapenv xid)))) xflatten).
Extraction Implicit xcross [t1 t2].

Lemma xcross_corr t1 t2 (p : xt_interp (xPair_t (xList_t t1) (xList_t t2))) :
  xinterp xcross p =
  Coqlib.list_flatten (List.map (fun x => List.map (fun y => (x,y)) (snd p)) (fst p)).
Proof.
  Opaque xflatten xmapenv xpair.
  destruct p. fold xt_interp. unfold xcross. rewrite xopt_corr.
  repeat rewrite xcomp_corr. simpl. repeat rewrite xcomp_corr. simpl.
  rewrite xflatten_corr2. rewrite xmapenv_corr. fold xt_interp.
  repeat f_equal.
  apply Coqlib.extensionality. intro. rewrite xcomp_corr. simpl.
  rewrite xmapenv_corr. fold xt_interp. simpl.
  f_equal.
Qed.

Lemma xcross_corr2 {t1 t2} (vs: xt_interp (xPair_t (xList_t t1) (xList_t t2))):
  xinterp xcross vs = List.list_prod (fst vs) (snd vs).
Proof. rewrite xcross_corr. fold xt_interp.
  destruct vs as [l1 l2].
  induction l1.
    simpl. induction l2; auto.
    simpl in *. f_equal. trivial.
Qed.

(** Lift a continuation to work on a list of values, and then
      concatenate all of the results. *)
Definition xthen {t1 t2 t3} (f1: t1 ->> xList_t t2) (f2: t2 ->> xList_t t3) :
  t1 ->> xList_t t3 :=
  xopt (xcomp f1 (xcomp (xmap f2) xflatten)).
Extraction Implicit xthen [t1 t2 t3].

(** Like cross product, but parameterized by generators [f1] and [f2]. *)
Definition xcrossmap {t1 t2 t3 t4} (f1 : t1 ->> xList_t t3) (f2 : t2 ->> xList_t t4) :
  (xPair_t t1 t2) ->> xList_t (xPair_t t3 t4) :=
  xopt (xcomp (xpair (xcomp xfst f1) (xcomp xsnd f2)) xcross).
Extraction Implicit xcrossmap [t1 t2 t3 t4].

(** A simplification tactic for [xform]s *)
Ltac xinterp_simpl :=
  repeat match goal with
    | [|- context[xcomp ?X1 ?X2]] => rewrite (xcomp_corr X1 X2); simpl
    | [H:context[xcomp ?X1 ?X2] |- _] =>
      rewrite (xcomp_corr X1 X2) in H; simpl in H
    | [|- context[xinterp (xpair _ _) _]] => rewrite xpair_corr; simpl
    | [H:context[xinterp (xpair _ _) _] |- _] =>
      rewrite xpair_corr in H; simpl in H
    | [|- context[xinterp xcross _]] => rewrite xcross_corr2; simpl
    | [H:context[xinterp xcross _] |- _] =>
      rewrite xcross_corr2 in H; simpl in H
    | [|- context [xinterp xapp (_,_)]] => rewrite xapp_corr; simpl
    | [H:context [xinterp xapp (_,_)] |- _] =>
      rewrite xapp_corr in H; simpl in H
    | [|- context [xinterp (xmap _) ?V]] =>
      rewrite (@xmap_corr _ _ _ V); simpl
    | [H:context [xinterp (xmap _) ?V] |- _] =>
      rewrite (@xmap_corr _ _ _ V) in H; simpl in H
    | [|- context[xinterp xflatten _]] => rewrite xflatten_corr2; simpl
    | [H:context[xinterp xflatten _] |- _] =>
      rewrite xflatten_corr2 in H; simpl in H
  end.

(** Some utilities for viewing and seeing the size of Xforms. *)

Require Import Coq.Strings.String.
Local Open Scope string_scope.

Definition emit (s:string) (a:list string) : list string := s :: a.
Definition seq {A} (c1 c2:A -> A)(a:A): A :=
  c2 (c1 a).
Notation "c1 ;; c2" := (seq c1 c2) (right associativity, at level 84).

Fixpoint show_xform' t1 t2 (x:t1->>t2) : list string -> list string :=
  match x with
    | Xid => emit "id"
    | Xzero => emit "Z"
    | Xcomp x1 x2 =>
      emit "(" ;; (show_xform' x1) ;; emit ";" ;; (show_xform' x2) ;; emit ")"
    | Xchar c => emit (show_char c)
    | Xunit => emit "U"
    | Xempty => emit "[]"
    | Xpair x1 x2 =>
      emit "(" ;; (show_xform' x1) ;; emit "," ;; (show_xform' x2) ;; emit ")"
    | Xfst => emit "fst"
    | Xsnd => emit "snd"
    | Xinl => emit "inl"
    | Xinr => emit "inr"
    | Xmatch x1 x2 =>
      emit "[" ;; (show_xform' x1) ;; emit "|" ;; (show_xform' x2) ;; emit "]"
    | Xcons x1 x2 =>
      emit "(" ;; (show_xform' x1) ;; emit "::" ;; (show_xform' x2) ;; emit ")"
    | Xfoldr x1 x2 x3 =>
      emit "fold(" ;; (show_xform' x1) ;; emit "," ;; (show_xform' x2) ;;
           emit "," ;; (show_xform' x3) ;; emit ")"
  end.
Extraction Implicit show_xform' [t1 t2].

Definition show_xform t1 t2 (x:t1->>t2) : string :=
  let ss := List.rev (show_xform' x nil) in
  List.fold_right (fun x y => x ++ y) "" ss.
Extraction Implicit show_xform [t1 t2].

Definition inc (n:nat) : nat := plus 1 n.

Fixpoint xform_count' t1 t2 (x:t1->>t2) : nat->nat :=
  match x with
    | Xid => inc
    | Xzero => inc
    | Xcomp x1 x2 => inc ;; (xform_count' x1) ;; (xform_count' x2)
    | Xchar _ => inc
    | Xunit => inc
    | Xempty => inc
    | Xpair x1 x2 => inc ;; (xform_count' x1) ;; (xform_count' x2)
    | Xfst => inc
    | Xsnd => inc
    | Xinl => inc
    | Xinr => inc
    | Xmatch x1 x2 => inc ;; (xform_count' x1) ;; (xform_count' x2)
    | Xcons x1 x2 => inc ;; (xform_count' x1) ;; (xform_count' x2)
    | Xfoldr x1 x2 x3 =>
      inc ;; (xform_count' x1) ;; (xform_count' x2) ;; (xform_count' x3)
  end.
Extraction Implicit xform_count' [t1 t2].

Definition xform_count t1 t2 (x:t1->>t2) : nat := xform_count' x 0.
Extraction Implicit xform_count [t1 t2].