Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Theorems about string-like types *)

Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.ZArith.ZArith.
Require Import Fiat.Common.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Le.
Require Import Fiat.Common.Tactics.SetoidSubst.
Require Import Fiat.Common.Tactics.IsClosed.
Require Import Fiat.Parsers.StringLike.Core Fiat.Common.UIP.

Local Open Scope list_scope.

Set Implicit Arguments.

Section String.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  (** For use with [induction str using String_rect] *)
  Definition String_rect (P : String -> Type)
    : (forall str, length str = 0 -> P str)
      -> (forall n str (Hlen : length str = S n)
                 (IHstr : forall str', length str' = n -> P str'),
             P str)
      -> forall str, P str.
  Proof.
    intros Zcase Scase str.
    pose (length str) as len.
    pose proof (eq_refl : length str = len) as Hlen.
    clearbody len.
    revert str Hlen.
    induction len; intros.
    { eapply Zcase; assumption. }
    { eapply Scase; eassumption. }
  Defined.

  Definition bool_eq_refl {x : String} : x =s x.
  Proof.
    reflexivity.
  Defined.

  Definition bool_eq_sym {x y : String} : ((x =s y) = (y =s x) :> bool)%string_like.
  Proof.
    case_eq (y =s x)%string_like; intro H';
    [
    | case_eq (x =s y)%string_like; intro H'' ].
    { apply (symmetry (R := (fun x y => x =s y))) in H'; assumption. }
    { apply (symmetry (R := (fun x y => x =s y))) in H''; hnf in H''.
      etransitivity; [ exact (eq_sym H'') | exact H' ]. }
    { reflexivity. }
  Defined.

  Definition bool_eq_trans {x y z : String} : (x =s y) -> (y =s z) -> (x =s z).
  Proof.
    apply (transitivity (R := (fun x y => x =s y))).
  Defined.

  Global Instance str_le_Proper_iff : Proper (beq ==> beq ==> iff) str_le | 1000.
  Proof.
    repeat match goal with
             | _ => intro
             | _ => split
             | [ H : _ ≤s _ |- _ ] => destruct H
             | _ => left; assumption
             | _ => right; assumption
             | _ => right; symmetry; assumption
             | [ H : ?x =s _ |- _ ] => rewrite H in *; clear x H
             | [ H : _ =s ?x |- _ ] => rewrite <- H in *; clear x H
           end.
  Qed.

  Global Instance str_le_Proper : Proper (beq ==> beq ==> impl) str_le.
  Proof.
    intros x y H' x' y' H'' H'''.
    apply (@str_le_Proper_iff x y H' x' y' H''); assumption.
  Qed.

  Global Instance str_le_Proper' : Proper (beq ==> beq ==> Basics.flip impl) str_le.
  Proof.
    intros x y H' x' y' H'' H'''.
    apply (@str_le_Proper_iff _ _ H' _ _ H''); assumption.
  Qed.

  Global Instance str_le_refl : Reflexive str_le.
  Proof.
    repeat intro; right; reflexivity.
  Qed.

  Global Instance str_le_antisym : @Antisymmetric _ beq _ str_le.
  Proof.
    intros ? ? [H'|H']; repeat subst; intros [H1|H1]; repeat subst; try reflexivity;
    solve [ reflexivity
          | exfalso; omega
          | assumption
          | symmetry; assumption ].
  Qed.

  Global Instance str_le_trans : Transitive str_le.
  Proof.
    intros ? ? ? [H'|H']; repeat subst; intros [H1|H1]; repeat subst;
    try (rewrite H1 in *; clear H1);
    try (rewrite H' in *; clear H');
    first [ reflexivity
          | left; assumption
          | left; etransitivity; eassumption ].
  Qed.

  Local Open Scope string_like_scope.

  Global Instance str_le_length_le_Proper : Proper (str_le ==> le) length.
  Proof.
    intros x y [H'|H']; auto with arith.
    rewrite H'; reflexivity.
  Qed.

  Global Instance str_le_length_le_Proper' : Proper (Basics.flip str_le ==> Basics.flip le) length.
  Proof.
    intros x y [H'|H']; unfold Basics.flip in *; auto with arith.
    rewrite H'; reflexivity.
  Qed.

  Lemma str_le_take {str n}
  : take n str ≤s str.
  Proof.
    destruct (le_gt_dec (length str) n).
    { right; apply take_long; assumption. }
    { left; rewrite take_short_length; omega. }
  Qed.

  Lemma str_le_drop {str n}
  : drop n str ≤s str.
  Proof.
    destruct n.
    { rewrite drop_0; reflexivity. }
    { hnf; rewrite drop_length.
      case_eq (length str); intro H'.
      { right; apply bool_eq_empty.
        { rewrite drop_length, H'; reflexivity. }
        { assumption. } }
      { intro; left; omega. } }
  Qed.

  Lemma take_length {str n}
  : length (take n str) = min n (length str).
  Proof.
    destruct (le_ge_dec (length str) n).
    { rewrite take_long by assumption.
      rewrite Min.min_r by assumption.
      reflexivity. }
    { rewrite take_short_length by assumption.
      rewrite Min.min_l by assumption.
      reflexivity. }
  Qed.

  Lemma length_le_trans
        {a b c : String} (H0' : length a < length b) (H1' : b ≤s c)
  : length a < length c.
  Proof.
    destruct H1'; setoid_subst.
    { etransitivity; eassumption. }
    { assumption. }
  Qed.

  Lemma strle_to_sumbool
        (s1 s2 : String) (f : String -> nat)
        (H' : f s1 < f s2 \/ s1 =s s2)
  : {f s1 < f s2} + {s1 =s s2}.
  Proof.
    unfold beq in *.
    case_eq (s1 =s s2).
    { intro H''; right; reflexivity. }
    { intro H''; left.
      destruct H' as [H' | H']; trivial.
      hnf in *.
      abstract congruence. }
  Defined.

  Section strle_choose.
    Context (s1 s2 : String) (f : String -> nat)
            (f_Proper : Proper (beq ==> eq) f)
            (H0' : f s1 < f s2 \/ s1 =s s2).

    Definition strle_left (H' : f s1 < f s2)
    : H0' = or_introl H'.
    Proof.
      destruct H0' as [H''|H'']; try clear H0'; [ apply f_equal | exfalso ].
      { apply le_proof_irrelevance. }
      { setoid_subst s1.
        eapply lt_irrefl; eassumption. }
    Qed.

    Definition strle_right (H' : s1 =s s2)
    : H0' = or_intror H'.
    Proof.
      destruct H0' as [H''|H'']; try clear H0'; [ exfalso | apply f_equal ].
      { setoid_subst s1; eapply lt_irrefl; eassumption. }
      { apply dec_eq_uip.
        decide equality. }
    Qed.
  End strle_choose.

  Lemma str_seq_lt_false
        {a b : String}
        (H0' : length a < length b)
        (H' : a =s b)
  : False.
  Proof.
    rewrite H' in H0'.
    eapply lt_irrefl; eassumption.
  Qed.

  Lemma singleton_exists_unique : forall s, length s = 1 -> exists !ch, s ~= [ ch ].
  Proof.
    intros s H'.
    destruct (singleton_exists s H') as [ch H''].
    exists ch.
    split; [ apply H'' | ].
    intro; apply singleton_unique; assumption.
  Qed.

  Lemma singleton_take {str ch} (H' : str ~= [ ch ]) n
  : take (S n) str =s str.
  Proof.
    eapply bool_eq_char; try eassumption.
    rewrite take_long; try assumption.
    apply length_singleton in H'; omega.
  Qed.

  Lemma drop_empty {str n} (H' : length str = 0) : drop n str =s str.
  Proof.
    apply bool_eq_empty; rewrite ?drop_length, ?take_length; omega.
  Qed.

  Lemma take_empty {str n} (H' : length str = 0) : take n str =s str.
  Proof.
    apply bool_eq_empty; rewrite ?drop_length, ?take_length; trivial.
    apply Min.min_case_strong; omega.
  Qed.

  Definition get_first_char_nonempty' str (H' : length str <> 0) : Char.
  Proof.
    let ret := constr:(get 0 str) in
    refine (match get 0 str as ch return ret = ch -> Char with
              | Some ch => fun _ => ch
              | None => fun H'' => match _ : False with end
            end eq_refl).
    abstract (
        pose proof (singleton_exists (take 1 str)) as H''';
        rewrite take_length in H'''; destruct (length str); try omega;
        specialize (H''' eq_refl);
        destruct H''' as [ch H'''];
        apply get_0 in H'''; congruence
      ).
  Defined.

  Definition get_first_char_nonempty str n (H' : length str = S n) : Char.
  Proof.
    apply (get_first_char_nonempty' str);
    generalize dependent (length str); clear; intros; abstract omega.
  Defined.

  Lemma no_first_char_empty str (H' : get 0 str = None) : length str = 0.
  Proof.
    case_eq (length (take 1 str)); rewrite take_length.
    { destruct (length str); simpl; intros; omega. }
    { intros ? H''.
      pose proof (singleton_exists (take 1 str)) as H'''.
      rewrite take_length in H'''.
      destruct (length str); try omega; simpl in *.
      specialize (H''' eq_refl).
      destruct H''' as [ch H'''].
      apply get_0 in H'''.
      congruence. }
  Qed.

  Lemma has_first_char_nonempty str (H' : length str = 0) : get 0 str = None.
  Proof.
    case_eq (get 0 str); try reflexivity.
    intros ch H''.
    exfalso.
    apply get_0, length_singleton in H''.
    rewrite take_length, H' in H''.
    simpl in *; omega.
  Qed.

  Global Instance get_Proper {n}
  : Proper (beq ==> eq) (get n).
  Proof.
    induction n.
    { intros x y H'.
      case_eq (get 0 x).
      { intros ch H''.
        apply get_0 in H''.
        rewrite H' in H''.
        rewrite (proj1 (get_0 _ _) H'').
        reflexivity. }
      { intros H'''.
        case_eq (get 0 y).
        { intros ch' H''.
          apply get_0 in H''.
          rewrite <- H' in H''.
          rewrite (proj1 (get_0 _ _) H'') in H'''.
          congruence. }
        { reflexivity. } } }
    { intros x y H'.
      rewrite !get_S.
      apply IHn.
      rewrite H'; reflexivity. }
  Qed.

  Global Instance get_Proper'
    : Proper (eq ==> beq ==> eq) get.
  Proof.
    intros ???; subst; apply get_Proper.
  Qed.

  Lemma get_drop {n str} : get n str = get 0 (drop n str).
  Proof.
    revert str; induction n; intros.
    { rewrite drop_0; reflexivity. }
    { rewrite !get_S, IHn.
      rewrite drop_drop.
      repeat (f_equal; []).
      omega. }
  Qed.

  Lemma get_drop' {n m str} : get m (drop n str) = get (m + n) str.
  Proof.
    revert str n; induction m; intros.
    { rewrite <- get_drop; reflexivity. }
    { rewrite !get_S at 1; rewrite !drop_drop, IHm; simpl.
      repeat (f_equal; []).
      omega. }
  Qed.

  Lemma fold'_nil
        {A} (f : Char -> A -> A) (init : A) (str : String)
  : fold' f init str 0 = init.
  Proof.
    reflexivity.
  Qed.

  Lemma fold'_cons
        {A} (f : Char -> A -> A) (init : A) (str : String) len
  : fold' f init str (S len)
    = match get (length str - S len) str with
        | Some ch => f ch (fold' f init str len)
        | None => init
      end.
  Proof.
    reflexivity.
  Qed.

  Global Instance fold'_Proper
         {A} (f : Char -> A -> A) (init : A)
  : Proper (beq ==> eq ==> eq) (fold' f init).
  Proof.
    intros ?? H' ? x ?; subst.
    induction x.
    { rewrite !fold'_nil; reflexivity. }
    { rewrite !fold'_cons.
      repeat match goal with
               | _ => reflexivity
               | _ => rewrite IHx
               | _ => rewrite H' at 1
               | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
             end. }
  Qed.

  Lemma fold'_drop
        {A} (f : Char -> A -> A) (init : A) (str : String) len m
        (H' : m + len <= length str)
  : fold' f init str len = fold' f init (drop m str) len.
  Proof.
    revert str m H'.
    induction len; simpl.
    { intros; reflexivity. }
    { intros.
      rewrite !(@get_drop (length _ - _)).
      rewrite drop_length, drop_drop.
      rewrite <- Nat.sub_add_distr, (plus_comm m), Nat.sub_add_distr, Nat.sub_add by omega.
      match goal with
        | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
      end.
      { rewrite <- IHlen by omega; reflexivity. }
      { reflexivity. } }
  Qed.

  Definition fold_nil
             {A} (f : Char -> A -> A) (init : A) (str : String)
             (H' : length str = 0)
  : fold f init str = init.
  Proof.
    unfold fold; rewrite H'; apply fold'_nil.
  Qed.

  Lemma fold_recr
        {A} (f : Char -> A -> A) (init : A) (str : String)
  : fold f init str
    = match get 0 str with
        | Some ch => f ch (fold f init (drop 1 str))
        | None => init
      end.
  Proof.
    case_eq (get 0 str).
    { intros ch H'.
      unfold fold.
      case_eq (length str).
      { intro H''.
        apply has_first_char_nonempty in H''.
        congruence. }
      { intros ? H''.
        rewrite fold'_cons.
        rewrite !H'', minus_diag, H'.
        rewrite drop_length, H''; simpl.
        rewrite <- minus_n_O.
        apply f_equal.
        rewrite <- fold'_drop by omega; reflexivity. } }
    { intro H'.
      apply fold_nil, no_first_char_empty; assumption. }
  Qed.

  Global Instance fold_Proper
         {A} (f : Char -> A -> A) (init : A)
  : Proper (beq ==> eq) (fold f init).
  Proof.
    repeat intro; apply fold'_Proper; trivial.
    setoid_subst_rel beq; reflexivity.
  Qed.

  Lemma fold_lookahead'_nil
        {A} (f : Char -> option Char -> A -> A) (init : A) (str : String)
  : fold_lookahead' f init str 0 = init.
  Proof.
    reflexivity.
  Qed.

  Lemma fold_lookahead'_cons
        {A} (f : Char -> option Char -> A -> A) (init : A) (str : String) len
  : fold_lookahead' f init str (S len)
    = match get (length str - S len) str with
        | Some ch => f ch (get (length str - len) str) (fold_lookahead' f init str len)
        | None => init
      end.
  Proof.
    reflexivity.
  Qed.

  Global Instance fold_lookahead'_Proper
         {A} (f : Char -> option Char -> A -> A) (init : A)
  : Proper (beq ==> eq ==> eq) (fold_lookahead' f init).
  Proof.
    intros ?? H' ? x ?; subst.
    induction x.
    { rewrite !fold_lookahead'_nil; reflexivity. }
    { rewrite !fold_lookahead'_cons.
      repeat match goal with
               | _ => reflexivity
               | _ => rewrite IHx
               | _ => rewrite H' at 1
               | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
             end. }
  Qed.

  Lemma fold_lookahead'_drop
        {A} (f : Char -> option Char -> A -> A) (init : A) (str : String) len m
        (H' : m + len <= length str)
  : fold_lookahead' f init str len = fold_lookahead' f init (drop m str) len.
  Proof.
    revert str m H'.
    induction len; simpl.
    { intros; reflexivity. }
    { intros.
      rewrite !(@get_drop (length _ - _)).
      rewrite drop_length, drop_drop.
      rewrite <- Nat.sub_add_distr, (plus_comm m), Nat.sub_add_distr, Nat.sub_add by omega.
      match goal with
        | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
      end.
      { rewrite drop_drop;
        rewrite <- Nat.sub_add_distr, (plus_comm m), Nat.sub_add_distr, Nat.sub_add by omega;
        rewrite <- IHlen by omega; reflexivity. }
      { reflexivity. } }
  Qed.

  Definition fold_lookahead_nil
             {A} (f : Char -> option Char -> A -> A) (init : A) (str : String)
             (H' : length str = 0)
  : fold_lookahead f init str = init.
  Proof.
    unfold fold_lookahead; rewrite H'; apply fold_lookahead'_nil.
  Qed.

  Lemma fold_lookahead_recr
        {A} (f : Char -> option Char -> A -> A) (init : A) (str : String)
  : fold_lookahead f init str
    = match get 0 str with
        | Some ch => f ch (get 1 str) (fold_lookahead f init (drop 1 str))
        | None => init
      end.
  Proof.
    case_eq (get 0 str).
    { intros ch H'.
      unfold fold_lookahead.
      case_eq (length str).
      { intro H''.
        apply has_first_char_nonempty in H''.
        congruence. }
      { intros n H''.
        rewrite fold_lookahead'_cons.
        rewrite !H'', minus_diag, H'.
        replace (S n - n) with 1 by omega.
        rewrite drop_length, H''; simpl.
        rewrite <- minus_n_O.
        apply f_equal.
        rewrite <- fold_lookahead'_drop by omega; reflexivity. } }
    { intro H'.
      apply fold_lookahead_nil, no_first_char_empty; assumption. }
  Qed.

  Global Instance fold_lookahead_Proper
         {A} (f : Char -> option Char -> A -> A) (init : A)
  : Proper (beq ==> eq) (fold_lookahead f init).
  Proof.
    repeat intro; apply fold_lookahead'_Proper; trivial.
    setoid_subst_rel beq; reflexivity.
  Qed.

  Lemma add_take_1_singleton (str : String) ch (H : str ~= [ ch ])
  : take 1 str ~= [ ch ].
  Proof.
    rewrite take_long; [ assumption | ].
    apply length_singleton in H; rewrite H; reflexivity.
  Qed.

  Lemma take_n_1_singleton (str : String) n ch (H : take n str ~= [ ch ])
  : take 1 str ~= [ ch ].
  Proof.
    apply add_take_1_singleton in H.
    rewrite (take_take str 1 n) in H.
    destruct n; simpl min in H.
    { apply length_singleton in H; rewrite take_length in H.
      simpl in H; congruence. }
    { exact H. }
  Qed.

  Lemma get_take_lt (str : String) n m (Hle : n < m)
  : get n (take m str) = get n str.
  Proof.
    repeat match goal with
             | _ => progress simpl in *
             | _ => congruence
             | _ => omega
             | _ => progress rewrite ?drop_take
             | [ |- context[get ?n _] ] => not constr_eq n 0; rewrite !(get_drop (n := n))
             | [ |- context[get 0 ?str] ] => destruct (get 0 str) eqn:?
             | [ H : get 0 _ = Some _ |- _ ] => apply get_0 in H
             | [ H : get 0 _ = None |- _ ] => apply no_first_char_empty in H
             | [ H : _ |- _ ] => progress rewrite ?take_take, ?take_length in H
             | [ H : is_true (take ?n _ ~= [ _ ]) |- _ ] => progress apply take_n_1_singleton in H
             | [ |- Some _ = Some _ ] => apply f_equal
             | _ => eapply singleton_unique; eassumption
             | [ H : length ?str = 0, H' : is_true (take _ ?str ~= [ _ ]) |- _ ]
               => apply length_singleton in H'
             | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : context[min _ _] |- _ ] => revert H; apply Min.min_case_strong; intros
           end.
  Qed.

  Lemma take_min_length (str : String) n
  : take n str =s take (min (length str) n) str.
  Proof.
    apply Min.min_case_strong; [ | reflexivity ].
    intro H.
    rewrite !take_long by (assumption || reflexivity).
    reflexivity.
  Qed.

  Lemma drop_min_length (str : String) n
  : drop n str =s drop (min (length str) n) str.
  Proof.
    apply Min.min_case_strong; [ | reflexivity ].
    intro H.
    apply bool_eq_empty; rewrite drop_length; omega.
  Qed.

  Lemma not_is_char_options str ch
  : (is_char str ch = false) <-> (length str <> 1 \/ get 0 str <> Some ch).
  Proof.
    destruct (is_char str ch) eqn:H;
    (split; intro H'; try solve [ inversion H' | exact eq_refl ]).
    { pose proof H as H0.
      apply add_take_1_singleton, get_0 in H.
      apply length_singleton in H0.
      rewrite H, H0 in H'.
      destruct H'; congruence. }
    { destruct (Nat.eq_dec (length str) 1); [ right | left; assumption ].
      intro H''.
      apply get_0 in H''.
      rewrite take_long in H'' by omega.
      congruence. }
  Qed.

  Lemma is_char_parts str ch
  : (is_true (is_char str ch)) <-> (length str = 1 /\ get 0 str = Some ch).
  Proof.
    destruct (is_char str ch) eqn:H;
    (split; intro H'; try solve [ inversion H' | reflexivity ]).
    { split.
      { apply length_singleton in H; assumption. }
      { apply get_0, add_take_1_singleton, H. } }
    { apply not_is_char_options in H; tauto. }
  Qed.

  Local Ltac induction_to_string str IHlen :=
    let H := fresh "H" in
    let len := fresh "len" in
    unfold fold;
      generalize dependent str; intro str;
      remember (length str) as len eqn:H;
      revert str H;
      induction len as [|len IHlen]; simpl; intros;
      [
      | specialize (IHlen (drop 1 str));
        rewrite drop_length in IHlen;
        specialize_by omega;
        try rewrite <- !H, !minus_diag;
        try rewrite <- fold'_drop in IHlen by omega ].

  Lemma to_string_length str
  : List.length (to_string str) = length str.
  Proof.
    induction_to_string str IHlen; trivial.
    destruct (get 0 str) eqn:H'; simpl; [ rewrite IHlen; reflexivity | ].
    apply no_first_char_empty in H'; omega.
  Qed.

  Local Ltac take_drop_to_string_t0 :=
    repeat match goal with
             | _ => progress specialize_by omega
             | _ => reflexivity
             | _ => omega
             | _ => progress subst
             | [ H : context[S _ - S _] |- _ ] => rewrite Nat.sub_succ in H
             | [ H : context[S ?x - ?x] |- _ ] => replace (S x - x) with 1 in H by omega
             | [ H : cons _ _ = cons _ _ |- _ ] => inversion H; clear H
             | _ => discriminate
             | [ H : context[_ + 1] |- _ ] => rewrite Nat.add_1_r in H
             | [ |- context[match get 0 ?s with _ => _ end] ] => destruct (get 0 s) eqn:?
             | [ H : get 0 ?str = None |- _ ] => apply no_first_char_empty in H
             | [ H : _ = ?x |- _ = ?x ] => rewrite <- H; clear H
             | [ H : ?x = _ |- ?x = _ ] => rewrite H; clear H
             | [ H : context[length (drop _ _)] |- _ ] => rewrite drop_length in H
             | [ |- context[length (drop _ _)] ] => rewrite drop_length
             | [ H : context[length (take _ _)] |- _ ] => rewrite take_length in H
             | [ |- context[length (take _ _)] ] => rewrite take_length
             | [ |- context[_ - 0] ] => rewrite Nat.sub_0_r
             | [ H : context[_ - 0] |- _ ] => rewrite Nat.sub_0_r in H
             | [ |- context[fold' _ _ (drop _ _) _] ] => rewrite <- fold'_drop by (rewrite ?take_length; try apply Min.min_case_strong; omega)
             | [ H : context[fold' _ _ (drop _ _) _] |- _ ] => rewrite <- fold'_drop in H by omega
             | [ H : ?x = ?y |- context[?x - ?y] ] => replace (x - y) with 0 by omega
             | [ H : ?y = ?x |- context[?x - ?y] ] => replace (x - y) with 0 by omega
             | [ |- cons _ _ = cons _ _ ] => apply f_equal2
             | [ H : context[get _ (drop 0 ?str)] |- _ ] => rewrite (drop_0 str) in H
             | [ H : ?x = Some ?c, H' : ?y = Some ?c' |- _ ]
               => not constr_eq c c'; is_var c; is_var c';
                  assert (c = c') by congruence; subst
             | _ => progress simpl in *
             | [ |- context[fold' _ _ (drop _ (drop _ _)) _] ] => rewrite drop_drop
             | [ |- context[?x + 1] ] => rewrite Nat.add_1_r
             | [ H : S _ = ?x |- context[match ?x with _ => _ end] ] => rewrite <- H
             | [ H : S _ = ?x, H' : context[match ?x with _ => _ end] |- _ ] => rewrite <- H in H'
             | [ H : context[?x - ?x] |- _ ] => rewrite minus_diag in H
             | [ |- context[?x - ?x] ] => rewrite minus_diag
             | [ H : context[get _ (take _ _)] |- _ ] => rewrite get_take_lt in H by omega
             | [ H : context[min (pred ?x) ?x] |- _ ] => rewrite (Min.min_l (pred x) x) in H by omega
             | [ |- context[take _ (drop _ _)] ] => rewrite take_drop
             | [ |- context[min ?x ?y] ] => rewrite (Min.min_l x y) by omega
             | [ |- context[get _ (drop 0 ?s)] ] => rewrite (drop_0 s)
             | [ |- context[get _ (drop _ (drop _ _))] ] => rewrite drop_drop
             | [ H : S ?x = ?y, H' : S ?z = ?y |- _ ]
               => is_var x; not constr_eq x z; assert (x = z) by omega; subst
             | [ H : S ?x = ?y, H' : ?y = S ?z |- _ ]
               => is_var x; not constr_eq x z; assert (x = z) by omega; subst
             | [ H : get ?n ?s = None |- _ ] => not constr_eq n 0; rewrite get_drop in H
           end.

  Local Ltac take_drop_to_string_t s n :=
    unfold fold; rewrite ?drop_length, ?take_length;
    revert n;
    let IHlen := fresh "IHlen" in
    induction_to_string s IHlen;
      destruct n as [|n];
      try specialize (IHlen n);
      take_drop_to_string_t0.

  Lemma drop_to_string s n
  : List.drop n (to_string s) = to_string (drop n s).
  Proof.
    take_drop_to_string_t s n.
  Qed.

  Lemma take_to_string s n
  : List.take n (to_string s) = to_string (take n s).
  Proof.
    destruct (le_lt_dec (length s) n) as [H|H].
    { rewrite take_long by assumption.
      rewrite take_all by (rewrite to_string_length; assumption).
      reflexivity. }
    { revert H.
      take_drop_to_string_t s n. }
  Qed.

  Lemma nth_to_string s n
  : List.nth_error (to_string s) n = get n s.
  Proof.
    rewrite get_drop.
    symmetry.
    take_drop_to_string_t s n;
      try solve [ apply has_first_char_nonempty; rewrite ?drop_length; omega ].
  Qed.

  Lemma beq_to_string {s s'}
  : to_string s = to_string s' <-> s =s s'.
  Proof.
    split.
    { intro H; apply bool_eq_from_get; intro n.
      rewrite <- !nth_to_string, H; reflexivity. }
    { intro; setoid_subst_rel beq.
      reflexivity. }
  Qed.

  Lemma is_char_to_string s ch
  : is_char s ch <-> to_string s = (ch::nil)%list.
  Proof.
    induction_to_string s IHlen.
    { split; intro H'; exfalso; try congruence.
      apply length_singleton in H'; omega. }
    { clear IHlen.
      take_drop_to_string_t0.
      split; intro H'.
      { pose proof (add_take_1_singleton _ _ H') as H''.
        apply length_singleton in H'.
        apply get_0 in H''.
        take_drop_to_string_t0. }
      { take_drop_to_string_t0.
        rewrite <- take_long by reflexivity.
        match goal with
          | [ H : S ?len = length ?s |- _ ] => is_var len; destruct len; rewrite <- H
        end.
        { apply get_0; assumption. }
        { take_drop_to_string_t0.
          match goal with
            | [ H : context[match get ?n ?s with _ => _ end] |- _ ] => destruct (get n s) eqn:?
          end;
          take_drop_to_string_t0. } } }
  Qed.

  Section substring.
    Local Ltac substring_t' :=
      idtac;
      match goal with
        | [ |- beq _ _ ] => reflexivity
        | [ |- _ = _ ] => reflexivity
        | _ => assumption
        | [ H : length ?s = 0 |- beq _ ?s ] => apply bool_eq_empty
        | [ H : length ?s = 0 |- beq ?s _ ] => apply bool_eq_empty
        | _ => progress rewrite ?drop_0, ?take_long, ?take_length, ?drop_length by trivial
        | _ => progress rewrite <- ?Nat.sub_min_distr_r, ?Nat.add_sub by trivial
        | _ => rewrite !take_long by (rewrite drop_length; omega)
        | [ |- context[min ?x ?y] ]
          => match goal with
               | [ |- context[min y x] ]
                 => rewrite (Min.min_comm x y)
             end
        | _ => repeat apply Min.min_case_strong; omega
      end.

    Local Ltac substring_t := repeat substring_t'.

    Lemma substring_correct3 {s : String} m (H : length s <= m)
    : substring 0 m s =s s.
    Proof. substring_t. Qed.

    Lemma substring_correct3' {s : String}
    : substring 0 (length s) s =s s.
    Proof. substring_t. Qed.

    Lemma substring_length {s n m}
    : length (substring n m s) = (min (length s) (m + n)) - n.
    Proof. substring_t. Qed.

    Lemma substring_correct0_length {s : String} {n}
    : length (substring n 0 s) = 0.
    Proof. substring_t. Qed.

    Lemma substring_correct0 {s s' : String} {n} (H : length s' = 0)
    : substring n 0 s =s s'.
    Proof. substring_t. Qed.

    Lemma substring_correct0'_length {s : String} {n m} (H : length s <= n)
    : length (substring n m s) = 0.
    Proof. substring_t. Qed.

    Lemma substring_correct0' {s s' : String} {n m} (H : length s <= n) (H' : length s' = 0)
    : substring n m s =s s'.
    Proof. substring_t. Qed.

    Lemma substring_correct4 {s : String} {n m m'}
          (H : length s <= n + m) (H' : length s <= n + m')
    : substring n m s =s substring n m' s.
    Proof. substring_t. Qed.

    Lemma substring_substring {s n m n' m'}
    : substring n m (substring n' m' s) =s substring (n + n') (min m (m' - n)) s.
    Proof.
      rewrite !drop_take, !take_take, !drop_drop; reflexivity.
    Qed.

    Lemma substring_min {x x' y y' z str} (H : substring x y str =s substring x' y' str)
    : substring x (min y z) str =s substring x' (min y' z) str.
    Proof.
      pose proof (fun y x => @substring_substring str 0 z x y) as H'; simpl in *.
      setoid_rewrite Nat.sub_0_r in H'.
      setoid_rewrite Min.min_comm in H'.
      rewrite <- !H', H; reflexivity.
    Qed.

    Lemma substring_min_length str x y
    : substring x (min y (length str)) str =s substring x y str.
    Proof.
      apply Min.min_case_strong; try reflexivity.
      intro H.
      apply substring_correct4; omega.
    Qed.

    Lemma substring_length_no_min {offset len s} (Hshort : len = 0 \/ offset + len <= length s)
    : length (substring offset len s) = len.
    Proof.
      rewrite substring_length; destruct Hshort as [Hshort|Hshort];
      try rewrite Min.min_r by (clear -Hshort; omega);
      subst; simpl;
      rewrite <- ?NPeano.Nat.sub_min_distr_r, ?NPeano.Nat.add_sub, ?minus_diag, ?Min.min_0_r;
      reflexivity.
    Qed.
  End substring.

  Lemma char_at_matches_is_char_no_ex offset len str P
        (Hlen : offset + len <= length str)
  : (EqNat.beq_nat len 1 && char_at_matches offset str P)%bool = true
    <-> match get offset str with
          | Some ch => (P ch /\ substring offset len str ~= [ch])%string_like
          | None => False
        end.
  Proof.
    destruct (get offset str) as [ch|] eqn:Heq.
    { split; intro H.
      { apply Bool.andb_true_iff in H.
        destruct H as [H0 H1].
        apply EqNat.beq_nat_true in H0; subst.
        erewrite char_at_matches_correct in H1 by eassumption.
        split; try assumption.
        rewrite get_drop in Heq.
        generalize dependent (drop offset str); clear Hlen offset str; intro str.
        intro H.
        apply get_0; assumption. }
      { destruct H as [H0 H1].
        erewrite char_at_matches_correct by eassumption.
        apply Bool.andb_true_iff; split; [ | eassumption ].
        apply length_singleton in H1.
        rewrite substring_length, <- Nat.sub_min_distr_r, Nat.add_sub in H1.
        apply EqNat.beq_nat_true_iff.
        revert H1.
        apply Min.min_case_strong; intros; omega. } }
    { split; [ intro H | intros [] ].
      rewrite get_drop in Heq.
      apply no_first_char_empty in Heq.
      rewrite drop_length in Heq.
      apply Bool.andb_true_iff in H.
      destruct H as [H0 H1].
      apply EqNat.beq_nat_true in H0; subst.
      omega. }
  Qed.

  Lemma char_at_matches_is_char offset len str P
        (Hlen : offset + len <= length str)
  : (EqNat.beq_nat len 1 && char_at_matches offset str P)%bool = true
    <-> (exists ch, P ch /\ substring offset len str ~= [ch])%string_like.
  Proof.
    rewrite char_at_matches_is_char_no_ex by assumption.
    destruct (get offset str) as [ch|] eqn:Heq.
    { split; intro H; [ exists ch; assumption | ].
      destruct H as [ch' H].
      assert (ch = ch');
        [
        | subst; assumption ].
      destruct H as [H0 H1].
      apply take_n_1_singleton in H1.
      apply get_0 in H1.
      rewrite get_drop in Heq.
      congruence. }
    { split; [ intros [] | intros [ch [H0 H1]] ].
      rewrite get_drop in Heq.
      apply no_first_char_empty in Heq.
      rewrite drop_length in Heq.
      apply length_singleton in H1.
      assert (len = 0) by omega; subst.
      rewrite substring_length, <- Nat.sub_min_distr_r, Nat.add_sub, Min.min_0_r in H1.
      omega. }
  Qed.

  Lemma not_all_lengths n : ~ forall str, length str = n.
  Proof.
    destruct n; intro H;
      [ destruct (strings_nontrivial 1) as [? H']
      | destruct (strings_nontrivial 0) as [? H'] ];
      rewrite H in H';
      congruence.
  Qed.

  Lemma not_not_string : ~ (String -> False).
  Proof.
    destruct (strings_nontrivial 0) as [str ?].
    eauto.
  Qed.

  Global Instance beq_subrelation_pointwise_iff {A} {R : relation A}
    : subrelation (beq ==> R)%signature (pointwise_relation String R).
  Proof.
    intros f g H x.
    specialize (H x x (reflexivity _)); assumption.
  Qed.
End String.

Section Iso.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSI : StringIso Char}
          {HSLP : StringLikeProperties Char} {HSIP : StringIsoProperties Char}.

  Lemma length_of_string_nil
  : length (of_string nil) = 0.
  Proof.
    apply no_first_char_empty.
    rewrite get_of_string; reflexivity.
  Qed.

  Lemma drop_of_string (n : nat) str
  : drop n (of_string str) =s of_string (List.drop n str).
  Proof.
    apply bool_eq_from_get.
    intro n'; rewrite get_drop', !get_of_string, nth_error_drop.
    reflexivity.
  Qed.

  Lemma take_of_string (n : nat) str
  : take n (of_string str) =s of_string (List.take n str).
  Proof.
    revert str; induction n; intros; simpl.
    { apply bool_eq_empty; rewrite ?take_length, ?drop_length; trivial.
      apply length_of_string_nil. }
    { apply bool_eq_from_get.
      intros_destruct.
      { destruct str as [|ch str]; simpl;
        repeat match goal with
                 | _ => progress simpl
                 | _ => reflexivity
                 | _ => progress rewrite ?get_take_lt, ?get_of_string, ?take_length, ?length_of_string_nil
                       by (reflexivity || omega)
               end. }
      { intro n'; rewrite !get_S.
        rewrite drop_take, !drop_of_string; simpl.
        rewrite NPeano.Nat.sub_0_r.
        destruct str; simpl;
        rewrite !IHn; simpl; trivial.
        destruct n; reflexivity. } }
  Qed.

  Lemma of_string_length str
  : length (of_string str) = List.length str.
  Proof.
    induction str as [|ch str IHstr].
    { apply no_first_char_empty.
      rewrite get_of_string; reflexivity. }
    { simpl; rewrite <- IHstr; clear IHstr.
      assert (H : of_string str =s drop 1 (of_string (ch :: str))) by (rewrite drop_of_string; reflexivity).
      rewrite H, drop_length.
      destruct (length (of_string (ch::str))) eqn:H'.
      { apply has_first_char_nonempty in H'.
        rewrite get_of_string in H'; simpl in H'.
        inversion H'. }
      { omega. } }
  Qed.

  Lemma is_char_of_string str ch
  : is_true (is_char (of_string str) ch) <-> str = (ch::nil).
  Proof.
    split; intro H;
    [ pose proof (length_singleton _ _ H) as H';
      rewrite of_string_length in H'
    | ];
    (destruct str as [|ch' [|ch'' str]];
     simpl in *; try discriminate);
    change (ch' :: nil) with (List.take 1 (ch'::nil)) in *;
    repeat match goal with
             | [ H : _ |- _ ] => progress rewrite <- ?take_of_string, ?get_of_string in H
             | _ => progress rewrite <- ?take_of_string, ?get_of_string
             | _ => progress simpl in *
             | [ H : is_true (is_char _ _) |- _ ] => apply get_0 in H
             | [ |- is_true (is_char _ _) ] => apply get_0
             | _ => progress unfold value in *
             | [ H : Some _ = Some _ |- _ ] => inversion_clear H
             | [ H : _::_ = _::_ |- _ ] => inversion_clear H
             | _ => reflexivity
           end.
  Qed.

  Lemma substring_of_string {n m str}
  : substring n m (of_string str) =s of_string (List.take m (List.drop n str)).
  Proof.
    rewrite <- take_of_string, <- drop_of_string; reflexivity.
  Qed.

  Lemma to_of_string str
  : to_string (of_string str) = str.
  Proof.
    induction str.
    { unfold fold, fold'.
      rewrite of_string_length; simpl.
      reflexivity. }
    { rewrite fold_recr.
      rewrite get_of_string; simpl.
      rewrite drop_of_string; simpl.
      rewrite IHstr.
      reflexivity. }
  Qed.

  Lemma of_to_string str
  : of_string (to_string str) =s str.
  Proof.
    remember (length str) as n eqn:H.
    revert str H; induction n; intros.
    { unfold fold.
      apply bool_eq_empty; rewrite <- H, ?of_string_length; reflexivity. }
    { rewrite fold_recr.
      apply bool_eq_from_get.
      intros [|n'].
      { destruct (get 0 str) eqn:H'.
        { rewrite get_of_string; reflexivity. }
        { apply no_first_char_empty in H'; congruence. } }
      { rewrite !get_S.
        rewrite <- (IHn (drop 1 str)) by (rewrite drop_length; omega).
        rewrite drop_of_string.
        destruct (get 0 str) eqn:H'; simpl.
        { reflexivity. }
        { apply no_first_char_empty in H'; congruence. } } }
  Qed.

  Lemma beq_of_string {s s'}
  : of_string s =s of_string s' <-> s = s'.
  Proof.
    rewrite <- beq_to_string, !to_of_string.
    reflexivity.
  Qed.
End Iso.

Ltac pose_string_like_for_lengths :=
  match goal with
  | [ H : context[length _ = ?n] |- _ ]
    => lazymatch n with
       | length _ => fail
       | _ => idtac
       end;
       lazymatch goal with
       | [ H' : length _ = n |- _ ] => fail
       | _ => destruct (strings_nontrivial n)
       end
  | [ H : @String ?Char ?HSLM -> ?T |- _ ]
    => is_closed T;
       lazymatch goal with
       | [ s : @String Char HSLM |- _ ] => fail
       | _ => destruct (@strings_nontrivial Char HSLM _ _ 0)
       end
  end.

Ltac simpl_string_like_no_setoid_step :=
  match goal with
  | [ H : length ?str = _, H' : context[length ?str] |- _ ] => rewrite H in H'
  | [ H : length ?str = _ |- context[length ?str] ] => rewrite H
  | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl)
  | _ => progress pose_string_like_for_lengths
  | [ H : forall str, length str = ?n -> ?T, H' : length ?str' = ?n |- _ ]
    => is_closed T; specialize (H str' H')
  | [ H : String -> ?T, H' : String |- _ ]
    => is_closed T; specialize (H H')
  | [ H : False |- _ ] => solve [ induction H | case H ]
  | [ H : forall str, length str = ?n |- _ ] => apply not_all_lengths in H
  | [ H : @length ?Char ?HSLM ?str = @length ?Char ?HSLM ?str' |- _ ]
    => first [ generalize dependent (@length Char HSLM str'); intros; subst; clear str'
             | generalize dependent (@length Char HSLM str); intros; subst; clear str ]
  | [ H : _ |- _ ] => progress rewrite ?take_length, ?drop_length, ?Min.min_0_r, ?Min.min_0_l, ?Nat.sub_0_l in H
  | _ => progress rewrite ?take_length, ?drop_length, ?Min.min_0_r, ?Min.min_0_l, ?Nat.sub_0_l
  end.
Ltac simpl_string_like_step :=
  first [ progress simpl_string_like_no_setoid_step
        | progress setoid_subst_rel (@beq _ _ _) ].
Ltac simpl_string_like_no_setoid := repeat simpl_string_like_no_setoid_step.
Ltac simpl_string_like := repeat simpl_string_like_step.


Require Import Coq.Classes.DecidableClass.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import SquiggleEq.export.
Require Import SquiggleEq.UsefulTypes.
Require Import SquiggleEq.list.
Require Import SquiggleEq.LibTactics.
Require Import SquiggleEq.tactics.
Require Import SquiggleEq.AssociationList.
Require Import ExtLib.Structures.Monads.
Require Import common.
Require Import Trecord.

Fixpoint natElim (n  : nat) : Type:=
match n with
| 0 => bool
| S n => unit + (natElim n)
end.

Definition isZero (n  : nat) : bool :=
negb(
match n with
| 0 => true
| S _ => false
end).

(*
Parametricity Recursive isZero.
 Print isZero_R.

Parametricity Recursive unit.
Parametricity Recursive sum.

Print nat_R.
 *)

(* Print nat_R
Changed Set to Prop
*)
Inductive nat_R : nat -> nat -> (* Set *) Prop :=
nat_R_O_R : nat_R 0 0 | nat_R_S_R : forall H H0 : nat, nat_R H H0 -> nat_R (S H) (S H0).

(*
Parametricity Recursive natElim.
Print natElim_R.
(* copied below *)
*)

(* Fails because nat_R is now in Prop
Definition natElim_R :=
let fix_natElim_1 :=
  fix natElim (n : nat) : Type :=
    match n with
    | 0 => bool
    | S n0 => (unit + natElim n0)%type
    end in
let fix_natElim_2 :=
  fix natElim (n : nat) : Type :=
    match n with
    | 0 => bool
    | S n0 => (unit + natElim n0)%type
    end in
fix natElim_R (n₁ n₂ : nat) (n_R : nat_R n₁ n₂) {struct n_R} :
  fix_natElim_1 n₁ -> fix_natElim_2 n₂ -> Type :=
  match n_R in (nat_R n₁0 n₂0) return (fix_natElim_1 n₁0 -> fix_natElim_2 n₂0 -> Type) with
  | nat_R_O_R => bool_R
  | nat_R_S_R n₁0 n₂0 n_R0 =>
      sum_R unit unit unit_R (fix_natElim_1 n₁0) (fix_natElim_2 n₂0)
        (natElim_R n₁0 n₂0 n_R0)
  end.
*)

Print list.

Inductive list (A : Set (* Type fails *))
  : Set :=  nil : list A | cons : A -> list A -> list A.

Fixpoint listElim (A:Set )(l  : list A) : Type:=
match l with
| nil _ => True
| cons _ _ tl => @sum A (listElim A tl)
end.

(*
Parametricity Recursive unit.
Parametricity Recursive sum.
 *)

(*Parametricity Recursive list.
 Parametricity Recursive listElim.

Print listElim_R.
(* copied below *)
*)

Inductive list_R (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Set) : list A₁ -> list A₂ -> Prop :=
    list_R_nil_R : list_R A₁ A₂ A_R (nil A₁) (nil A₂)
  | list_R_cons_R : forall (H : A₁) (H0 : A₂),
                    A_R H H0 ->
                    forall (H1 : list A₁) (H2 : list A₂),
                    list_R A₁ A₂ A_R H1 H2 ->
                    list_R A₁ A₂ A_R (cons A₁ H H1) (cons A₂ H0 H2).

(* Fails because list_R is now in Prop
Definition listElim_R :=
let fix_listElim_1 :=
  fix listElim (A : Set) (l : list A) {struct l} : Type :=
    match l with
    | nil _ => unit
    | cons _ _ tl => (A + listElim A tl)%type
    end in
let fix_listElim_2 :=
  fix listElim (A : Set) (l : list A) {struct l} : Type :=
    match l with
    | nil _ => unit
    | cons _ _ tl => (A + listElim A tl)%type
    end in
fix
listElim_R (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Set) (l₁ : list A₁)
           (l₂ : list A₂) (l_R : list_R A₁ A₂ A_R l₁ l₂) {struct l_R} :
  fix_listElim_1 A₁ l₁ -> fix_listElim_2 A₂ l₂ -> Type :=
  match
    l_R in (list_R _ _ _ l₁0 l₂0)
    return (fix_listElim_1 A₁ l₁0 -> fix_listElim_2 A₂ l₂0 -> Type)
  with
  | list_R_nil_R _ _ _ => unit_R
  | list_R_cons_R _ _ _ _ _ _ tl₁ tl₂ tl_R =>
      sum_R A₁ A₂ A_R (fix_listElim_1 A₁ tl₁) (fix_listElim_2 A₂ tl₂)
        (listElim_R A₁ A₂ A_R tl₁ tl₂ tl_R)
  end.
*)

Fixpoint list_RR (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (l1 : list A₁) (l2 : list A₂)
  {struct l1} : Prop :=
match (l1, l2) with
| (nil _, nil _) => True
| (cons _ h1 tl1, cons _ h2 tl2) => @sigT (A_R h1 h2) (fun _ => list_RR _ _ A_R tl1 tl2)
| ( _, _) => False
end.

(* because of template polymorphism, * for /\ works *)

(*
Parametricity Recursive sum.
 *)

Inductive True_R : True -> True -> Prop :=  True_R_I_R : True_R I I.
Inductive sum_R (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) (B₁ B₂ : Type) (B_R : B₁ -> B₂ -> Type)
  : A₁ + B₁ -> A₂ + B₂ -> Type :=
    inl_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> sum_R A₁ A₂ A_R B₁ B₂ B_R (inl H) (inl H0)
  | inr_R : forall (H : B₁) (H0 : B₂), B_R H H0 -> sum_R A₁ A₂ A_R B₁ B₂ B_R (inr H) (inr H0).

Fixpoint listElim_RR  (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (l1 : list A₁) (l2 : list A₂)
  (l_R : list_RR A₁ A₂ A_R l1 l2) {struct l1} (* not l_R *)
 : (listElim A₁ l1) -> (listElim A₂ l2) -> Type :=
let reT := fun l1 l2 => list_RR A₁ A₂ A_R l1 l2 -> (listElim A₁ l1) -> (listElim A₂ l2) -> Type in
(match l1 return reT l1 l2 with
| nil _ =>
  match l2 return reT (nil _) l2 with
  | nil _ => fun l_R => True_R
  | cons _ _ _ => fun l_R => False_rect _ l_R
  end
| cons _ h1 tl1 =>
  match l2 return reT (cons _ h1 tl1) l2 with
  | nil _ => fun l_R => False_rect _ l_R
  | cons _ h2 tl2 => fun l_R =>
      let tl_R := projT2 l_R in
      @sum_R _ _ A_R
      _ _ (listElim_RR _ _ A_R _ _ tl_R)
  end
end) l_R.

Require Import templateCoqMisc.
Require Import Template.Ast.

Run TemplateProgram (printTerm "isZero").

(* Should we have a set version as well? *)
(* The return type of eq is a Prop... So we can hust return fun _ _ .. => True *)

Definition eq_RR (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) (x₁ : A₁) (x₂ : A₂)
(x_R : A_R x₁ x₂) : forall (y₁ : A₁) (y₂ : A₂), A_R y₁ y₂ -> x₁ = y₁ -> x₂ = y₂ -> Prop.
intros ? ?.
(*
rename H into y₁.
rename H0 into y₂. *)
intros ary H1eq H2eq.
destruct H1eq.
destruct H2eq.
exact True.
Defined.

Inductive Vec  (C:Set) : forall (m:nat), Set :=
| vnil : Vec C 0
| vcons : forall (n: nat) (c:C) (vc: Vec C n), Vec C (S n).

Inductive Vec2  (C:Set) : nat -> Type :=
| vnil2 : Vec2 C 0
| vcons2 : forall (n: nat), C -> Vec2 C n -> Vec2 C (n+1) (* not struct on n*).

Open Scope nat_scope.

Fixpoint nat_RR (n1 n2: nat)
  {struct n1} : Prop :=
match (n1, n2) with
| (0, 0) => True
| (S h1, S h2) => nat_RR h1 h2
| ( _, _) => False
end.

(*
Definition transportRev {T : Type} {a b : T} {P : T -> Type}
   (p : a = b) (pb : P b) : P a
:= transport (eq_sym p) pb.
*)

Fixpoint vAppend  {C:Set} {n m : nat}
  (vl : Vec C n) (vr : Vec C m): Vec C (n+m) :=
match vl in Vec _ n return Vec C (n + m) with
| vnil _ =>  vr
| vcons _ n' hl tl =>
    (vcons _ _ hl (vAppend tl vr))
end.

Definition vAppend2  {C:Set} {m : nat} (cdef: C)
   (vr : Vec C m):  C :=
match vAppend vr vr as vapx in Vec _ n return C with
| vnil _ =>  cdef
| vcons _ n' hl tl => hl
end.
(*
Parametricity Recursive vAppend2.
Print vAppend2_R.
vAppend2_R =
fun (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Set) (m₁ m₂ : nat) (m_R : common.nat_R m₁ m₂)
  (cdef₁ : C₁) (cdef₂ : C₂) (cdef_R : C_R cdef₁ cdef₂) (vr₁ : Vec C₁ m₁)
  (vr₂ : Vec C₂ m₂) (vr_R : Vec_R C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂) =>
match
  vAppend_R C₁ C₂ C_R m₁ m₂ m_R m₁ m₂ m_R vr₁ vr₂ vr_R vr₁ vr₂ vr_R in
  (Vec_R _ _ _ n₁ n₂ n_R x₁ x₂)
  return
    (C_R match x₁ with
         | vnil _ => cdef₁
         | vcons _ _ hl _ => hl
         end match x₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl _ => hl
             end)
with
| Vec_R_vnil_R _ _ _ => cdef_R
| Vec_R_vcons_R _ _ _ _ _ _ _ _ hl_R _ _ _ => hl_R
end
     : forall (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Set) (m₁ m₂ : nat)
         (m_R : common.nat_R m₁ m₂) (cdef₁ : C₁) (cdef₂ : C₂),
       C_R cdef₁ cdef₂ ->
       forall (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂),
       Vec_R C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂ -> C_R (vAppend2 cdef₁ vr₁) (vAppend2 cdef₂ vr₂)
*)
(*
Run TemplateProgram (printTerm "vAppend").
Run TemplateProgram (duplicateDefn "vAppend" "vAppendss").
Check (eq_refl: @vAppend=vAppendss).
*)

(*
Parametricity Recursive vAppend.

Print Vec_R.
Check vAppend_R.
*)

Fixpoint Vec_RR (C1 C2 : Set) (C_R : C1 -> C2 -> Prop)
  (n1 n2 : nat) (n_R : nat_RR n1 n2)  (v1 : Vec C1 n1) (v2: Vec C2 n2) {struct v1} : Prop:=
let reT := fun n1 n2 => nat_RR n1 n2 -> (* only the indices change. so only they appear here*)
  Prop in
(* for indexed inductives, in is needed before return to bring the index in scope *)
(match v1 in (Vec _ n1) return reT n1 n2 with
| vnil _ =>
  match v2 in (Vec _ n2) return reT 0 n2 with
  | vnil _ => fun _ => True
  | vcons _ _ _ _ => fun _ => False
  end
| vcons _ n1 h1 tl1 =>
  match v2 in (Vec _ n2) return reT (S n1) n2 with
  | vnil _ => fun _ => False
  | vcons _ n2 h2 tl2 => fun n_R =>
    let n_R := n_R (* no sig *) in
     (C_R h1 h2) /\ (Vec_RR _ _ C_R n1 n2 n_R tl1 tl2)
  end
end) n_R.

(* non n_R argument *)
Fixpoint Vec_RR2 (C1 C2 : Set) (C_R : C1 -> C2 -> Prop)
  (n1 n2 : nat)  (v1 : Vec C1 n1) (v2: Vec C2 n2) {struct v1} : Prop:=
let reT :=  fun _ _ => Prop in
(* for indexed inductives, in is needed before return to bring the index in scope *)
(match v1 in (Vec _ n1) return reT n1 n2 with
| vnil _ =>
  match v2 in (Vec _ n2) return reT 0 n2 with
  | vnil _ => True
  | vcons _ _ _ _ => False
  end
| vcons _ n1 h1 tl1 =>
  match v2 in (Vec _ n2) return reT (S n1) n2 with
  | vnil _ =>  False
  | vcons _ n2 h2 tl2 =>
     (C_R h1 h2) /\ (Vec_RR2 _ _ C_R n1 n2 tl1 tl2)
  end
end).

Definition Vec_RR3 :=
fix
ReflParam_matchR_Vec_RR0 (C C₂ : Set) (C_R : (fun H H0 : Set => H -> H0 -> Prop) C C₂)
                         (H H0 : nat) (_ (* unused *): nat_RR H H0)
                         (H2 : Vec C H) (H3 : Vec C₂ H0) {struct H2} : Prop :=
  match H2 with
  | vnil _ => match H3 with
              | vnil _ => True
              | vcons _ _ _ _ => False
              end
  | vcons _ n x x0 =>
      match H3 with
      | vnil _ => False
      | vcons _ n₂ x1 x2 =>
          {n_R : nat_RR n n₂ &
          {_ : C_R x x1 & {_ : ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R x0 x2 & True}}}
      end
  end.

(*
Print Nat.add.
Print Coq_o_Init_o_Nat_o_add_R.
*)

Definition S_RR (n1 n2 : nat)
  (n_R : nat_RR n1 n2) : nat_RR (S n1) (S n2) :=
n_R.

Definition O_RR : nat_RR O O := I.

(* Parametricity Recursive Vec. *)
(* nat_R changed to nat_RR, Set changed to Prop *)
Inductive Vec_R (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop)
  : forall H H0 : nat, nat_RR H H0 -> Vec C₁ H -> Vec C₂ H0 -> Prop :=
  |  Vec_R_vnil_R : Vec_R C₁ C₂ C_R 0 0 O_RR (vnil C₁) (vnil C₂)
  | Vec_R_vcons_R : forall (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂) (H : C₁) (H0 : C₂),
                    C_R H H0 ->
                    forall (H1 : Vec C₁ n₁) (H2 : Vec C₂ n₂),
                    Vec_R C₁ C₂ C_R n₁ n₂ n_R H1 H2 ->
                    Vec_R C₁ C₂ C_R (S n₁) (S n₂) (S_RR n₁ n₂ n_R)
                      (vcons C₁ n₁ H H1) (vcons C₂ n₂ H0 H2).

Definition fromNewV (C C₂ : Set) (C_R : C -> C₂ -> Prop)
(n1 n2: nat) (nr : nat_RR n1 n2) v1 v2
  (vr : Vec_RR3 _ _ C_R n1 n2 nr v1 v2) :
  Vec_R _ _ C_R n1 n2 nr v1 v2.
induction v1;induction v2; simpl in *.
- (* nr is arbitrary because it is an unused argument in Vec_RR *)
Abort.

Fixpoint Vec2_RR (C1 C2 : Set) (C_R : C1 -> C2 -> Prop)
  (n1 n2 : nat) (_ : nat_RR n1 n2)  (v1 : Vec2 C1 n1) (v2: Vec2 C2 n2) {struct v1} : Prop
   :=
(match v1 with
| vnil2 _ =>
  match v2 with
  | vnil2 _ => True
  | vcons2 _ _ _ _ => False
  end
| vcons2 _ n1 h1 tl1 =>
  match v2 with
  | vnil2 _ => False
  | vcons2 _ n2 h2 tl2 =>
     (C_R h1 h2) /\ (sig (fun nr => Vec2_RR _ _ C_R n1 n2 nr tl1 tl2))
  end
end).

Fixpoint add_RR (n1 n2 : nat) (n_R : nat_RR n1 n2) (m1 m2 : nat) (m_R : nat_RR m1 m2):
nat_RR (n1 + m1) (n2 + m2) :=
let reT := fun n1 n2 => nat_RR n1 n2 -> nat_RR (n1 + m1) (n2 + m2) in
(match n1 return reT n1 n2 with
| 0 =>
  match n2 return reT 0 n2 with
  | 0 => fun _ => m_R
  | S _ => fun n_R => False_rect _ n_R
  end
| S p1 =>
  match n2 return reT (S p1) n2 with
  | 0 => fun n_R => False_rect _ n_R
  | S p2 => fun n_R => S_RR _ _ (add_RR p1 p2 n_R m1 m2 m_R)
  end
end) n_R.
(* Print Vec_R_vcons_R. *)

Definition vcons_RR {C₁ C₂ : Set} {C_R : C₁ -> C₂ -> Prop}
(n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
 (H : C₁) (H0 : C₂) (c_R: C_R H H0)
 (H1 : Vec C₁ n₁) (H2 : Vec C₂ n₂)
 (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2):
  Vec_RR C₁ C₂ C_R (S n₁) (S n₂) (S_RR n₁ n₂ n_R)
  (vcons C₁ n₁ H H1) (vcons C₂ n₂ H0 H2).
Proof.
simpl. split; assumption.
Defined.

Fixpoint vAppend_RR {C₁ C₂ : Set} {C_R : C₁ -> C₂ -> Prop} (n₁ n₂ : nat)
   (n_R : nat_RR n₁ n₂) (m₁ m₂ : nat) (m_R : nat_RR m₁ m₂)
   (vl₁ : Vec C₁ n₁) (vl₂ : Vec C₂ n₂)
   (vl_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂)
   (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂)
   (vr_R : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂) {struct vl₁ }:
    Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂) :=
let reT := fun n₁ vl₁ n₂ vl₂ =>
forall n_R: nat_RR n₁ n₂,
Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂
->
Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂)  in
(match vl₁ in Vec _ n₁ return reT n₁ vl₁ n₂ vl₂ with
| vnil _ =>
  match vl₂ in (Vec _ n₂) return reT 0 (vnil _) n₂ vl₂ with
  | vnil _ => fun _ _ => vr_R
  | vcons _ _ _ _ => fun _ v_R => False_rect _ v_R
  end

| vcons _ n₁ hl₁ tl₁ =>
  match vl₂ in (Vec _ n₂) return reT (S n₁) (vcons _ n₁ hl₁ tl₁) n₂ vl₂ with
  | vnil _ =>  fun _ v_R => False_rect _ v_R
  | vcons _ _ hl₂ tl₂ => fun _ v_R =>
    let hl_R := proj1 v_R in
    let tl_R := proj2 v_R in
    (vcons_RR _ _ _ _ _ hl_R _ _ (vAppend_RR _ _ _ _ _ _ _ _  tl_R  _ _ vr_R))
  end
end) n_R vl_R.

(* summary : need indices of:
  1) the type of the discriminee. put a cast around discriminee in template-coq?
  2) for each constructor, a way to get the indices of the return type
    (or just the return type) from the arguments.
    take a list of types of constructors, in order of the constructors.
    convert the PIs to Lams in the type and then apply the arguments and maybe
    beta reduce. Beta reduction is not necessary though.
*)

Definition vAppend2_RR (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (m₁ m₂ : nat)
  (m_R : nat_RR m₁ m₂)
  (cdef₁ : C₁) (cdef₂ : C₂) (cdef_R : C_R cdef₁ cdef₂)
  (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂) (vr : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂):
  C_R (vAppend2  cdef₁ vr₁) (vAppend2 cdef₂ vr₂) :=
(
let reT n1 n2 v1 v2 (* indices and values. move the _Rs to the body, as Pi args  *) :=
      forall (nr: nat_RR n1 n2)
        (vapr: Vec_RR C₁ C₂ C_R n1 n2 nr v1 v2),
     C_R match v1 with
      | vnil _ => cdef₁
      | vcons _ _ hl _ => hl
      end match v2 with
          | vnil _ => cdef₂
          | vcons _ _ hl _ => hl
          end in

(* the "as vap1" part cannot be inlined.
"vAppend vr₁ vr₁" has type "Vec C₁ (m₁ + m₁)" while vap1 has type "Vec C₁ n1"
*)
match vAppend vr₁ vr₁ as vap1 in Vec _ n1
  return reT n1 (m₂+m₂)(*prime of index of discriminee *)
      vap1 (vAppend vr₂ vr₂) (* prime of discriminee*)
with
| vnil _ =>
    match vAppend vr₂ vr₂ as vap2 in Vec _ n2
      return reT O (*index of this constr:vnil*) n2 (* from in *)
          (vnil _) vap2
      with
      | vnil _ => fun (nr : nat_RR 0 0) (_ : Vec_RR C₁ C₂ C_R 0 0 nr (vnil C₁) (vnil C₂))  => cdef_R
      | vcons _ n2 hl2 v2 =>
        fun (nr : nat_RR 0 (S n2))
          (vr0 : Vec_RR C₁ C₂ C_R 0 (S n2) nr (vnil C₁) (vcons C₂ n2 hl2 v2))
        => False_rect
            (*reT 0 (S n2) (vnil C₁) (vcons C₂ n2 hl2 v2) nr vr0 -- then strip the 2 pis*)
            _ vr0 (* always the last lambda *)
      end
| vcons _ n1 hl tl =>
    match vAppend vr₂ vr₂ as vap2 in Vec _ n2
      return reT (S n1) (*index of this constr*) n2 (* from in *)
          (vcons _ _ hl tl) vap2
      with
      | vnil _ => fun _ vr => False_rect _ vr
      | vcons _ _ hl _ => fun _ vr =>
        let hl_R := proj1 vr in hl_R
      end

end (add_RR m₁ m₂ m_R m₁ m₂ m_R)
(* below is the type of the discriminee. Because its type changes during the
matches, we need to convoy it. Thus, in the branches, we need to lambda bind it.
To lambda bind, we need its type, which is [D] d d', where D is the type of the discrimee d.
(Here D is vAppend ..).
Thus, we need D, the type of the discriminee, which is not stored in the kernel, but added by the reifier.

Also, because of dependent types, [D] may depend on the proofs that the indices are related. Thus, we
need to convoy them too.
*)
  (vAppend_RR _ _ _ _ _ _ _ _ vr _ _ vr)
).

Inductive IHaveUndecidalbeEq : Set :=
injFun : (nat->nat) -> IHaveUndecidalbeEq.

(*
Parametricity Recursive IHaveUndecidalbeEq.
Print IHaveUndecidalbeEq_R.
*)

Inductive IHaveUndecidalbeEq_R : IHaveUndecidalbeEq -> IHaveUndecidalbeEq -> Prop :=
 injFun_R : forall f1 f2 : nat -> nat,
   (forall n1 n2 : nat,
          n1 = n2 -> (f1 n1) = (f2 n2)) ->
             IHaveUndecidalbeEq_R (injFun f1) (injFun f2).

(* even after assuming function extensionality, is this provable? *)
Lemma UIP (f:IHaveUndecidalbeEq) (p1 p2 : IHaveUndecidalbeEq_R f f) :
p1=p2.
Proof using.
  Fail induction p1.
Abort.

Inductive IHaveUndecidalbeEq_R2 : IHaveUndecidalbeEq -> IHaveUndecidalbeEq -> Prop :=
 injFun_R2 : forall f1 f2 : nat -> nat, (f1= f2)
             -> IHaveUndecidalbeEq_R2 (injFun f1) (injFun f2).

Inductive IHaveUndecidalbeEq_R3  (f: IHaveUndecidalbeEq): IHaveUndecidalbeEq -> Prop :=
 injFun_R3 :  IHaveUndecidalbeEq_R3 f f.

Require Import Contractible.

Definition iso23 f1 f2 (p: IHaveUndecidalbeEq_R2 f1 f2) :   IHaveUndecidalbeEq_R3 f1 f2.
Proof using.
  destruct p. induction H.
  apply injFun_R3.
Defined.

Definition iso32 f1 f2 (p: IHaveUndecidalbeEq_R3 f1 f2) :   IHaveUndecidalbeEq_R2 f1 f2.
Proof using.
  destruct p.
  destruct f1.
  apply injFun_R2. reflexivity.
Defined.

Lemma iso232 f1 f2:
forall a : IHaveUndecidalbeEq_R3 f1 f2, iso23 f1 f2 (iso32 f1 f2 a) = a.
Proof using.
  intros ?. unfold iso32, iso23. simpl.
  destruct a. destruct f1. reflexivity.
Qed.

Lemma preserveContractible23 f (c1 : Contractible (IHaveUndecidalbeEq_R2 f f)):
  Contractible (IHaveUndecidalbeEq_R3 f f).
Proof using.
  revert c1.
  apply UP_iso with (AtoB := iso23 f f) (BtoA := iso32 f f).
  apply iso232.
Qed.

Section Iso12Feq.

Hypothesis feqNatNat : forall (f g : nat -> nat),
  (forall n, f n = g n) -> f=g.

Lemma feqNatNat2 : forall (f g : nat -> nat),
  (forall n1 n2, n1=n2 -> f n1 = g n2) -> f=g.
Proof.
  intros.
  apply feqNatNat. intros n.
  specialize (H n n eq_refl). assumption.
Qed.

Definition iso12 f1 f2 (p: IHaveUndecidalbeEq_R f1 f2) :   IHaveUndecidalbeEq_R2 f1 f2.
Proof.
  destruct p.
  apply feqNatNat2 in H.
  apply injFun_R2. assumption.
Defined.

Definition iso21 f1 f2 (p: IHaveUndecidalbeEq_R2 f1 f2) :   IHaveUndecidalbeEq_R f1 f2.
Proof using.
  destruct p.
  apply injFun_R.
  intros.  subst. reflexivity.
Defined.

Lemma iso121 f1 f2:
forall a : IHaveUndecidalbeEq_R2 f1 f2, iso12 f1 f2 (iso21 f1 f2 a) = a.
Proof using.
  intros ?. unfold iso21, iso12. simpl.
  destruct a. simpl.
  (* in Hott, this would be compute because function extensionality is not an axiom.
  If Contractible (IHaveUndecidalbeEq_R2 f1 f2) is not provable in
  HoTT, a more powerful theory, it is not provable in Coq. *)
  Fail induction e.
  (* destruct f1. reflexivity. *)
Abort.

End Iso12Feq.

Inductive tree (A : Set) : Set :=
| leaf : tree A
| node : tlist A -> tree A
with
 tlist (A:Set) : Set :=
| tnil : tlist A
| tcons : tree A -> tlist A -> tlist A.

Module test.
Inductive slist (A : Set) : Set :=
snil : slist A
| scons : A -> slist A -> slist A.

Inductive tree (A : Set) : Set :=
| leaf : tree A
| node : slist (tree A) -> tree A.
End test.

Module test2.
Inductive slist (A : Set) : Set :=
| snil : slist A
| scons : (A -> A) -> slist A -> slist A.

(*
Inductive tree (A : Set) : Set :=
| leaf : tree A
| node : slist (tree A) -> tree A.
*)

Inductive tree (A : Set) : Set :=
| leaf : tree A
| node : forall n, Vec (tree A) n -> tree A.

End test2.

Fixpoint zero (T:Type) (e:T=T) :=
  let x := zero T e in 0.

(*
Fixpoint leee (n m :nat) (e: n + 1 =m ) (p:le n (n+1)) {struct p}: nat :=
(fix leee (n m : nat) (e : n + 1 = m) (p : n <= n + 1) {struct p} : nat :=
   (fun p0 : n <= m => ?Goal@{p:=p0}) (eq_ind (n + 1) (fun n0 : nat => n <= n0) p m e))

rewrite e in p.
Show Proof.
destruct n.
-  exact 0.
- specialize (leee n (n+1) eq_refl). apply leee.
Show Proof.
  inversion p.
  destruct p.
  rewrite <- e in p.
  inversion p. admit.
  subst.
  destruct p.

destruct p.
subst m.

Lemma leee0 n p : leee n p =0.
unfold leee.
destruct p.
*)


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From fourcolor Require Import real realplane.
From fourcolor Require combinatorial4ct discretize finitize.

(******************************************************************************)
(*   This files contains the proof of the high-level statement of the Four    *)
(* Color Theorem, whose statement uses only the elementary real topology      *)
(* defined in libraries real and realplane. The theorem is stated for an      *)
(* arbitrary model of the real line, which we show in separate libraries      *)
(* (dedekind and realcategorical) is equivalent to assuming the classical     *)
(* excluded middle axiom.                                                     *)
(*   We only import the real and realplane libraries, which do not introduce  *)
(* any extra-logical context, in particular no new notation, so that the      *)
(* interpretation of the text below is as transparent as possible.            *)
(*   Accordingly we use qualified names refer to the supporting result in the *)
(* finitize, discretize and combinatorial4ct libraries, and do not rely on    *)
(* the ssreflect extensions in the formulation of the final arguments.        *)
(******************************************************************************)

Section FourColorTheorem.

Variable Rmodel : Real.model.
Let R := Real.model_structure Rmodel.
Implicit Type m : map R.

Theorem four_color_finite m : finite_simple_map m -> colorable_with 4 m.
Proof.
intros fin_m.
pose proof (discretize.discretize_to_hypermap fin_m) as [G planarG colG].
exact (colG (combinatorial4ct.four_color_hypermap planarG)).
Qed.

Theorem four_color m : simple_map m -> colorable_with 4 m.
Proof. revert m; exact (finitize.compactness_extension four_color_finite). Qed.

End FourColorTheorem.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_R1.
Require Export XR_Rmult.
Require Export XR_Rinv.
Require Export XR_Rinv_r.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rinv_r_sym : forall r, r <> R0 -> R1 = r * / r.
Proof.
  intros x h.
  symmetry.
  apply Rinv_r.
  exact h.
Qed.


(** test script for removal of unneeded arguments **)

Load removeNonAug.

Inductive listᵗ (A : Type) (Aᵗ : A -> Type) : list A -> Type :=
    nilᵗ : listᵗ A Aᵗ []
  | consᵗ : forall H : A,
            Aᵗ H -> forall H0 : list A, listᵗ A Aᵗ H0 -> listᵗ A Aᵗ (H :: H0).

Inductive boolᵗ : bool -> Set :=
  trueᵗ : boolᵗ true | falseᵗ : boolᵗ false.
Inductive natᵗ : nat -> Set :=
    Oᵗ : natᵗ 0
  | Sᵗ : forall H : nat, natᵗ H -> natᵗ (S H).

Definition vec := VectorDef.t.

Inductive
vecᵗ (A : Type) (Aᵗ : A -> Type)
  : forall H : nat, natᵗ H -> vec A H -> Type :=
    vecnilᵗ : vecᵗ A Aᵗ 0 Oᵗ (@Vector.nil A)
  | vecconsᵗ : forall H : A,
               Aᵗ H ->
               forall (n : nat) (nᵗ : natᵗ n)
                 (H0 : vec A n),
               vecᵗ A Aᵗ n nᵗ H0 ->
               vecᵗ A Aᵗ (S n) (Sᵗ n nᵗ)
                    (@Vector.cons A H n H0).

(* Inductive *)
(* vecᵗ' (A : Type) (Aᵗ : A -> Type) *)
(*   : forall H : nat, vec A H -> Type := *)
(*     vecnilᵗ' : vecᵗ' A Aᵗ 0 (@Vector.nil A) *)
(*   | vecconsᵗ' : forall H : A, *)
(*                Aᵗ H -> *)
(*                forall (n : nat) *)
(*                (1* (nᵗ : natᵗ n) *1) *)
(*                  (H0 : vec A n), *)
(*                vecᵗ' A Aᵗ n H0 -> *)
(*                vecᵗ' A Aᵗ (S n) *)
(*                     (@Vector.cons A H n H0). *)

(*
Print vecᵗ.

Inductive
vecᵗ (A : Type) (Aᵗ : A -> Type)
  : forall H : nat, natᵗ H -> vec A H -> Type :=
    vecnilᵗ : vecᵗ A Aᵗ 0 Oᵗ (Vector.nil A)
  | vecconsᵗ : forall H : A,
               Aᵗ H ->
               forall (n : nat) (nᵗ : natᵗ n) (H0 : vec A n),
               vecᵗ A Aᵗ n nᵗ H0 ->
               vecᵗ A Aᵗ (S n) (Sᵗ n nᵗ) (Vector.cons A H n H0)
               *)

(* MetaCoq Run (cleanInd "vecᵗ" >>= tmMsg). *)
(* MetaCoq Run (cleanInd listᵗ >>= tmMsg). *)

(* Print vecᵗ0. *)
(* Print listᵗ0. *)

Print tmMkInductive.
Print mutual_inductive_entry.
Search mutual_inductive_entry.
Print mutual_inductive_body.
Print context_decl.

MetaCoq Run (tmQuoteInductive "vecᵗ" >>= tmPrint).

Compute (removeArgList (tApp (tRel 0) [tRel 1;tRel 2;tRel 3]) [1]).

About print_term.
Search global_env_ext.

(* MetaCoq Run ( *)
(* xp <- removeNonAugmentable <% forall(A : Type) (Aᵗ : A -> Type) *)
(*   , forall H : nat, natᵗ H -> vec A H -> Type %> 0 ;; *)
(* y <- tmEval all (xp);; *)
(* tmPrint y;; *)
(* tmMsg (print_term (empty_ext []) [] true y.1)). *)

(* MetaCoq Run ( *)
(* x <- removeNonAugmentable *)
(*   <% *)
(* forall(A : Type) (Aᵗ : A -> Type), *)
(*                forall H : A, *)
(*                Aᵗ H -> *)
(*                forall (n : nat) (nᵗ : natᵗ n) *)
(*                  (H0 : vec A n), *)
(*                vecᵗ A Aᵗ n nᵗ H0 -> *)
(*                vecᵗ A Aᵗ (S n) (Sᵗ n nᵗ) *)
(*                     (@Vector.cons A H n H0) *)
(*   %> 0;; *)
(* y <- tmEval all (x);; *)
(* tmPrint y;; *)
(* tmMsg (print_term (empty_ext []) [] true y.1);; *)
(* tmMsg "";; *)
(* tmMsg "";; *)
(* tmMsg "";; *)
(* y2 <- tmEval all (removeArgList (y.1) [3]);; *)
(* tmPrint y2;; *)
(* tmMsg (print_term (empty_ext []) [] true y2) *)
(* ). *)

(*
1. remove Parameter after non augmentable inductive
2. delete parameter in recursive call

should the function look inside the arguments?
TODO: find examples like (T -> nat) or (nat -> T) in an argument
*)


(** * Constructor and Deconstructor Machines for Lists *)

Require Import ProgrammingTools.

Section CaseList.

  (** ** Deconstructor *)

  Variable X : Type.
  Variable (sigX : finType).
  Hypothesis (cX : codable sigX X).

  Definition stop (s: (sigList sigX)^+) :=
    match s with
    | inr (sigList_cons) => true
    | inr (sigList_nil) => true
    | inl _ => true
    | _ => false
    end.

  Definition Skip_cons : pTM (sigList sigX)^+ unit 1 :=
    Move R;;
    MoveToSymbol stop id.

  Definition M1 : pTM (sigList sigX)^+ unit 2 :=
    LiftTapes Skip_cons [|Fin0|];;
    LiftTapes (Write (inl STOP)) [|Fin1|];;
    MovePar L L;;
    CopySymbols_L stop;;
    LiftTapes (Write (inl START)) [|Fin1|].

  Definition CaseList : pTM (sigList sigX)^+ bool 2 :=
    LiftTapes (Move R) [|Fin0|];;
    Switch (LiftTapes (ReadChar) [|Fin0|])
          (fun s => match s with
                 | Some (inr sigList_nil) => (* nil *)
                   Return (LiftTapes (Move L) [|Fin0|]) false
                 | Some (inr sigList_cons) => (* cons *)
                   M1;;
                   LiftTapes Skip_cons [|Fin0|];;
                   Return (LiftTapes (Move L;; Write (inl START)) [|Fin0|]) true
                 | _ => Return Nop default (* invalid input *)
                 end).

  (** *** Corectness *)

  Definition Skip_cons_Rel : pRel (sigList sigX)^+ unit 1 :=
    Mk_R_p (
        ignoreParam (
            fun tin tout =>
              forall ls rs (x : X) (l : list X),
                tin = midtape (inl START :: ls) (inr sigList_cons)
                              (map inr (encode x) ++ map inr (encode l) ++ inl STOP :: rs) ->
                match l with
                | nil =>
                  tout = midtape (rev (map inr (encode x)) ++ inr sigList_cons :: inl START :: ls)
                                 (inr sigList_nil) (inl STOP :: rs)
                | x'::l' =>
                  tout = midtape (rev (map inr (encode x)) ++ inr sigList_cons :: inl START :: ls)
                                 (inr sigList_cons) (map inr (encode x') ++ map inr (encode l') ++ inl STOP :: rs)
                end)).

  Lemma stop_lemma x :
    forall s : (sigList sigX)^+, s el map inr (map sigList_X (encode x)) -> stop s = false.
  Proof.
    rewrite List.map_map. intros ? (?&<-&?) % in_map_iff. cbn. reflexivity.
  Qed.

  Lemma Skip_cons_Realise : Skip_cons ⊨ Skip_cons_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Skip_cons. TM_Correct. }
    {
      intros tin ((), tout) H. intros ls rs x l HTin. TMSimp. clear_trivial_eqs.
      destruct l as [ | x' l']; cbn.
      - rewrite MoveToSymbol_correct_moveright; cbn; auto.
        + now rewrite map_id.
        + apply stop_lemma.
      - rewrite MoveToSymbol_correct_moveright; cbn; auto.
        + rewrite map_id, map_app, <- app_assoc. reflexivity.
        + apply stop_lemma.
    }
  Qed.

  Definition M1_Rel : pRel (sigList sigX)^+ unit 2 :=
    ignoreParam (
        fun tin tout =>
          forall ls rs (x : X) (l : list X),
            isRight tin[@Fin1] ->
            tin[@Fin0] = midtape (inl START :: ls) (inr sigList_cons)
                                 (map inr (encode x) ++ map inr (encode l) ++ inl STOP :: rs) ->
            tout[@Fin0] = tin[@Fin0] /\
            tout[@Fin1] ≃ x).

  Lemma M1_Realise : M1 ⊨ M1_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold M1. TM_Correct. eapply Skip_cons_Realise. }
    {
      intros tin ((), tout) H. intros ls rs x l HRight HTin0. TMSimp; clear_trivial_eqs.
      rename H2 into HCopy.
      destruct HRight as (r1&r2&HRight). TMSimp. clear HRight.

      specialize H with (1 := eq_refl).
      destruct l as [ | x' l']; TMSimp.
      - rewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
        2: setoid_rewrite <- in_rev; apply stop_lemma.
        inv HCopy. TMSimp.
        cbn. rewrite !rev_involutive. repeat econstructor. cbn. f_equal. simpl_tape. reflexivity.
      - rewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
        2: setoid_rewrite <- in_rev; apply stop_lemma.
        inv HCopy. TMSimp.
        cbn. rewrite !rev_involutive. repeat econstructor.
        + f_equal. rewrite map_app, <- app_assoc. reflexivity.
        + cbn. f_equal. simpl_tape. reflexivity.
    }
  Qed.

  Definition CaseList_Rel : pRel (sigList sigX)^+ bool 2 :=
    fun tin '(yout, tout) =>
      forall (l : list X),
        tin[@Fin0] ≃ l ->
        isRight tin[@Fin1] ->
        match yout, l with
        | false, nil =>
          tout[@Fin0] ≃ nil /\
          isRight tout[@Fin1]
        | true, x :: l' =>
          tout[@Fin0] ≃ l' /\
          tout[@Fin1] ≃ x
        | _, _ => False
        end.

  Lemma CaseList_Realise : CaseList ⊨ CaseList_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold CaseList. TM_Correct. eapply M1_Realise. eapply Skip_cons_Realise. }
    {
      intros tin (yout, tout) H. intros l HEncL HRight.
      destruct HEncL as (ls&HEncL). pose proof HRight as (ls'&rs'&HRight'). TMSimp; clear_trivial_eqs.
      destruct l as [ | x l'] in *; cbn in *; TMSimp; clear_trivial_eqs.
      { (* nil *)
        split; auto.
        - repeat econstructor; cbn; simpl_tape.
      }
      { (* cons *)
        rewrite map_app, <- app_assoc in *.
        specialize H1 with (1 :=HRight) (2 := eq_refl).
        TMSimp. symmetry in H0. specialize H2 with (1 := eq_refl).
        destruct l' as [ | x' l'']; TMSimp.
        - repeat split; auto. repeat econstructor. f_equal. simpl_tape. cbn. reflexivity.
        - repeat split; auto. repeat econstructor. f_equal. simpl_tape. cbn. now rewrite map_app, <- app_assoc.
      }
    }
  Qed.

  (** *** Termination *)

  Local Arguments plus : simpl never. Local Arguments mult : simpl never.

  Lemma Skip_cons_Terminates :
    projT1 (Skip_cons) ↓
           (fun tin k =>
              exists ls rs (x : X) (l : list X),
                tin[@Fin0] = midtape (inl START :: ls) (inr sigList_cons)
                                     (map inr (encode x) ++ map inr (encode l) ++ inl STOP :: rs) /\
                 6 + 4 * size cX x <= k).
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Skip_cons. TM_Correct. }
    {
      intros tin k (ls&rs&x&l&HTin&Hk). TMSimp. clear HTin.
      exists 1, (4 + 4 * size cX x). repeat split. 1-2: omega.
      intros tmid () H. TMSimp. clear H.
      destruct l as [ | x' l]; cbn.
      - rewrite MoveToSymbol_steps_moveright; cbn; auto. now rewrite !map_length.
      - rewrite MoveToSymbol_steps_moveright; cbn; auto. now rewrite !map_length.
    }
  Qed.

  Lemma M1_Terminates :
    projT1 M1 ↓
           (fun tin k =>
              exists ls rs (x : X) (l : list X),
                tin[@Fin0] = midtape (inl START :: ls) (inr sigList_cons)
                                     (map inr (encode x) ++ map inr (encode l) ++ inl STOP :: rs) /\
                 23 + 12 * size cX x <= k).
  Proof.
    eapply TerminatesIn_monotone.
    { unfold M1. TM_Correct. eapply Skip_cons_Realise. eapply Skip_cons_Terminates. }
    {
      intros tin k (ls&rs&x&l&HTin&Hk). TMSimp. clear HTin.
      exists (6 + 4 * size cX x), (16 + 8 * size cX x). repeat split; try omega. eauto 6.
      intros tmid (). intros (H&HInj); TMSimp. specialize H with (1 := eq_refl).
      destruct l as [ | x' l']; TMSimp. (* Both cases are identical *)
      1-2: exists 1, (14 + 8 * size cX x); repeat split; try omega.
      - intros tmid2 (). intros (_&HInj2); TMSimp.
        exists 3, (10 + 8 * size cX x). repeat split; try omega.
        intros tmid3 (). intros (H3&H3'); TMSimp.
        exists (8+8*size cX x), 1. repeat split; cbn; try omega.
        + rewrite CopySymbols_L_steps_moveleft; auto.
          now rewrite rev_length, !map_length.
        + intros tmid4 () _. omega.
      - intros tmid2 (). intros (_&HInj2); TMSimp.
        exists 3, (10 + 8 * size cX x). repeat split; try omega.
        intros tmid3 (). intros (H3&H3'); TMSimp.
        exists (8+8*size cX x), 1. repeat split; cbn; try omega.
        + rewrite CopySymbols_L_steps_moveleft; auto.
          now rewrite rev_length, !map_length.
        + intros tmid4 () _. omega.
    }
  Qed.

  Definition CaseList_steps_cons (x : X) := 42 + 16 * size cX x.

  Definition CaseList_steps_nil := 5.

  Definition CaseList_steps l :=
    match l with
    | nil => CaseList_steps_nil
    | x::l' => CaseList_steps_cons x
    end.

  Lemma CaseList_Terminates :
    projT1 CaseList ↓
           (fun tin k =>
              exists l : list X,
                tin[@Fin0] ≃ l /\
                isRight tin[@Fin1] /\
                CaseList_steps l <= k).
  Proof.
    unfold CaseList_steps, CaseList_steps_cons, CaseList_steps_nil. eapply TerminatesIn_monotone.
    { unfold CaseList. TM_Correct.
      - eapply M1_Realise.
      - eapply M1_Terminates.
      - eapply Skip_cons_Realise.
      - eapply Skip_cons_Terminates.
    }
    {
      cbn. intros tin k (l&HEncL&HRight&Hk).
      destruct HEncL as (ls&HEncL); TMSimp.
      destruct l as [ | x l']; cbn.
      {
        exists 1, 3. repeat split; try omega.
        intros tmid (). intros (H1&HInj1); TMSimp.
        exists 1, 1. repeat split; try omega.
        intros tmid2 ymid2 ((H2&H2')&HInj2). apply Vector.cons_inj in H2' as (H2'&_). TMSimp.
        omega.
      }
      {
        exists 1, (40 + 16 * size cX x). repeat split; try omega.
        intros tmid (). intros (H1&HInj1); TMSimp.
        exists 1, (38 + 16 * size cX x). repeat split; try omega.
        intros tmid2 ymid2 ((H2&H2')&HInj2). apply Vector.cons_inj in H2' as (H2'&_). TMSimp.
        exists (23 + 12 * size cX x), (14 + 4 * size cX x). repeat split; try omega.
        { TMSimp_goal. rewrite List.map_app, <- app_assoc. do 4 eexists; eauto. }
        intros tmid3 () H3'.
        rewrite map_app, <- app_assoc in H3'. specialize H3' with (1 := HRight) (2 := eq_refl). TMSimp.
        exists (6 + 4 * size cX x), 3. repeat split; try omega. eauto 6.
        intros tmid4 () (H4&HInj4); TMSimp. specialize H4 with (1 := eq_refl).
        destruct l' as [ | x' l'']; TMSimp. (* both cases are equal *)
        - exists 1, 1. repeat split; try omega. intros ? _ _. omega.
        - exists 1, 1. repeat split; try omega. intros ? _ _. omega.
      }
    }
  Qed.

  (** ** [IsNil] *)

  Definition IsNil : pTM (sigList sigX)^+ bool 1 :=
    Move R;;
    Switch ReadChar
    (fun s =>
       match s with
       | Some (inr sigList_nil) =>
         Return (Move L) true
       | _ => Return (Move L) false
       end).

  Definition IsNil_Rel : pRel (sigList sigX)^+ bool 1 :=
    Mk_R_p (
        fun tin '(yout, tout) =>
          forall (xs : list X),
            tin ≃ xs ->
            match yout, xs with
            | true, nil => tout ≃ xs
            | false, _ :: _ => tout ≃ xs
            | _, _ => False
            end).

  Definition IsNil_steps := 5.

  Lemma IsNil_Sem : IsNil ⊨c(IsNil_steps) IsNil_Rel.
  Proof.
    unfold IsNil_steps. eapply RealiseIn_monotone.
    { unfold IsNil. TM_Correct. }
    { Unshelve. 4-11: reflexivity. omega. }
    {
      intros tin (yout, tout) H. cbn. intros xs HEncXs.
      destruct HEncXs as (ls & HEncXs). TMSimp.
      destruct xs as [ | x xs' ]; TMSimp.
      - repeat econstructor.
      - repeat econstructor.
    }
  Qed.

  (** ** Constructors *)

  (** *** [nil] *)

  Definition Constr_nil : pTM (sigList sigX)^+ unit 1 := WriteValue [sigList_nil].

  Goal Constr_nil = WriteMove (inl STOP) L;; WriteMove (inr sigList_nil) L;; Write (inl START).
  Proof. reflexivity. Qed.

  Definition Constr_nil_Rel : pRel (sigList sigX)^+ unit 1 :=
    Mk_R_p (ignoreParam (fun tin tout => isRight tin -> tout ≃ nil)).

  Definition Constr_nil_steps := 5.

  Lemma Constr_nil_Sem : Constr_nil ⊨c(Constr_nil_steps) Constr_nil_Rel.
  Proof.
    unfold Constr_nil_steps. eapply RealiseIn_monotone.
    { unfold Constr_nil. TM_Correct. }
    { reflexivity. }
    { intros tin ((), tout) H. cbn in *. auto. }
  Qed.

  (** *** [cons] *)

  Definition Constr_cons : pTM (sigList sigX)^+ unit 2 :=
    LiftTapes (MoveRight _;; Move L) [|Fin1|];;
    LiftTapes (CopySymbols_L stop) [|Fin1;Fin0|];;
    LiftTapes (WriteMove (inr sigList_cons) L;; Write (inl START)) [|Fin0|].

  Definition Constr_cons_Rel : pRel (sigList sigX)^+ unit 2 :=
    ignoreParam (
        fun tin tout =>
          forall l y,
            tin[@Fin0] ≃ l ->
            tin[@Fin1] ≃ y ->
            tout[@Fin0] ≃ y :: l /\
            tout[@Fin1] ≃ y
      ).

  Lemma Constr_cons_Realise : Constr_cons ⊨ Constr_cons_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Constr_cons. TM_Correct. apply MoveRight_Realise with (X := X). }
    {
      intros tin ((), tout) H. intros l y HEncL HEncY.
      TMSimp; clear_trivial_eqs.
      specialize (H y HEncY) as (ls&H). TMSimp.
      destruct HEncL as (ls2&HEncL). TMSimp.
      rewrite CopySymbols_L_correct_moveleft in H0; swap 1 2; auto.
      { intros ? (?&<-& (?&<-&?) % in_rev % in_map_iff) % in_map_iff. cbn. reflexivity. }
      inv H0. TMSimp.
      repeat econstructor.
      - cbn. f_equal. simpl_tape. rewrite !map_rev, rev_involutive. f_equal.
        now rewrite !List.map_map, map_app, <- app_assoc, List.map_map.
      - f_equal. now rewrite !map_rev, rev_involutive.
    }
  Qed.

  Definition Constr_cons_steps (x : X) := 23 + 12 * size _ x.

  Lemma Constr_cons_Terminates :
    projT1 Constr_cons ↓
           (fun tin k =>
              exists (l: list X) (y: X),
                tin[@Fin0] ≃ l /\
                tin[@Fin1] ≃ y /\
                Constr_cons_steps y <= k).
  Proof.
    unfold Constr_cons_steps. eapply TerminatesIn_monotone.
    { unfold Constr_cons. TM_Correct.
      - apply MoveRight_Realise with (X := X).
      - apply MoveRight_Realise with (X := X).
      - apply MoveRight_Terminates with (X := X).
    }
    {
      intros tin k (l&y&HEncL&HEncY&Hk). cbn.
      exists (10 + 4 * size _ y), (12 + 8 * size _ y). repeat split; try omega.
      - cbn. exists (8 + 4 * size _ y), 1. repeat split; try omega.
        + eexists. split. eauto. unfold MoveRight_steps. now rewrite Encode_map_hasSize.
        + now intros _ _ _.
      - intros tmid () (H&HInj). TMSimp.
        specialize (H _ HEncY) as (ls&HEncY'). TMSimp.
        exists (8 + 8 * size _ y), 3. repeat split; try omega.
        + erewrite CopySymbols_L_steps_moveleft; eauto. now rewrite map_length, rev_length, map_length.
        + intros tmid2 (). intros (H2&HInj2). TMSimp.
          exists 1, 1. repeat split; try omega. intros ? _ _. omega.
    }
  Qed.

End CaseList.

Arguments CaseList : simpl never.
Arguments IsNil : simpl never.
Arguments Constr_nil : simpl never.
Arguments Constr_cons : simpl never.

(** ** Compatibility of running time functions with encoding mapping *)

Section Steps_comp.
  Variable (sig tau: finType) (X:Type) (cX: codable sig X).
  Variable (I : Retract sig tau).

  Lemma CaseList_steps_cons_comp x :
    CaseList_steps_cons (Encode_map cX I) x = CaseList_steps_cons cX x.
  Proof. unfold CaseList_steps_cons. now rewrite Encode_map_hasSize. Qed.

  Lemma CaseList_steps_comp l :
    CaseList_steps (Encode_map cX I) l = CaseList_steps cX l.
  Proof. unfold CaseList_steps. destruct l; auto. apply CaseList_steps_cons_comp. Qed.

  Lemma Constr_cons_steps_comp l :
    Constr_cons_steps (Encode_map cX I) l = Constr_cons_steps cX l.
  Proof. unfold Constr_cons_steps. now rewrite Encode_map_hasSize. Qed.

End Steps_comp.

(** ** Tactic Support *)

Ltac smpl_TM_CaseList :=
  lazymatch goal with
  | [ |- CaseList _ ⊨ _ ] => apply CaseList_Realise
  | [ |- projT1 (CaseList _) ↓ _ ] => apply CaseList_Terminates

  | [ |- IsNil _ ⊨ _ ] => eapply RealiseIn_Realise; apply IsNil_Sem
  | [ |- IsNil _ ⊨c(_) _ ] => apply IsNil_Sem
  | [ |- projT1 (IsNil _ ) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply IsNil_Sem

  | [ |- Constr_nil _ ⊨ _ ] => eapply RealiseIn_Realise; apply Constr_nil_Sem
  | [ |- Constr_nil _ ⊨c(_) _ ] => apply Constr_nil_Sem
  | [ |- projT1 (Constr_nil _) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Constr_nil_Sem

  | [ |- Constr_cons _ ⊨ _ ] => apply Constr_cons_Realise
  | [ |- projT1 (Constr_cons _) ↓ _ ] => apply Constr_cons_Terminates
  end.

Smpl Add smpl_TM_CaseList : TM_Correct.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo77:
  prime  1642101276132584953776278568705188245389037->
  prime  979920652329567805996085186101517086130053709503.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      979920652329567805996085186101517086130053709503
      596748
      ((1642101276132584953776278568705188245389037,1)::nil)
      0
      5832
      9
      81)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem2: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem2. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (rev (append x y))) (append (rev (rev x)) (rev (rev y))).
Proof.
  intros. rewrite lem.
  rewrite lem.
  lfind. Admitted.


Require Import Coq.Strings.Ascii Coq.Strings.String Coq.Lists.List.
Require Import Coq.Numbers.BinNums.
Require Import Coq.QArith.QArith.
Require Import Coq.ZArith.BinInt.
Require Import Crypto.Util.Option.
Require Coq.Strings.BinaryString.
Require Coq.Strings.OctalString.
Require Coq.Strings.HexString.
Require Import Crypto.Util.Strings.Decimal.
Require Import Crypto.Util.Strings.Parse.Common.
Require Import Crypto.Util.Notations.
Import ListNotations.
Import BinPosDef.
Local Open Scope option_scope.
Local Open Scope list_scope.
Local Open Scope char_scope.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope nat_scope.

Definition is_num (ch : ascii) : bool
  := match DecimalString.uint_of_char ch (Some Decimal.Nil) with Some _ => true | None => false end.

Definition is_oct_num (ch : ascii) : bool
  := match OctalString.ascii_to_digit ch with Some _ => true | None => false end.

Definition is_hex_num (ch : ascii) : bool
  := match HexString.ascii_to_digit ch with Some _ => true | None => false end.

Definition startswith_oct (s : string) : bool
  := match s with
     | String zero (String kind (String d rest))
       => (zero =? "0")%char && (kind =? "o")%char && is_oct_num d
     | _ => false
     end.

Definition startswith_hex (s : string) : bool
  := match s with
     | String zero (String kind (String d rest))
       => (zero =? "0")%char && (kind =? "x")%char && is_hex_num d
     | _ => false
     end.

Definition parse_bin_prefix : ParserAction _ := "0b".
Definition parse_oct_prefix : ParserAction _ := "0o".
Definition parse_dec_prefix : ParserAction _ := "".
Definition parse_hex_prefix : ParserAction _ := "0x".

(** Is [E]/[e] a valid digit in the given base? *)
Definition base_accepts_E (base : N) : bool
  := (10 + N_of_ascii "E" - N_of_ascii "A" <? base)%N.

Definition parse_digits_gen_step (base : N) : ParserAction N
  := (parse_strs
        (List.flat_map
           (fun v => if (v <? 10)%N
                     then [(String (ascii_of_N (v + N_of_ascii "0")) "", v)]
                     else [(String (ascii_of_N (v - 10 + N_of_ascii "A")) "", v);
                             (String (ascii_of_N (v - 10 + N_of_ascii "a")) "", v)])
           (List.map N.of_nat (List.seq 0 (N.to_nat base))))).

(*
Definition parse_oct_digits : ParserAction (list N)
  := Eval cbv -[ParserAction parse_alt_gen parse_impossible parse_str parse_star] in
      parse_digits_gen 8.
Definition parse_dec_digits : ParserAction (list N)
  := Eval cbv -[ParserAction parse_alt_gen parse_impossible parse_str parse_star] in
      parse_digits_gen 10.
Definition parse_hex_digits : ParserAction (list N)
  := Eval cbv -[ParserAction parse_alt_gen parse_impossible parse_str parse_star] in
      parse_digits_gen 16.
 *)

Definition digits_to_N (base : N) (digits : list N) : N
  := List.fold_left
       (fun so_far d => base * so_far + d)%N
       digits
       0%N.

Redirect "log" Check eq_refl : digits_to_N 10 [1;2;3;4;5;6]%N = 123456%N.

Local Coercion N.of_nat : nat >-> N.
Local Coercion Z.of_N : N >-> Z.
Local Coercion inject_Z : Z >-> Q.

Definition parse_N_digits (base : N) : ParserAction N
  := (parse_map (digits_to_N base) ((parse_digits_gen_step base)+)).

Definition parse_num_gen (allow_neg : bool) {P} (base : N) (parse_prefix : ParserAction P) : ParserAction Q
  := let parse_E_exponent
         := (("e" || "E") ;;->{ fun _ v => Qpower 10 v }
                          (((strip_whitespace_after "-")?)
                             ;;->{ fun n (v:N) => if n:option _ then (-v)%Z else v }
                             (parse_N_digits base)))%parse in
     let parse_P_exponent
         := (("p" || "P") ;;->{ fun _ v => Qpower 2 v }
                          (((strip_whitespace_after "-")?)
                             ;;->{ fun n (v:N) => if n:option _ then (-v)%Z else v }
                             (parse_N_digits base)))%parse in
     (if allow_neg then ((strip_whitespace_after "-")?) else parse_map (fun _ => None) "")
       ;;->{ fun n v => if n:option _ then (-v)%Q else v }
       parse_prefix ;;->{ fun _ v => v }
       ((((parse_digits_gen_step base)* )
           ;;->{ fun ds decimals
                 => (digits_to_N base ds
                     + digits_to_N base decimals / base^List.length decimals)%Q }
           "." ;;->{ fun _ v => v }
           (parse_digits_gen_step base)* )
        || parse_map (digits_to_N base : _ -> Q) ((parse_digits_gen_step base)+))
       ;;->{ fun n e => match e with Some e => n * e | None => n end%Q }
       ((if base_accepts_E base
         then parse_P_exponent (* if [e] is a valid character in the base, then we don't permit [e] as an exponent *)
         else (parse_E_exponent || parse_P_exponent))?).

Definition parse_num (allow_neg : bool) : ParserAction Q
  := parse_num_gen allow_neg 2 parse_bin_prefix
     || parse_num_gen allow_neg 8 parse_oct_prefix
     || parse_num_gen allow_neg 10 parse_dec_prefix
     || parse_num_gen allow_neg 16 parse_hex_prefix.

Definition parse_int_gen (allow_neg : bool) {P} (base : N) (parse_prefix : ParserAction P) : ParserAction Z
  := let parse_E_exponent
         := (("e" || "E") ;;->{ fun _ (v:N) => Z.pow 10 v } (parse_N_digits base))%parse in
     let parse_P_exponent
         := (("p" || "P") ;;->{ fun _ (v:N) => Z.pow 2 v } (parse_N_digits base))%parse in
     (if allow_neg then ((strip_whitespace_after "-")?) else parse_map (fun _ => None) "")
       ;;->{ fun n v => if n:option _ then (-v)%Z else v }
       parse_prefix ;;->{ fun _ v => v }
       (parse_N_digits base)
       ;;->{ fun (n:N) e => match e with Some e => n * e | None => n end%Z }
       ((if base_accepts_E base
         then parse_P_exponent (* if [e] is a valid character in the base, then we don't permit [e] as an exponent *)
         else (parse_E_exponent || parse_P_exponent))?).

Definition parse_int (allow_neg : bool) : ParserAction Z
  := parse_int_gen allow_neg 2 parse_bin_prefix
     || parse_int_gen allow_neg 8 parse_oct_prefix
     || parse_int_gen allow_neg 10 parse_dec_prefix
     || parse_int_gen allow_neg 16 parse_hex_prefix.

Redirect "log" Check let ls := [("-1234", -(1234):Q); ("0xF", 15:Q); ("10.5", (10 + 5/10)); ("-10.5", -(10+5/10))]%Q in
                     eq_refl
                     : List.map (fun '(s, v) => ((parse_num true;;->{fun v _ => v} ε)%parse s )) ls
                       = List.map (fun '(s, v) => [(v, "")]) ls.

(* This was previously stack overflowing due to treating [e] as an exponent *)
Redirect "log" Compute parse_num false "0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551".

Inductive Qexpr := Qv (_ : Q) | Qeopp (a : Qexpr) | Qeadd (a b : Qexpr) | Qesub (a b : Qexpr) | Qemul (a b : Qexpr) | Qediv (a b : Qexpr) | Qepow (b e : Qexpr).
Coercion Qv : Q >-> Qexpr.
Delimit Scope Qexpr_scope with Qexpr.
Bind Scope Qexpr_scope with Qexpr.
Infix "^" := Qepow : Qexpr_scope.
Infix "*" := Qemul : Qexpr_scope.
Infix "+" := Qeadd : Qexpr_scope.
Infix "/" := Qediv : Qexpr_scope.
Infix "-" := Qesub : Qexpr_scope.
Notation "- x" := (Qeopp x) : Qexpr_scope.

Fixpoint eval_Qexpr (v : Qexpr) : Q
  := match v with
     | Qv x => x
     | Qeopp a => Qopp (eval_Qexpr a)
     | Qeadd a b => Qplus (eval_Qexpr a) (eval_Qexpr b)
     | Qesub a b => Qminus (eval_Qexpr a) (eval_Qexpr b)
     | Qemul a b => Qmult (eval_Qexpr a) (eval_Qexpr b)
     | Qediv a b => Qdiv (eval_Qexpr a) (eval_Qexpr b)
     | Qepow b e => let b := eval_Qexpr b in
                    let e := eval_Qexpr e in
                    let (qe, re) := Z.div_eucl (Qnum e) (Z.pos (Qden e)) in
                    (* (b^qe)*(b^(re/Qden e)) *)
                    Qmult (Qpower b qe) (Qpower b (* approximate *) (re / Z.pos (Qden e)))
     end.

Fixpoint eval_Qexpr_strict (v : Qexpr) : option Q
  := match v with
     | Qv x => Some x
     | Qeopp a => option_map Qopp (eval_Qexpr_strict a)
     | Qeadd a b => a <- eval_Qexpr_strict a; b <- eval_Qexpr_strict b; Some (Qplus a b)
     | Qesub a b => a <- eval_Qexpr_strict a; b <- eval_Qexpr_strict b; Some (Qminus a b)
     | Qemul a b => a <- eval_Qexpr_strict a; b <- eval_Qexpr_strict b; Some (Qmult a b)
     | Qediv a b => a <- eval_Qexpr_strict a; b <- eval_Qexpr_strict b; if Qeq_bool b 0 then None else Some (Qdiv a b)
     | Qepow b e => b <- eval_Qexpr_strict b;
                      e <- eval_Qexpr_strict e;
                      let (qe, re) := Z.div_eucl (Qnum e) (Z.pos (Qden e)) in
                      if Z.eqb re 0 && (negb (Qeq_bool b 0) || Z.ltb 0 qe)
                      then Some (Qpower b qe)
                      else None
     end.

Definition parse_ops {A} (ls : list (string * (A -> A -> A))) (parse : ParserAction A) : ParserAction A
  := parse ;;->{fun l fs => List.fold_left (fun v f => f v) fs l}
           (strip_whitespace_around (parse_strs ls) ;;->{fun f r l => f l r}
                                    parse)*.

Definition parse_prefix_ops {A} (ls : list (string * (A -> A))) (parse : ParserAction A) : ParserAction A
  := ((strip_whitespace_after (parse_strs ls))* )
       ;;->{fun ls v => fold_right (fun f x => f x) v ls }
       parse.

Section step.
  Context (parse_num : ParserAction Q)
          (parse : ParserAction Qexpr).

  Definition parseQexpr_gen_parens : ParserAction Qexpr
    := ("(" ;;->{fun _ v => v} strip_whitespace_around parse ;;->{fun v _ => v} ")")
       || parse_map Qv parse_num.
  Definition parseQexpr_gen_exp : ParserAction Qexpr
    := parse_ops [("^", Qepow)] parseQexpr_gen_parens.
  Definition parseQexpr_gen_opp : ParserAction Qexpr
    := parse_prefix_ops [("-", Qeopp)] parseQexpr_gen_exp.
  Definition parseQexpr_gen_mul_div : ParserAction Qexpr
    := parse_ops [("*", Qemul); ("/", Qediv)] parseQexpr_gen_opp.
  Definition parseQexpr_gen_add_sub : ParserAction Qexpr
    := parse_ops [("+", Qeadd); ("-", Qesub)] parseQexpr_gen_mul_div.
End step.

Fixpoint parse_Qexpr_fueled (parse_num : ParserAction Q) (fuel : nat) : ParserAction Qexpr
  := strip_whitespace_around
       (parseQexpr_gen_add_sub parse_num
                               (match fuel with
                                | O => parse_impossible
                                | S fuel => parse_Qexpr_fueled parse_num fuel
                                end)).

Definition parse_Qexpr_gen (parse_num : ParserAction Q) : ParserAction Qexpr := fuel (parse_Qexpr_fueled parse_num).

Definition parse_Qexpr_with_vars (vars : list (string * Q)) : ParserAction Qexpr
  := parse_Qexpr_gen
       (List.fold_right
          (fun '((s, q) : string * Q) default => default || parse_map (fun _ => q) s)%parse
          (parse_num false)
          vars).

Definition Q_to_Z (q : Q) : Z := (Qnum q / Z.pos (Qden q))%Z.
Definition Q_to_Z_strict (x : Q) : option Z
  := let '(q, r) := Z.div_eucl (Qnum x) (Zpos (Qden x)) in
     if Z.eqb r 0
     then Some q
     else None.
Definition N_of_Z_strict (z : Z) : option N
  := match z with Z0 => Some N0 | Zpos p => Some (Npos p) | Zneg _ => None end.
Definition positive_of_N (n : N) : positive
  := match n with N0 => 1%positive | Npos p => p end.
Definition positive_of_N_strict (n : N) : option positive
  := match n with N0 => None | Npos p => Some p end.

Definition parse_Q_with_vars (vars : list (string * Q)) : ParserAction Q
  := parse_map eval_Qexpr (parse_Qexpr_with_vars vars).
Definition parse_Q_strict_with_vars (vars : list (string * Q)) : ParserAction Q
  := parse_option_list_map eval_Qexpr_strict (parse_Qexpr_with_vars vars).
Definition parse_Z_with_vars (vars : list (string * Q)) : ParserAction Z
  := parse_map Q_to_Z (parse_Q_with_vars vars).
Definition parse_Z_strict_with_vars (vars : list (string * Q)) : ParserAction Z
  := parse_option_list_map Q_to_Z_strict (parse_Q_strict_with_vars vars).
Definition parse_N_with_vars (vars : list (string * Q)) : ParserAction N
  := parse_map Z.to_N (parse_Z_with_vars vars).
Definition parse_N_strict_with_vars (vars : list (string * Q)) : ParserAction N
  := parse_option_list_map N_of_Z_strict (parse_Z_strict_with_vars vars).
Definition parse_nat_with_vars (vars : list (string * Q)) : ParserAction nat
  := parse_map N.to_nat (parse_N_with_vars vars).
Definition parse_nat_strict_with_vars (vars : list (string * Q)) : ParserAction nat
  := parse_map N.to_nat (parse_N_strict_with_vars vars).
Definition parse_positive_with_vars (vars : list (string * Q)) : ParserAction positive
  := parse_map positive_of_N (parse_N_with_vars vars).
Definition parse_positive_strict_with_vars (vars : list (string * Q)) : ParserAction positive
  := parse_option_list_map positive_of_N_strict (parse_N_strict_with_vars vars).

Definition parseQexpr_arith_with_vars (vars : list (string * Q)) (s : string) : option Qexpr
  := finalize (parse_Qexpr_with_vars vars) s.
Definition parseQ_arith_with_vars (vars : list (string * Q)) (s : string) : option Q
  := option_map eval_Qexpr (parseQexpr_arith_with_vars vars s).
Definition parseZ_arith_with_vars (vars : list (string * Q)) (s : string) : option Z
  := (q <- parseQ_arith_with_vars vars s; Some (Qnum q / Z.pos (Qden q)))%Z%option.
Definition parsepositive_arith_with_vars (vars : list (string * Q)) (s : string) : option positive
  := (z <- parseZ_arith_with_vars vars s; match z with Z0 => None | Zpos p => Some p | Zneg _ => None end).
Definition parseN_arith_with_vars (vars : list (string * Q)) (s : string) : option N
  := (z <- parseZ_arith_with_vars vars s; match z with Z0 => Some 0 | Zpos p => Some (Npos p) | Zneg _ => None end)%N%option.
Definition parsenat_arith_with_vars (vars : list (string * Q)) (s : string) : option nat
  := (n <- parseN_arith_with_vars vars s; Some (N.to_nat n)).

Definition parseQ_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option Q
  := (q <- parseQexpr_arith_with_vars vars s; eval_Qexpr_strict q)%option.
Definition parseZ_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option Z
  := (q <- parseQ_arith_strict_with_vars vars s; Q_to_Z_strict q)%option.
Definition parsepositive_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option positive
  := (z <- parseZ_arith_strict_with_vars vars s; match z with Z0 => None | Zpos p => Some p | Zneg _ => None end).
Definition parseN_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option N
  := (z <- parseZ_arith_strict_with_vars vars s; match z with Z0 => Some 0 | Zpos p => Some (Npos p) | Zneg _ => None end)%N%option.
Definition parsenat_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option nat
  := (n <- parseN_arith_strict_with_vars vars s; Some (N.to_nat n)).

Definition parse_Qexpr := parse_Qexpr_with_vars [].
Definition parseQexpr_arith := parseQexpr_arith_with_vars [].
Definition parseQ_arith := parseQ_arith_with_vars [].
Definition parseZ_arith := parseZ_arith_with_vars [].
Definition parsepositive_arith := parsepositive_arith_with_vars [].
Definition parseN_arith := parseN_arith_with_vars [].
Definition parsenat_arith := parsenat_arith_with_vars [].
Definition parseQ_arith_strict := parseQ_arith_strict_with_vars [].
Definition parseZ_arith_strict := parseZ_arith_strict_with_vars [].
Definition parsepositive_arith_strict := parsepositive_arith_strict_with_vars [].
Definition parseN_arith_strict := parseN_arith_strict_with_vars [].
Definition parsenat_arith_strict := parsenat_arith_strict_with_vars [].

Definition parse_Q_arith := parse_Q_with_vars [].
Definition parse_Q_arith_strict := parse_Q_strict_with_vars [].
Definition parse_Z_arith := parse_Z_with_vars [].
Definition parse_Z_arith_strict := parse_Z_strict_with_vars [].
Definition parse_N_arith := parse_N_with_vars [].
Definition parse_N_arith_strict := parse_N_strict_with_vars [].
Definition parse_nat_arith := parse_nat_with_vars [].
Definition parse_nat_arith_strict := parse_nat_strict_with_vars [].
Definition parse_positive_arith := parse_positive_with_vars [].
Definition parse_positive_arith_strict := parse_positive_strict_with_vars [].

Redirect "log" Check eq_refl : parseQexpr_arith "1 + -2" = Some (1%Q + - 2%Q)%Qexpr.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e488m17_20limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e414m17_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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 O E Eprime B C U : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (col_ O E O /\ (col_ O E B /\ (col_ O E C /\ (col_ O E O /\ col_ O E U)))))))) -> col_ O U C)).
Proof.
  time tac.
Qed.

End FOFProblem.