(**************************************************************************
* TLC: A library for Coq                                                  *
* Examples for LibFix                                                     *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibReflect LibFunc LibEpsilon LibList
  LibInt LibNat LibProd LibSum LibRelation LibWf LibFix LibStream.
Require Import Div2.
Open Scope nat_scope.
Open Scope comp_scope.
Open Scope func_scope.

(** Setting up of automation *)

Hint Resolve lt_wf : wf.

Ltac auto_tilde ::= auto with wf.
Ltac auto_star ::= try solve [ auto | false | math | intuition eauto ].

Hint Resolve list_equiv_equiv.

(* ********************************************************************** *)
(** * DFS *)

Module DFS.

Parameter marks : Type.
Parameter marks_inhab : Inhab marks.
Existing Instance marks_inhab.
Implicit Type i : nat.

Parameter is_marked : marks -> nat -> bool.
Parameter add_mark : marks -> nat -> marks.
Parameter nb_unmarked : marks -> nat.
Parameter add_mark_nb_unmarked : forall m i,
  is_marked m i = false ->
  nb_unmarked (add_mark m i) < nb_unmarked m.

Parameter neighbours : nat -> list nat.

Definition Dfs dfs m i :=
  'let m := add_mark m i in
  'let v := neighbours i in
  'let aux := (fun j m => if is_marked m j then m else dfs m j) in
  fold_left aux m v.

Definition dfs := FixFun2 Dfs.

Lemma fix_dfs : forall m i,
  is_marked m i = false ->
  dfs m i = Dfs dfs m i.
  (* Could be added to the statement:
     /\ (forall m i, is_marked m i = false ->
         nb_unmarked (Dfs dfs m i) < nb_unmarked m). *)
Proof using.
  applys~ FixFun2_fix_partial_inv
    (measure2 (fun m i => nb_unmarked m))
    (fun m i m' => nb_unmarked m' < nb_unmarked m).
  intros m i f1 f2 Hi IH. unfolds Dfs.
  unfold measure2 in IH. sets_eq N: (nb_unmarked m).
  let_name_all. let_name_all.
  let_name_all as aux1. let_name_all as aux2.
  asserts L: (nb_unmarked m0 < N).
    subst N m0. applys* add_mark_nb_unmarked.
  clears m i. gen m0. induction v as [|i v]. simple*.
  intros m Lt. simpl.
  asserts [E F]: (aux1 i m = aux2 i m /\ nb_unmarked (aux1 i m) < N).
    rewrite EQaux1, EQaux2. case_if as C.
      auto.
      forwards* [E L]: IH C. split. auto. math.
  rewrite <- E. applys* IHv.
Qed.

(*
Extraction Language Ocaml.
Extraction Inline Dfs
  FixFun2Mod FixFun2 curry2 uncurry2 FixFunMod.
Set Extraction Optimize.
Extraction dfs.
*)

End DFS.

(* ********************************************************************** *)
(** * COFE for streams *)

(** Definition of stream ordered family of requiv *)

Definition stream_mod_family A (E:binary A) : family nat (stream A) :=
  nat_family (bisimilar_mod_upto E).

(** Special case of comparing stream values wrt equality *)

Definition stream_family A := stream_mod_family (@eq A).

(** Similarity for this OFE is equal to stream bisimilarity *)

Lemma stream_mod_similarity : forall A (E:binary A),
  bisimilar_mod E = similar (stream_mod_family E).
Proof using.
  intros. apply prop_ext_2. intros s1 s2.
  unfold similar. simpl. split.
  intros. apply~ bisimilar_mod_to_upto.
  intros. apply~ bisimilar_mod_take.
Qed.

Hint Resolve stream_mod_similarity.

Lemma stream_similarity : forall A,
  @bisimilar A = similar (stream_family A).
Proof using. intros. apply stream_mod_similarity. Qed.

Hint Resolve stream_similarity.

(** Completeness of the OFE *)

Hint Unfold list_equiv.
Hint Constructors Forall2.

Lemma stream_mod_cofe : forall A {IA:Inhab A} (E:binary A),
  equiv E -> COFE (stream_mod_family E).
Proof using.
  introv IA Equiv. apply nat_cofe. typeclass.
  intros. apply~ bisimilar_mod_upto_equiv.
  introv H. exists (diagonal (fun i => u (S i)) 0).
  induction i; unfolds.
    simple~.
    apply~ bisimilar_mod_upto_succ. apply~ (trans_sym_1 (u i)).
    rewrite stream_diagonal_nth. math_rewrite~ (i + 0 = i).
Qed.

Lemma stream_cofe : forall A {IA:Inhab A}, COFE (stream_family A).
Proof using. intros. apply~ stream_mod_cofe. Qed.

Hint Resolve @stream_cofe.

(* ********************************************************************** *)
(** * Constant stream -- basic corecursive value *)

Definition Const1 const1 := (1%nat) ::: const1.

Definition const1 := FixValMod (@bisimilar nat) Const1.

Lemma const1_fix : const1 === Const1 const1.
Proof using.
  applys~ (FixValMod_fix (stream_family nat)). typeclass.
  intros i s1 s2 H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Constant stream -- basic corecursion *)

Definition Const const (n:nat) := n ::: const n.

Definition const := FixFunMod (@bisimilar nat) Const.

Lemma const_fix : forall n, const n === Const const n.
Proof using.
  intros.
  applys (FixFunMod_corec (stream_family nat) (@pred_true nat)); autos*.
  apply stream_cofe.
  clear n. intros i n s1 s2 _ H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Polymorphic Constant stream -- basic corecursion with polymorphism *)

Definition PConst A pconst (n:A) := n ::: pconst n.

Definition pconst `{IA:Inhab A} := FixFunMod (@bisimilar A) (@PConst A).

Lemma pconst_fix : forall A {IA:Inhab A} (n:A),
  pconst n === PConst pconst n.
Proof using.
  intros.
  applys* (FixFunMod_corec (stream_family A) (@pred_true A)).
  clears n. intros i n s1 s2 _ H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

Lemma pconst_spec : forall A {IA:Inhab A} (x:A),
  LibStream.const x === pconst x.
Proof using.
  intros.
  apply bisimilar_mod_take. induction i. simple~.
  apply* sym_elim. apply* trans_sym_2.
   apply bisimilar_mod_to_upto. apply pconst_fix.
   simpl. constructor~.
Qed.

(* ********************************************************************** *)
(** * Mutually-defined stream -- basic corecursion *)
(* u = 1::2::3::1::2::3::1::2::3::1::2::3::1::2::3::...*)

Definition MU (mu mv : stream nat) := (1%nat) ::: mv.
Definition MV (mu mv : stream nat) := (2%nat) ::: ((3%nat) ::: mu).

Definition muv := FixValModMut2 (@bisimilar nat) (@bisimilar nat) MU MV.
Definition mu := fst muv.
Definition mv := snd muv.

Lemma uv_fix : mu === MU mu mv /\ mv === MV mu mv.
Proof using.
  applys (FixValModMut2_fix
    (prod_family (stream_family nat) (stream_family nat))).
  apply tuple2_from_proj.
  unfold bisimilar. rewrite stream_mod_similarity. apply prod_similar.
  apply prod_cofe; typeclass.
  intros i u1 v1 u2 v2 H. simpls. destruct~ i. split.
    unfolds. simpl. constructor~. apply* H.
    unfolds. simpl. constructor~. destruct i. simple~. simpl.
     constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Stream of natural numbers *)

Definition Nats nats (n:nat) := n ::: nats (S n).

Definition nats := FixFunMod (@bisimilar nat) Nats.

Lemma nats_fix : forall (n:nat),
  nats n === Nats nats n.
Proof using.
  intros.
  applys (FixFunMod_corec (stream_family nat) (@pred_true nat)); autos*.
  apply stream_cofe.
  clears n. intros i n s1 s2 _ H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Filter on streams *)

Definition dist_to_next A (P:A->Prop) (s:stream A) :=
  epsilon (first_st_at P s).

Lemma eventually_to_dist : forall A (P:A->Prop) s,
  eventually P s -> exists n, first_st_at P s n.
Proof using.
  introv H. induction H. exists 0. simple~.
  destruct (classic (P x)).
    exists 0. simple~.
    destruct IHeventually as [n Pn]. exists (S n). simple~.
Qed.

Lemma eventually_dist_cons : forall A (P:A->Prop) s x,
  eventually P s -> ~ P x ->
  dist_to_next P s < dist_to_next P (x:::s).
Proof using.
  introv H Nx. unfold dist_to_next.
  spec_epsilon as n Pn. apply~ eventually_to_dist.
  spec_epsilon as n' Pn'. apply~ eventually_to_dist.
   apply~ eventually_tail.
  clearbody n n'. destruct n'; simpl in Pn'; tryfalse.
  rewrite* (@first_st_at_unique n n' A P s).
Qed.

Section MyFilters.
Context (A:Type) {IA:Inhab A}.
Variable (P:A->Prop).

Definition Filter filter s :=
  let '(x:::s') := s in
  let s'' := filter s' in
  If P x then x:::s'' else s''.

Definition filter := FixFunMod (@bisimilar A) Filter.

Lemma filter_fix : forall s,
  infinitely_often P s ->
  filter s === Filter filter s.
Proof using.
  applys~ (FixFunMod_mixed_partial
    (stream_family A)
    (measure (dist_to_next P))
    (infinitely_often P)
    (@bisimilar A)).
  intros i s f1 f2 Ps H. simpls.
  destruct s. simpl. unfolds. destruct i. simple~.
   inverts Ps as Ps' Ev. case_if as C.
     simpl. constructor~. apply~ H. left*.
     inverts Ev as Ev.
       false.
       apply~ H. right. split~. apply~ eventually_dist_cons.
Qed.

End MyFilters.

(* ********************************************************************** *)
(** * The log function -- basic recursion *)

(** Definition of the functional *)

Definition Log log n :=
 If n <= 1 then 0 else 1 + log (div2 n).

(** Construction of the fixed point *)

Definition log := FixFun Log.

Lemma fix_log : forall n,
  log n = Log log n.
Proof using.
  applys~ (FixFun_fix (@lt nat _)).
  introv H. unfolds. case_if~.
  fequals. apply H. apply* div2_lt.
Qed.

(** Example of unfolding of the body *)

Lemma log_double : forall n, n > 0 ->
  log(2*n) = 1 + log n.
Proof using.
  introv Pos. rewrite fix_log. unfold Log.
  case_if*. fequals. rewrite~ div2_double.
Qed.

(** Example of reasoning by induction *)

Lemma log_grows : forall n m,
  m <= n -> log m <= log n.
Proof using.
  induction n using peano_induction. introv Le.
  do 2 rewrite fix_log. unfolds Log.
  (do 2 case_if); autos*.
  rew_nat. apply H. apply* div2_lt. apply~ div2_grows.
Qed.

(*
Extraction Language Ocaml.
Extraction Inline Log.
Set Extraction Optimize.
Extraction log.
*)

(* ********************************************************************** *)
(** * Loop on odd numbers -- partial function *)

(** The function [F] defined in this module returns [1]
    on any even number and "loops" on any odd number.
    It does not actually loop, since when a recursive
    call is not made on a smaller argument, the recursion
    is stopped and a dummy value is returned. *)

Require Import Even.

Definition Only_even only_even n :=
  If n = 0 then 1 else
  If n = 1 then 1 + only_even 1 else
  only_even (n - 2).

Definition only_even := FixFun Only_even.

Lemma only_even_fix : forall n, even n ->
  only_even n = Only_even only_even n.
Proof using.
  applys~ (FixFun_fix_partial (@lt nat _)).
  intros f1 f2 n Pn IH. unfolds. case_if~. case_if as C.
  subst. inverts Pn as Pn'. inverts Pn'.
  apply* IH. inverts Pn as Pn'; tryfalse. inverts Pn'. simpl. rew_nat~.
Qed.

(* ********************************************************************** *)
(** * GCD function (binary currified function, by measure) *)

Definition Gcd gcd x y :=
  If x = 0 then y else
  If y = 0 then x else
  If x <= y then gcd x (y-x) else gcd (x-y) y.

(** The measure is the sum of the arguments *)

Definition gcd := FixFun2 Gcd.

Lemma fix_gcd : forall x y,
  gcd x y = Gcd gcd x y.
Proof using.
  applys~ (FixFun2_fix (measure2 plus)).
  unfold measure2. introv IH. unfolds.
  case_if~. case_if~. case_if. apply* IH. apply* IH.
Qed.

(* ********************************************************************** *)
(** * Zero function (nested recursion) *)

(** [zero n] is a function that always returns [0]. *)

Definition Zero zero n :=
  If n = 0 then 0 else zero (zero (n-1)).

Definition zero := FixFun Zero.

Implicit Arguments FixFun_fix_partial_inv [A B F f].

Lemma zero_fix : forall x, zero x = Zero zero x
              /\ forall x, zero x = 0.
Proof using.
  forwards~ [H1 H2]: (FixFun_fix_partial_inv lt pred_true (fun (x y : nat) => y = 0) _ (F:=Zero)).
  introv _ H. unfold Zero. case_if~.
  forwards* [H1 H2]: (H (x-1)). rewrite <- H1. rewrite H2. apply* H.
Qed.

(* ********************************************************************** *)
(** * Ackerman's function (nested non-primitive recursion, two arguments) *)

Ltac emaths := eauto with maths.

Definition Ack ack m n :=
  If m = 0 then n+1 else
  If n = 0 then ack (m-1) 1 else
  ack (m-1) (ack m (n-1)).

Definition ack := FixFun2 Ack.

Lemma fix_ack : forall m n,
  ack m n = Ack ack m n.
Proof using.
  applys~ (FixFun2_fix (lexico2 (@lt nat _) (@lt nat _))).
  introv IH. unfolds. case_if~. case_if~.
  apply IH. emaths.
  rewrite IH. fequals~. emaths. emaths.
Qed.

(* ********************************************************************** *)
(** * McCarthy's 91 function (nested recursion) *)

(** [McCarthy n] returns [n-10] if [n > 100] and returns
    [91] otherwise. It is defined using nested recursion. *)

Definition McCarthy mcCarthy n :=
  If n > 100
    then n - 10
    else mcCarthy (mcCarthy (n + 11)).

Definition mcCarthy := FixFun McCarthy.

Definition McCarthy_post n r :=
  If n > 100 then r = n - 10 else r = 91.

Lemma McCarthy_fix_post :
     (forall n, mcCarthy n = McCarthy mcCarthy n)
  /\ (forall n, McCarthy_post n (mcCarthy n)).
Proof using.
  sets meas: (fun n => If n > 100 then 0 else 101 - n).
  applys~ (FixFun_fix_inv (measure meas)). introv IH.
  unfold McCarthy. unfold McCarthy_post. case_if~.
  forwards [K1 K2]: IH (x+11). unfold measure, meas. case_if; case_if*.
  rewrite <- K1 in *. sets y: (f1(x+11)). unfolds in K2.
  forwards [L1 L2]: IH y. unfold measure, meas. case_if; case_if*. case_if*.
  rewrite <- L1 in *. sets z: (f1 y). unfolds in L2. split~.
  case_if*. case_if*.
Qed.

(** Corrolaries *)

Lemma McCarthy_fix : forall n,
  mcCarthy n = McCarthy mcCarthy n.
Proof using. apply (proj1 (McCarthy_fix_post)). Qed.

Lemma McCarthy_spec_gt100 : forall n,
  n > 100 -> mcCarthy n = n - 10.
Proof using.
  introv Lt. lets H: (proj2 McCarthy_fix_post n). unfolds in H. case_if*.
Qed.

Lemma McCarthy_spec_le100 : forall n,
  n <= 100 -> mcCarthy n = 91.
Proof using.
  introv Le. lets H: (proj2 McCarthy_fix_post n). unfolds in H. case_if*.
Qed.

(* ********************************************************************** *)
(** * Integer division (binary function) *)

Require Import Arith. (* todo : needed?*)

(** [div n m] returns a pair [(q,r)] such that
    [n = q*m + r] with [r < m]. Its definition involves
    non-structural recursion. *)

Definition Div div n m :=
  If n < m then (0,n)
  else let (q,r) := div (n-m) m : nat*nat in
       (q+1,r).

Definition div := FixFun2 Div.

Lemma fix_div : forall n m, m <> 0 ->
  div n m = Div div n m.
Proof using.
  applys~ (FixFun2_fix_partial (measure (@fst nat nat))).
  introv Posm IH. unfold Div. case_if~.
  rewrite~ IH. unfolds. simpl. math.
Qed.

(* ********************************************************************** *)
(** * A function on trees -- higher-order recursion *)

Definition Mem A (x:A) l := Exists (=x) l. (* todo: move *)

(** The congruence rule for [map] on lists *)

Lemma map_congr : forall A B (f1 f2 : A->B) l,
  (forall x, Mem x l -> f1 x = f2 x) ->
  LibList.map f1 l = LibList.map f2 l.
Proof using. Hint Constructors Exists. Hint Unfold Mem.
  introv H. induction l. auto. rew_map. fequals~.
Qed.

(** Definition of trees *)

Inductive tree : Type :=
  | leaf : nat -> tree
  | node : list tree -> tree.

Instance tree_inhab : Inhab tree.
Proof using. intros. apply (prove_Inhab (leaf 0)). Qed.

(** An induction principle for trees *)

Section Tree_induct.
Variables
(P : tree -> Prop)
(Q : list tree -> Prop)
(P1 : forall n, P (leaf n))
(P2 : forall l, Q l -> P (node l))
(Q1 : Q nil)
(Q2 : forall t l, P t -> Q l -> Q (t::l)).

Fixpoint tree_induct_gen (T : tree) : P T :=
  match T as x return P x with
  | leaf n => P1 n
  | node l => P2
      ((fix tree_list_induct (l : list tree) : Q l :=
      match l as x return Q x with
      | nil   => Q1
      | t::l' => Q2 (tree_induct_gen t) (tree_list_induct l')
      end) l)
  end.

End Tree_induct.

Lemma tree_induct : forall (P : tree -> Prop),
  (forall n : nat, P (leaf n)) ->
  (forall l : list tree,
    (forall t, Mem t l -> P t) -> P (node l)) ->
  forall T : tree, P T.
Proof using.
  introv Hl Hn. eapply tree_induct_gen with (Q := fun l =>
    forall t, Mem t l -> P t); intros.
  auto. auto. inversions H. inversions~ H1.
Qed.

(** Definition of immediate subtrees *)

Inductive subtree : binary tree :=
  | subtree_intro : forall t l,
     Mem t l -> subtree t (node l).

Hint Constructors subtree.

Lemma subtree_wf : wf subtree.
Proof using.
  intros t. induction t using tree_induct;
  constructor; introv K; inversions~ K.
Qed.

(** Definition of the [treeincr] function *)

Definition Treeincr treeincr t :=
  match t with
  | leaf n => leaf (S n)
  | node l => node (LibList.map treeincr l)
  end.

Definition treeincr := FixFun Treeincr.

Lemma treeincr_fix : forall t,
  treeincr t = Treeincr treeincr t.
Proof using.
  applys (FixFun_fix subtree).
  reflexivity. apply subtree_wf.
  introv H. unfold Treeincr. destruct x.
    auto.
    fequals. apply~ map_congr.
Qed.

(* ********************************************************************** *)
(** * An example with cofinite trees *)

Require Import LibNat.

(** Definition of [itree], trees with possibly-infinite branches *)

CoInductive itree : Type :=
  | itree_leaf : nat -> itree
  | itree_node : itree -> itree -> itree.

(** The type [itree] is inhabited *)

Instance itree_inhab : Inhab itree.
Proof using. intros. apply (prove_Inhab (itree_leaf 0)). Qed.

(** Similarity up to level [i] between two trees *)

Fixpoint itree_similar_upto (i:nat) (m1 m2: itree) :=
  match i with
  | O => True
  | S i' => match m1,m2 with
     | itree_leaf n1, itree_leaf n2 => n1 = n2
     | itree_node t11 t12, itree_node t21 t22 =>
           itree_similar_upto i' t11 t21
        /\ itree_similar_upto i' t12 t22
     | _, _ => False
     end
  end.

(** Similarity upto is an equivalence *)

Lemma itree_similar_upto_equiv :
  forall i, equiv (itree_similar_upto i).
Proof using.
  constructor; unfolds.
  induction i; intros; simple~. destruct~ x.
  induction i; intros; simple~. destruct x; destruct y; simpls*.
  induction i; intros; simple~. destruct x; destruct y; destruct z; simpls*.
Qed.

Hint Resolve itree_similar_upto_equiv.
Hint Extern 1 (itree_similar_upto ?i _ _) =>
  apply (@equiv_refl _ _ (itree_similar_upto_equiv i)).

(** Construction of the COFE for the family [itree] *)

Definition itree_family := Build_family lt itree_similar_upto.

Definition itree_left t :=
  match t with
  | itree_leaf n => arbitrary
  | itree_node t1 t2 => t1
  end.

Definition itree_right t :=
  match t with
  | itree_leaf n => arbitrary
  | itree_node t1 t2 => t2
  end.

Definition shifts A (u:nat->A) :=
  fun n => u (S n).

CoFixpoint itree_diagonal (u:nat->itree) : itree :=
  match u 0 with
  | itree_leaf n => itree_leaf n
  | itree_node t1 t2 =>
      itree_node (itree_diagonal (itree_left \o shifts u))
                 (itree_diagonal (itree_right \o shifts u))
  end.

Lemma itree_family_COFE : COFE itree_family.
Proof using.
  apply~ nat_cofe'. typeclass.
  introv H. exists (itree_diagonal (shifts u)).
  cuts M: (forall k i u, i <= k ->
    (forall i j : nat, i < j -> itree_similar_upto (S i) (u i) (u j)) ->
      itree_similar_upto (S i) (u k) (itree_diagonal u)).
    intros i. destruct i. simple~.
    sets u': (shifts u). change (u (S i)) with (u' i).
    apply M. math.
      intros i' j' Ri'j'. unfold u', shifts. apply H. math.
  clears u. induction k using peano_induction; introv Lik Coh.
  tests: (k = 0). math_rewrite (i = 0). simpl. destruct~ (u 0).
  unfolds. fold itree_similar_upto.
  forwards S0: (>> Coh 0 k __). math. simpl in S0.
  unfold itree_diagonal; fold itree_diagonal.
  sets_eq <- u0: (u 0). sets_eq <- uk: (u k).
  destruct u0 as [|t01 t02]; destruct uk as [|tk1 tk2]; auto_false.
  split. (* todo: find a way to factorize both sides *)
  (* left subtree *)
  destruct i. simple~.
  sets u': (itree_left \o shifts u).
  asserts_rewrite (tk1 = u' (k-1)).
    unfold u'. unfold compose, shifts, itree_left.
    math_rewrite (S (k - 1) = k). rewrite~ EQuk.
  apply H; try math. intros i' j' Li'j'.
  unfold u'. unfold compose, shifts, itree_left.
  sets_eq i'': (S i'). sets_eq j'': (S j').
  forwards Ssi: (Coh i'' j''). math.
  simpl in Ssi. destruct (u i''); destruct (u j''); auto_false*.
  (* right subtree *)
  destruct i. simple~.
  sets u': (itree_right \o shifts u).
  asserts_rewrite (tk2 = u' (k-1)).
    unfold u'. unfold compose, shifts. unfold itree_right.
    math_rewrite (S (k - 1) = k). rewrite~ EQuk.
  apply H; try math. intros i' j' Li'j'.
  unfold u'. unfold compose, shifts, itree_left.
  sets_eq i'': (S i'). sets_eq j'': (S j').
  forwards Ssi: (Coh i'' j''). math.
  simpl in Ssi. destruct (u i''); destruct (u j''); auto_false*.
Qed.

(** Two equivalent definitions of similarity between two trees,
    one using an coinductive predicate and another constructed
    as the intersection of the "similarity-upto" relations. *)

CoInductive itree_similar : binary itree :=
  | itree_similar_leaf : forall n,
      itree_similar (itree_leaf n) (itree_leaf n)
  | itree_similar_node : forall t11 t12 t21 t22 : itree,
      itree_similar t11 t21 ->
      itree_similar t12 t22 ->
      itree_similar (itree_node t11 t12) (itree_node t21 t22).

Hint Constructors itree_similar.

Lemma itree_similar_eq : itree_similar = similar itree_family.
Proof using.
  apply prop_ext_2. intros t1 t2. iff H.
  intros i. hnf. gen t1 t2. induction i; simpl; introv H.
   auto. inversions~ H.
  hnf in H. gen t1 t2. cofix IH.
   intros t1 t2. destruct t1; destruct t2;
    introv H; lets H1: (H 1); simpl in H1; inversions H1; constructor.
      apply IH. intros i. lets_simpl HSi: (H (S i)). autos*.
      apply IH. intros i. lets_simpl HSi: (H (S i)). autos*.
Qed.

(** A first corecursive operation: the "product" of two trees.
   Note that it always add a head element. *)

Definition Product product m1 m2 :=
  match m1,m2 with
  | itree_node t11 t12, itree_node t21 t22 =>
     itree_node (product t11 t22) (product t12 t21)
  | _, _ => itree_node m1 m2
  end.

Definition product := FixFun2Mod itree_similar Product.

(** We prove that [product] satisfies the fixed point equation *)

Lemma product_fixpoint : forall m1 m2,
  itree_similar (product m1 m2) (Product product m1 m2).
Proof using.
  apply (FixFun2Mod_corec itree_family).
  reflexivity. apply itree_similar_eq. apply itree_family_COFE.
  simpl. introv H. destruct i. simple~. unfold Product.
  destruct x1; destruct x2; simpl; auto with maths.
Qed.

(** And we show that it is productive wrt its arguments *)

Lemma product_incr_similarity : forall i m1 m1' m2 m2',
   itree_similar_upto i m1 m1' ->
   itree_similar_upto i m2 m2' ->
   itree_similar_upto (S i) (product m1 m2) (product m1' m2').
Proof using.
  induction i using peano_induction.
  change (itree_similar_upto) with (family_sim itree_family).
  introv K1 K2. (* todo: setoid rewrite *)
  eapply cofe_similar_modulo. apply itree_family_COFE.
    rewrite <- itree_similar_eq. apply product_fixpoint.
    rewrite <- itree_similar_eq. apply product_fixpoint.
  simpl in K1, K2 |- *.
  destruct m1; destruct m2; simpl; auto.
  destruct m1'; destruct m2'; simple~. destruct~ i. inversions K1.
  destruct m1'; destruct m2'; simple~. destruct~ i. inversions K1.
  destruct m1'; destruct m2'; simple~. destruct~ i. inversions K2.
  destruct m1'; destruct m2'; simple~; destruct~ i.
    inversions K1. inversions K1. inversions K2.
    simpl in K1, K2. destruct K1. destruct K2. auto with maths.
Qed.

(** A second corecursive function, which is not guarded:
    it is productive only because the function [product]
    is productive. *)

Definition Makeitree makeitree m :=
  match m with
  | itree_node t1 t2 => product (makeitree t1) (makeitree t2)
  | itree_leaf n => itree_leaf (S n)
  end.

Definition makeitree := FixFunMod itree_similar Makeitree.

(** Still, we can establish the fixed point equation for our function *)

Lemma makeitree_fixpoint : forall m,
  itree_similar (makeitree m) (Makeitree makeitree m).
Proof using.
  apply (FixFunMod_corec_total itree_family).
  reflexivity. apply itree_similar_eq. apply itree_family_COFE.
  introv H. unfold Makeitree. simpl. destruct x.
  auto.
  destruct i. auto. apply product_incr_similarity.
    apply H; simpl; auto with maths.
    apply H; simpl; auto with maths.
Qed.

(* ********************************************************************** *)
(** * Verification of a recursive parser in CPS form *)

Ltac auto_tilde ::= auto with wf.

(* ---------------------------------------------------------------------- *)
(** ** The assertion construction *)

(** The expression [ ##P## v ] is equivalent to [v],
    with the assertion that [P] holds. If [P] does not hold,
    then the expression is undefined. *)

Definition asserts (P:Prop) (A:Type) `{Inhab A} (v:A) :=
  If P then v else arbitrary.

Notation "'##' P '##' v" := (asserts P v) (at level 69).

Tactic Notation "case_asserts" :=
  unfold asserts; case_if.
Tactic Notation "case_asserts" "~" :=
  case_asserts; auto_tilde.

(* ---------------------------------------------------------------------- *)
(** ** Definition of the data types *)

Inductive regexp : Type :=
  | regexp_null : regexp
  | regexp_empty : regexp
  | regexp_char : nat -> regexp
  | regexp_alt : regexp -> regexp -> regexp
  | regexp_seq : regexp -> regexp -> regexp
  | regexp_star : regexp -> regexp.

Definition text := list nat.

Definition arg_type := (regexp * text * (text -> bool))%type.

(* ---------------------------------------------------------------------- *)
(** ** Definition of the regexp parser as an optimal fixed point *)

Definition Parse (parse : arg_type -> bool) (p : arg_type) : bool :=
  let '(r,s,k) := p in
  match r with
  | regexp_null => false
  | regexp_empty => k s
  | regexp_char c =>
     match s with
     | nil => false
     | c'::s' => If c = c' then k s' else false
     end
  | regexp_alt r1 r2 => parse (r1,s,k) || parse (r2,s,k)
  | regexp_seq r1 r2 => parse (r1,s,(fun s' => parse (r2,s',k)))
  | regexp_star r1 => k s || parse (r1,s,(fun s' => parse (r,s',k)))
  end.

Definition parse := FixFun Parse.

(** At this point, the function [parse] exists and can thus
    be mentioned in other definitions. *)

(* ---------------------------------------------------------------------- *)
(** ** Domain of the parser *)

(** [productive r] is the same as [not (nullable r)];
    it asserts that [r] consumes at least one character *)

Fixpoint productive (r:regexp) : Prop :=
  match r with
  | regexp_null => True
  | regexp_empty => False
  | regexp_char c => True
  | regexp_alt r1 r2 => productive r1 /\ productive r2
  | regexp_seq r1 r2 => productive r1 \/ productive r2
  | regexp_star r1 => False
  end.

(** [normal r] ensures that expressions under a star are productive *)

Fixpoint normal (r:regexp) : Prop :=
  match r with
  | regexp_null => True
  | regexp_empty => True
  | regexp_char c => True
  | regexp_alt r1 r2 => normal r1 /\ normal r2
  | regexp_seq r1 r2 => normal r1 /\ normal r2
  | regexp_star r1 => productive r1 /\ normal r1
  end.

Hint Unfold productive normal.

(** Definition of the domain *)

Definition parse_dom (p:arg_type) :=
  let '(r,s,k) := p in normal r.

(* ---------------------------------------------------------------------- *)
(** ** Termination relation for the parser *)

(** Sub-expression order for [regexp] *)

Inductive regexp_sub : binary regexp :=
  | regexp_sub_seq_1 : forall r1 r2,
      regexp_sub r1 (regexp_seq r1 r2)
  | regexp_sub_seq_2 : forall r1 r2,
      regexp_sub r2 (regexp_seq r1 r2)
  | regexp_sub_alt_1 : forall r1 r2,
      regexp_sub r1 (regexp_alt r1 r2)
  | regexp_sub_alt_2 : forall r1 r2,
      regexp_sub r2 (regexp_alt r1 r2)
  | regexp_sub_star : forall r1,
      regexp_sub r1 (regexp_star r1).

Hint Constructors regexp_sub.

Lemma regexp_sub_wf : wf regexp_sub.
Proof using. intros r. induction r; constructor; intros r' le; inverts~ le. Qed.

Hint Resolve regexp_sub_wf : wf.

(** [text_sub] is the transitive closure of the sub-list order *)

Definition text_sub : binary text := tclosure (@list_sub _).

Lemma text_sub_wf : wf text_sub.
Proof using. lets: tclosure_wf. unfold text_sub. prove_wf. Qed.

Hint Resolve text_sub_wf : wf.

Lemma text_sub_once : forall s c,
  text_sub s (c::s).
Proof using. intros. apply~ tclosure_once. Qed.

Lemma text_sub_trans : trans text_sub.
Proof using. apply tclosure_trans. Qed.

Hint Resolve text_sub_trans text_sub_once.

Lemma text_sub_app : forall s s1 s2,
  s = s1 ++ s2 -> large text_sub s2 s.
Proof using.
  intros. subst. induction s1; rew_list. auto.
  inverts IHs1.
    left. applys~ (@trans_elim text) (s1++s2).
    rewrite <- H. left. apply text_sub_once.
Qed.

(** [parse_sub] is the termination relation used for [parse];
    It is the lexicographical order [(s,r)] *)

Definition parse_sub : binary (regexp * text) :=
  lexico2 regexp_sub text_sub.

Lemma parse_sub_wf : wf parse_sub.
Proof using. prove_wf. Qed.

Hint Unfold parse_sub.
Hint Resolve parse_sub_wf : wf.

(** [parse_arg_sub] is similar to [parse_sub] except that
    it takes triples of the form [(r,s,k)] as arguments *)

Definition parse_arg_sub : binary arg_type :=
  fun p1 p2 => let '(r1,s1,k1) := p1 in let '(r2,s2,k2) := p2 in
               parse_sub (r1,s1) (r2,s2).

Lemma parse_arg_sub_wf : wf parse_arg_sub.
Proof using.
  intros [[r s] k].
  sets_eq p: (r,s). gen k r s. induction_wf IH: parse_sub_wf p.
  intros. subst p. constructor. intros [[r2 s2] k2] S. applys~ IH S.
Qed.

Hint Unfold parse_arg_sub.
Hint Resolve parse_arg_sub_wf : wf.

(* ---------------------------------------------------------------------- *)
(** ** Auxiliary recursive function *)

(** [parse'] is a function equivalen to [parse] except that it includes
    some assertions in order to make termination more obvious.
    Those assertions appear in-between [##] symbols. *)

Definition Parse' (parse : arg_type -> bool) (p : arg_type) : bool :=
  let '(r,s,k) := p in
  match r with
  | regexp_null => false
  | regexp_empty => k s
  | regexp_char c =>
     match s with
     | nil => false
     | c'::s' => If c = c' then k s' else false
     end
  | regexp_alt r1 r2 => parse (r1,s,k) || parse (r2,s,k)
  | regexp_seq r1 r2 => parse (r1,s,(fun s' => parse (r2,s',k)))
  | regexp_star r1 => k s || parse (r1,s,(fun s' => ##text_sub s' s## parse (r,s',k)))
  end.

Definition parse' := FixFun Parse'.

(** Remark: I will show further on how to factorize the definitions
    of [Parse] and [Parse'] so as to avoid the duplication of code. *)

(* ---------------------------------------------------------------------- *)
(** ** Proof of termination of the auxiliary function *)

(** Thanks to the assertions it contains, [parse'] is a total function
    that satisfies a contraction condition, and thus satisfies the
    fixed point equation for [Parse']. *)

Lemma parse'_fix : forall p,
  parse' p = Parse' parse' p.
Proof using.
  applys~ (FixFun_fix parse_arg_sub).
  intros f1 f2 [[r s] k] H. unfolds. destruct r; auto.
  fequal; auto 7.
  rewrite H; [|auto 7]. fequals_rec.
   apply func_ext_1. intros s'. apply~ H.
  fequal. rewrite H; [|auto 7]. fequals_rec.
   apply func_ext_1. intros s'. case_asserts; auto 7.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of the auxiliary function *)

(** [select_sub r] is equivalent to the strict sub-text relation
    when [r] is [productive], and it is otherwise equivalent to
    the large sub-text relation. *)

Definition select_sub (r:regexp) : binary text :=
  If productive r then text_sub else large text_sub.

(** The key result consists in showing that, when [r] is is normal form,
    the computation of [parse' (r,s,k)] is not affected by the evaluations
    of the assertions. *)

Lemma parse'_cont : forall r s k1 k2, normal r ->
  (forall s', select_sub r s' s -> k1 s' = k2 s') ->
  parse' (r,s,k1) = parse' (r,s,k2).
Proof using.
  intros r s. sets_eq p: (r,s). gen r s. induction_wf IH: parse_sub_wf p.
  introv P N E. subst p. do 2 rewrite parse'_fix. unfolds. destruct r; simpl in N.
  auto.
  apply E. hnf. rewrite~ If_r.
  destruct s as [|c' s']. auto. case_if~. apply E. unfolds. rewrite~ If_l.
  inverts N. asserts M: (forall r s', (r = r1 \/ r = r2) -> select_sub r s' s ->
                select_sub (regexp_alt r1 r2) s' s).
    introv C S. hnf in S |- *. simpl. case_if.
      destruct H1. case_if. auto. inverts C; tryfalse.
      case_if~.
   fequals.
     applys~ IH. auto 7. eauto 8.
     applys~ IH. auto 7. eauto 8.
  inverts N. applys~ IH. intros s' S'. applys~ IH.
    intros s'' S''. apply E. hnf in S',S''|-*. simpl.
    tests: (productive r1); tests: (productive r2).
      rewrite~ If_l. applys* (@trans_elim text) s'.
      rewrite~ If_l. applys* (@large_strict_trans text) s'.
      rewrite~ If_l. applys* (@strict_large_trans text) s'.
      rewrite If_r; [|rew_logic';auto]. applys~ (@large_trans text) s'.
  fequals.
    apply E. unfold select_sub. simpl. rewrite~ If_r.
  inverts N. applys~ IH. auto 7. intros s' S'. case_asserts~.
   applys~ IH. hnf in S'. rewrite~ If_l in S'.
   intros s'' S''. apply E. hnf in S'' |- *. simpls. case_if; tryfalse.
   inverts S''. left. applys* trans_elim. auto.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Proof of the fixed point equation for [parse] *)

(** The first step consists in proving that [parse']
    is a fixed point for [Parse] on the domain. This is done
    by showing that the assertions in the continuations are
    irrelevant, using the lemma [parse'_cont]. Yet, the statement
    [ Lemma parse'_fix_Parse_simple : forall p, parse_dom p ->
      parse' p = Parse parse' p. ]
    is not strong enough. Indeed, we need to generalize this
    into a form where we replace [parse'] with an arbitrary
    other total function that behave like [parse'] on the domain. *)

Lemma parse'_fix_Parse :
  fixed_point (pfunc_equal parse_dom) Parse parse'.
Proof using.
  intros f Hf [[r s] k] N. asserts E: (pfunc_equal parse_dom f parse').
    unfolds. apply~ equiv_sym. clear Hf.
  rewrite~ E. rewrite parse'_fix.
  unfold Parse, Parse'. destruct r; auto; simpl in N.
  inverts N. fequals; rewrite~ E.
  inverts N. rewrite~ E. apply~ parse'_cont. intros s' S'. rewrite~ E.
  inverts N. fequals. rewrite~ E. apply~ parse'_cont. intros s' S'.
   hnf in S'. rewrite~ If_l in S'. case_asserts; auto_false. rewrite~ E. simple~.
Qed.

(** The second step consists in proving that the functional [Parse]
    satisfies a contraction condition. This is almost the standard
    contraction condition, except that [f1] is specialized as [parse'].
    In this proof, we exploit the fact that [parse'] depends only
    a subdomain of its continuation. Remark: the statement is equivalent
    to [rec_contractive' eq parse_dom Parse parse_arg_sub parse']. *)

Lemma Parse_contractive_for_parse' : forall f' p, parse_dom p ->
  (forall q, parse_dom q -> parse_arg_sub q p -> parse' q = f' q) ->
  Parse parse' p = Parse f' p.
Proof using.
  introv N IH. unfold Parse. destruct p as [[r s] k].
  hnf in N. destruct r; simpl in N; auto.
  inverts N. fequals; apply~ IH.
  inverts N. erewrite parse'_cont; auto. apply~ IH.
   simpl. intros s' S'. apply~ IH.
  inverts N. fequals. erewrite parse'_cont; auto. apply IH; auto 7.
   simpl. intros s' S'. hnf in S'. rewrite~ If_l in S'. apply~ IH; hnfs~.
Qed.

(** Third and last step: we can put all the pieces together.
    Since [parse'] is a generally-consistent fixed point for [Parse]
    on the domain [parse_dom], [parse'] is extended by [parse],
    which is the optimal fixed point of [Parse]. Hence, [parse]
    and [parse'] agree on the domain [parse_dom]. It follows that
    [parse] satsifies the fixed point equation for [Parse] on the domain. *)

Lemma parse_fix : forall p, parse_dom p ->
  parse p = Parse parse p.
Proof using.
  applys~ (FixFun_fix_partial' (P:=parse_dom) (R:=parse_arg_sub) (F:=Parse) (f':=parse')).
  applys Parse_contractive_for_parse'. apply parse'_fix_Parse.
Qed.

Corollary parse_fix' : forall r s k, normal r ->
  parse (r,s,k) = Parse parse (r,s,k).
Proof using. intros. applys~ parse_fix. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Bonus: factorization of the definitions of [Parse] and [Parse'] *)

(** The idea is to define a single functional that takes as argument a
    function, which is intented to be instantiated either as [asserts]
    or as [ignore]. *)

Definition ignore (P:Prop) (A:Type) `{Inhab A} (v:A) := v.

Section Common.

Context (check : Prop -> forall A `{Inhab A}, A -> A).

Notation "'#' P '#' v" := (@check P _ _ v) (at level 69).

(** Here is the common definition to build [Parse] and [Parse']. *)

Definition Parse_common (parse : arg_type -> bool) (p : arg_type) : bool :=
  let '(r,s,k) := p in
  match r with
  | regexp_null => false
  | regexp_empty => k s
  | regexp_char c =>
     match s with
     | nil => false
     | c'::s' => If c = c' then k s' else false
     end
  | regexp_alt r1 r2 => parse (r1,s,k) || parse (r2,s,k)
  | regexp_seq r1 r2 => parse (r1,s,(fun s' => parse (r2,s',k)))
  | regexp_star r1 => k s || parse (r1,s,(fun s' => #text_sub s' s# parse (r,s',k)))
  end.

End Common.

(** Here are the alternative definitions for [Parse] and [Parse']. *)

Definition Parse_alternative := Parse_common ignore.
Definition Parse'_alternative := Parse_common asserts.

(** Finally, we can check that the alternative definitions are convertible
    with the one we had written by hand previously. *)

Lemma Parse_alternative_correct : Parse = Parse_alternative.
Proof using. reflexivity. Qed.

Lemma Parse'_alternative_correct : Parse' = Parse'_alternative.
Proof using. reflexivity. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Reasoning about [parse] *)

(** The inductively-defined proposition [sem r s] asserts that the
    string [s] matches the regular expression [r]. *)

Inductive sem : regexp -> text -> Prop :=
  | sem_empty :
      sem regexp_empty nil
  | sem_char : forall c,
      sem (regexp_char c) (c::nil)
  | sem_alt_1 : forall r1 r2 s,
      sem r1 s -> sem (regexp_alt r1 r2) s
  | sem_alt_2 : forall r1 r2 s,
      sem r2 s -> sem (regexp_alt r1 r2) s
  | sem_seq : forall r1 r2 s1 s2,
      sem r1 s1 -> sem r2 s2 -> sem (regexp_seq r1 r2) (s1 ++ s2)
  | sem_star_void : forall r1,
      sem (regexp_star r1) nil
  | sem_star_step : forall r1 s1 s2,
      sem r1 s1 ->
      sem (regexp_star r1) s2 ->
      sem (regexp_star r1) (s1 ++ s2).

Hint Constructors sem.

(** Observe that if a string [s] matches a productive regular
    expression [r], then [s] is not the empty string. *)

Lemma sem_productive : forall r s,
  sem r s -> productive r -> s <> nil.
Proof using.
  introv S. induction S; introv P; simpl in P; auto_false*.
  intros E. destruct (app_eq_nil_inv E). subst. destruct* P.
Qed.

(** The continuation [is_nil] holds only of the empty string *)

Definition is_nil (s:text) :=
  match s with nil => true | _ => false end.

(** The first result asserts that if [s] matches [r] semantically,
    then the [parse] function applied to [r] and [s] returns true. *)

Lemma sem_to_parse_ind : forall r s s' k,
  sem r s -> normal r -> k s' = true -> parse (r, s ++ s', k) = true.
Proof using.
  introv S N K. gen s' k N. induction S; intros;
   (rewrite parse_fix; [ | apply N ]); unfold Parse at 1; simpl in N;
   (try match type of N with _ /\ _ => destruct N end).
  rew_list~.
  rew_list. rewrite~ If_l.
  rewrite~ IHS.
  rewrite IHS at 1; auto. rew_bool~.
  rew_list. auto.
  rew_list. rewrite~ K.
  rew_list. rewrite~ IHS1. rew_bool~.
Qed.

Corollary sem_to_parse : forall r s,
  sem r s -> normal r -> parse (r,s,is_nil) = true.
Proof using. intros. forwards~ M: (@sem_to_parse_ind r s nil is_nil). rew_list~ in M. Qed.

(** The second result asserts the reciprocal: if the parse function
    applied to [r] and [s] returns true, then [s] matches [r] semantically. *)

Lemma parse_to_sem_ind : forall r s k,
  normal r -> parse (r,s,k) = true ->
  exists s1 s2, s = s1 ++ s2 /\ sem r s1 /\ k s2 = true.
Proof using.
  introv N P. sets_eq p: (r,s). gen r s k.
  induction_wf IH: parse_sub_wf p. intros. subst p.
  rewrite~ parse_fix in P. unfold Parse in P. destruct r;
   simpl in N; (try match type of N with _ /\ _ => destruct N end).
  false.
  exists (nil:text) s. splits~.
  destruct s; tryfalse. case_if; tryfalse.
   exists (n0::nil) s. splits~.
  case_eq (parse (r1,s,k)); intros P1.
    forwards~ (s1&s2&E&S&P'): IH P1. auto 7. exists~ s1 s2.
    rewrite P1 in P. rew_bool in P.
    forwards~ (s1&s2&E&S&P'): IH P. auto 7. exists~ s1 s2.
  forwards~ (s1&s2&E&S&P'): IH P. auto.
    forwards~ (s3&s4&E'&S'&K): IH P'. auto.
    forwards M: text_sub_app E. subst s s2. exists (s1 ++ s3) s4. rew_list~.
  case_eq (k s); intros K.
    exists (nil:text) s. splits~.
    rewrite K in P. rew_bool in P.
    forwards~ (s1&s2&E&S&P'): IH P. auto.
    forwards~ (s3&s4&E'&S'&K'): IH P'; try solve [hnfs~].
      forwards M: text_sub_app E. inverts M. auto. false.
       applys~ sem_productive S. apply* app_eq_self_inv_r.
    subst s s2. exists (s1++s3) s4. rew_list~.
Qed.

Corollary parse_to_sem : forall r s,
  normal r -> parse (r,s,is_nil) = true -> sem r s.
Proof using.
  intros. forwards~ (s1&s2&E&S&K): (@parse_to_sem_ind r s is_nil).
  subst. destruct s2; tryfalse. rew_list~ in *.
Qed.

(** We can reformulate those two results in the form of an
    equivalence between [sem] and [parse] *)

Theorem parse_iff_sem : forall r s, normal r ->
  (parse (r,s,is_nil) = true <-> sem r s).
Proof using. split. apply~ parse_to_sem. intros. apply~ sem_to_parse. Qed.

(** A similar, more general, result *)

Theorem parse_iff_sem_ind : forall r s k, normal r ->
  (parse (r,s,k) = true <-> (exists s1 s2, s = s1 ++ s2 /\ sem r s1 /\ k s2 = true)).
Proof using.
  split. intros. apply~ parse_to_sem_ind.
  intros (s1&s2&?&?&?). subst. apply~ sem_to_parse_ind.
Qed.


(** * Theorems about string-like types *)
Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms Coq.Program.Basics.
Require Import Coq.Arith.Lt.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Le.
Require Import Fiat.Parsers.StringLike.Core Fiat.Common.Le 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, !drop_drop, IHm.
      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.