(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of the Chomsky Normal
   Form for context-free grammars in Coq. Specifically, the following
   results were obtained:

   (i) context-free grammar simplification
   (i) context-free grammar Chomsky normalization and

   More information can be found in the paper "Formalization of
   the Chomsky Normal Form for Context-Free Grammars", submitted
   to SBMF 2019.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com

   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS                                      *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS - DEFINITIONS                        *)
(* --------------------------------------------------------------------- *)

Section Useless.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation nlist:= (list non_terminal).
Notation tlist:= (list terminal).

Definition useful (g: cfg _ _) (s: non_terminal + terminal): Prop:=
match s with
| inr t => True
| inl n => exists s: sentence, derives g [inl n] (map term_lift s)
end.

Definition useful_sf (g: cfg _ _)(l: _): Prop:=
forall s: _,
In s l -> useful g s.

Inductive g_use_rules (g: cfg _ _): non_terminal -> sf -> Prop :=
| Lift_use : forall left: non_terminal,
             forall right: sf,
             rules g left right ->
             useful g (inl left) ->
             useful_sf g right ->
             g_use_rules g left right.

Lemma g_use_finite:
forall g: cfg _ _,
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In (start_symbol g) ntl /\
forall left: non_terminal,
forall right: sf,
g_use_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite g) as [n [ntl [ tl H1]]].
exists n, ntl, tl.
split.
- destruct H1 as [H1 _].
  exact H1.
- intros left right H2.
  inversion H2.
  subst.
  destruct H1 as [_ H1].
  specialize (H1 left right H).
  destruct H1 as [H4 [H5 H6]].
  split.
  + exact H4.
  + split.
    * exact H5.
    * exact H6.
Qed.

Definition g_use (g: cfg _ _): cfg _ _:= {|
start_symbol:= start_symbol g;
rules:= g_use_rules g;
rules_finite:= g_use_finite g
|}.

Definition has_no_useless_symbols (g: cfg _ _): Prop:=
forall n: _, appears g (inl n) -> useful g (inl n).

Definition non_empty (g: cfg _ _): Prop:=
useful g (inl (start_symbol g)).

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS - LEMMAS AND THEOREMS                *)
(* --------------------------------------------------------------------- *)

Lemma useful_exists:
forall g: cfg _ _,
forall n:non_terminal,
useful g (inl n) ->
exists (left : non_terminal) (right : sf),
rules g left right /\ (n = left \/ In (inl n) right).
Proof.
intros g n H1.
destruct H1 as [s H2].
apply exists_rule in H2.
destruct H2 as [H2 | H2].
- exists n, (map term_lift s).
  split.
  + exact H2.
  + left.
    reflexivity.
- destruct H2 as [right [H3 H4]].
  exists n, right.
  split.
  + exact H3.
  + left.
    reflexivity.
Qed.

Lemma useful_sf_sentence:
forall l: sf,
forall g: cfg _ _,
useful_sf g l -> exists s': sentence, derives g l (map term_lift s').
Proof.
intros l g H.
induction l.
- exists [].
  simpl.
  apply derives_refl.
- replace (a :: l) with ([a]++l) in H.
  + assert (H1: forall s: non_terminal + terminal, In s l -> useful g s).
      {
      intros s H1.
      specialize (H s).
      apply H.
      apply in_or_app.
      right.
      exact H1.
      }
    specialize (IHl H1).
    assert (H2: useful g a).
      {
      apply H.
      simpl.
      left.
      reflexivity.
      }
    unfold useful in H2.
    destruct a.
    * destruct IHl as [s' H3].
      destruct H2 as [s H2].
      exists (s ++ s').
      simpl.
      {
      rewrite map_app.
      change (inl n :: l) with ([inl n] ++ l).
      apply derives_combine.
      split.
      - exact H2.
      - exact H3.
      }
    * destruct IHl as [s2 H5].
      exists ([t] ++ s2).
      rewrite map_app.
      change (inr t :: l) with ([inr t] ++ l).
      apply derives_combine.
      {
      split.
      - simpl.
        constructor.
      - exact H5.
      }
  + simpl.
    reflexivity.
Qed.

Lemma use_step:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules g left right ->
(forall s: non_terminal + terminal, In s right -> useful g s) ->
useful g (inl left).
Proof.
intros g left right H1 H2.
unfold useful.
apply derives_rule with (s1:=[]) (s2:=[]) in H1.
simpl in H1.
rewrite app_nil_r in H1.
apply useful_sf_sentence in H2.
destruct H2 as [s' H3].
exists s'.
apply derives_trans with (s2:=right).
- exact H1.
- exact H3.
Qed.

Lemma useful_g_g_use:
forall g: cfg _ _,
forall n: non_terminal,
useful g (inl n) -> useful (g_use g) (inl n).
Proof.
intros g n H.
unfold useful in H.
destruct H as [x H].
unfold useful.
exists x.
apply derives_sflist in H.
apply derives_sflist.
destruct H as [l [H2 [H3 H4]]].
exists l.
split.
- assert (H5: length l >= 2 \/ length l < 2).
    {
    omega.
    }
  destruct H5 as [H5 | H5].
  + assert (H6:= H5).
    apply sflist_rules with (g:=g) in H5.
    destruct H5 as [H5 _].
    specialize (H5 H2).
    apply sflist_rules.
    * exact H6.
    * intros i H7.
      specialize (H5 i H7).
      destruct H5 as [left [right [s0 [s' [H10 [H11 H12]]]]]].
      exists left, right, s0, s'.
      {
      split.
      - exact H10.
      - split.
        + exact H11.
        + simpl.
          apply Lift_use.
          * exact H12.
          * unfold useful.
            assert (H20: derives g (s0 ++ inl left :: s') (map term_lift x)).
              {
              apply derives_sflist.
              rewrite <- (firstn_skipn i l) in H2.
              apply sflist_app_l in H2.
              exists (skipn i l).
              split.
              - exact H2.
              - split.
                + rewrite hd_skip.
                  exact H10.
                + rewrite last_skip.
                  * exact H4.
                  * omega.
              }
            assert (H21: exists s'': sentence, derives g [inl left] (map term_lift s'')).
              {
              apply derives_split in H20.
              destruct H20 as [s1' [s2' [H21 [_ H22]]]].
              replace (inl left :: s') with ([inl left] ++ s') in H22.
              - apply derives_split in H22.
                destruct H22 as [s1'0 [s2'0 [H31 [H32 _]]]].
                symmetry in H21.
                apply map_expand in H21.
                destruct H21 as [s1'' [s2'' [H40 [H41 H42]]]].
                rewrite <- H42 in H31.
                symmetry in H31.
                apply map_expand in H31.
                destruct H31 as [s1''' [s2''' [H50 [H51 H52]]]].
                rewrite <- H51 in H32.
                exists s1'''.
                exact H32.
              - simpl.
                reflexivity.
              }
            exact H21.
          * intros s1 H8.
            {
            destruct s1.
            - assert (H30: derives g (s0 ++ right ++ s') (map term_lift x)).
                {
                apply derives_sflist.
                rewrite <- (firstn_skipn (S i) l) in H2.
                apply sflist_app_l in H2.
                exists (skipn (S i) l).
                split.
                - exact H2.
                - split.
                  + rewrite <- H11.
                    apply hd_skip.
                  + rewrite <- H4.
                    apply last_skip.
                    omega.
                }
              assert (H31: exists s'': sentence, derives g right (map term_lift s'')).
                {
                apply derives_split in H30.
                destruct H30 as [s1' [s2' [H35 [H36 H37]]]].
                apply derives_split in H37.
                destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
                symmetry in H35.
                apply map_expand in H35.
                destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
                rewrite <- H43 in H38.
                symmetry in H38.
                apply map_expand in H38.
                destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
                rewrite <- H51 in H39.
                exists s1'''.
                exact H39.
                }
              assert (H32: exists s'': sentence, derives g [inl n0] (map term_lift s'')).
                {
                apply in_split in H8.
                destruct H8 as [l1 [l2 H60]].
                rewrite H60 in H31.
                destruct H31 as [s'' H61].
                apply derives_split in H61.
                destruct H61 as [s1' [s2' [H35 [H36 H37]]]].
                replace (inl n0 :: l2) with ([inl n0] ++ l2) in H37.
                - apply derives_split in H37.
                  destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
                  symmetry in H35.
                  apply map_expand in H35.
                  destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
                  rewrite <- H43 in H38.
                  symmetry in H38.
                  apply map_expand in H38.
                  destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
                  rewrite <- H51 in H39.
                  exists s1'''.
                  exact H39.
                - simpl.
                  reflexivity.
                }
              exact H32.
            - simpl.
              auto.
          }
      }
  + destruct l as [|s0 l].
    * apply sflist_empty.
    * {
      destruct l as [|s1 l].
      - apply sflist_start.
      - replace (s0 :: s1 :: l) with ([s0] ++ [s1] ++ l) in H5.
        + repeat rewrite app_length in H5.
          simpl in H5.
          repeat apply lt_S_n in H5.
          apply lt_n_0 in H5.
          contradiction.
        + simpl.
          reflexivity.
      }
- split.
  + exact H3.
  + exact H4.
Qed.

Lemma useful_g_use:
forall g: cfg _ _,
forall n: non_terminal,
appears (g_use g) (inl n) -> useful (g_use g) (inl n).
Proof.
intros g n H.
inversion H.
clear H.
destruct H0 as [right [H1 H2]].
destruct H2 as [H2| H2].
- subst.
  simpl in H1.
  inversion H1.
  subst.
  apply useful_g_g_use.
  exact H0.
- simpl in H1.
  inversion H1.
  subst.
  apply useful_g_g_use.
  specialize (H3 (inl n)).
  apply H3.
  exact H2.
Qed.

Lemma sflist_g_use_g:
forall g: cfg _ _,
forall l: list sf,
sflist (g_use g) l -> sflist g l.
Proof.
intros g l H.
induction H.
- apply sflist_empty.
- apply sflist_start.
- apply sflist_step with (left:=left).
  exact IHsflist.
  exact H0.
  simpl in H1.
  inversion H1.
  exact H2.
Qed.

Lemma produces_g_use_g:
forall g: cfg _ _,
forall s: sentence,
produces (g_use g) s -> produces g s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
simpl in H2.
apply derives_sflist.
exists l.
split.
- apply sflist_g_use_g.
  exact H1.
- split.
  + exact H2.
  + exact H3.
Qed.

Lemma sflist_g_g_use:
forall g: cfg _ _,
forall l: list sf,
forall s: sentence,
sflist g l /\ last l [] = map term_lift s -> sflist (g_use g) l.
Proof.
intros g l s [H1 H2].
assert (H3: length l >= 2 \/ length l < 2).
  {
  omega.
  }
destruct H3 as [H3 | H3].
- assert (H3':=H3).
  apply sflist_rules with (g:=g) in H3.
  destruct H3 as [H3 _].
  specialize (H3 H1).
  apply sflist_rules.
  + exact H3'.
  + intros i H4.
    specialize (H3 i H4).
    destruct H3 as [left [right [s0 [s' [H5 [H6 H7]]]]]].
    exists left, right, s0, s'.
    split.
    * exact H5.
    * {
      split.
      - exact H6.
      - simpl.
        apply Lift_use.
        + exact H7.
        + unfold useful.
          assert (H20: derives g (s0 ++ inl left :: s') (map term_lift s)).
            {
            apply derives_sflist.
            rewrite <- (firstn_skipn i l) in H1.
            apply sflist_app_l in H1.
            exists (skipn i l).
            split.
            - exact H1.
            - split.
              + rewrite hd_skip.
                exact H5.
              + rewrite last_skip.
                * exact H2.
                * omega.
            }
          assert (H21: exists s'': sentence, derives g [inl left] (map term_lift s'')).
            {
            apply derives_split in H20.
            destruct H20 as [s1' [s2' [H21 [_ H22]]]].
            replace (inl left :: s') with ([inl left] ++ s') in H22.
            - apply derives_split in H22.
              destruct H22 as [s1'0 [s2'0 [H31 [H32 _]]]].
              symmetry in H21.
              apply map_expand in H21.
              destruct H21 as [s1'' [s2'' [H40 [H41 H42]]]].
              rewrite <- H42 in H31.
              symmetry in H31.
              apply map_expand in H31.
              destruct H31 as [s1''' [s2''' [H50 [H51 H52]]]].
              rewrite <- H51 in H32.
              exists s1'''.
              exact H32.
            - simpl.
              reflexivity.
            }
          exact H21.
        + intros s1 H99.
          destruct s1.
          * assert (H30: derives g (s0 ++ right ++ s') (map term_lift s)).
              {
              apply derives_sflist.
              rewrite <- (firstn_skipn (S i) l) in H1.
              apply sflist_app_l in H1.
              exists (skipn (S i) l).
                split.
              - exact H1.
              - split.
                + rewrite <- H6.
                  apply hd_skip.
                + rewrite <- H2.
                  apply last_skip.
                  omega.
              }
            assert (H31: exists s'': sentence, derives g right (map term_lift s'')).
              {
              apply derives_split in H30.
              destruct H30 as [s1' [s2' [H35 [H36 H37]]]].
              apply derives_split in H37.
              destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
              symmetry in H35.
              apply map_expand in H35.
              destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
              rewrite <- H43 in H38.
              symmetry in H38.
              apply map_expand in H38.
              destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
              rewrite <- H51 in H39.
              exists s1'''.
              exact H39.
              }
            assert (H32: exists s'': sentence, derives g [inl n] (map term_lift s'')).
              {
              apply in_split in H99.
              destruct H99 as [l1 [l2 H60]].
              rewrite H60 in H31.
              destruct H31 as [s'' H61].
              apply derives_split in H61.
              destruct H61 as [s1' [s2' [H35 [H36 H37]]]].
              replace (inl n :: l2) with ([inl n] ++ l2) in H37.
              - apply derives_split in H37.
                destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
                symmetry in H35.
                apply map_expand in H35.
                destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
                rewrite <- H43 in H38.
                symmetry in H38.
                apply map_expand in H38.
                destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
                rewrite <- H51 in H39.
                exists s1'''.
                exact H39.
              - simpl.
                reflexivity.
              }
            unfold useful.
            exact H32.
          * simpl.
            auto.
      }
- destruct l as [|s0 l].
  + apply sflist_empty.
  + destruct l as [|s1 l].
    * apply sflist_start.
    * {
      replace (s0 :: s1 :: l) with ([s0] ++ [s1] ++ l) in H3.
      - repeat rewrite app_length in H3.
        simpl in H3.
        repeat apply lt_S_n in H3.
        apply lt_n_0 in H3.
        contradiction.
      - simpl.
        reflexivity.
      }
Qed.

Lemma produces_g_g_use:
forall g: cfg _ _,
forall s: sentence,
produces g s -> produces (g_use g) s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
apply derives_sflist.
exists l.
split.
- apply sflist_g_g_use with (s:=s).
  split.
  + exact H1.
  + exact H3.
- split.
  + exact H2.
  + exact H3.
Qed.

Theorem g_equiv_use:
forall g: cfg _ _,
non_empty g -> g_equiv (g_use g) g.
Proof.
unfold g_equiv.
intros g H' s.
split.
- apply produces_g_use_g.
- apply produces_g_g_use.
Qed.

Theorem g_use_correct:
forall g: cfg _ _,
non_empty g ->
g_equiv (g_use g) g /\
has_no_useless_symbols (g_use g).
Proof.
intros g H'.
split.
- apply g_equiv_use.
  exact H'.
- unfold has_no_useless_symbols.
  intros n H.
  inversion H.
  destruct H0 as [right [H1 H2]].
  simpl in H1.
  inversion H1.
  subst.
  destruct H2.
  + subst.
    apply useful_g_g_use in H3.
    exact H3.
  + specialize (H4 (inl n) H2).
    apply useful_g_g_use in H4.
    exact H4.
Qed.

End Useless.


(** Operations, lemmas, and tactics for working with environments,
    association lists whose keys are atoms.  Unless stated otherwise,
    implicit arguments will not be declared by default.

    Authors: Brian Aydemir and Arthur Charguéraud, with help from
    Aaron Bohannon, Benjamin Pierce, Jeffrey Vaughan, Dimitrios
    Vytiniotis, Stephanie Weirich, and Steve Zdancewic.

    Table of contents:
      - #Overview#
      - #Functions on environments#
      - #Relations on environments#
      - #Properties of operations#
      - #Automation and tactics (I)#
      - #Properties of well-formedness and freshness#
      - #Properties of binds#
      - #Automation and tactics (II)#
      - #Additional properties of binds#
      - #Automation and tactics (III)# *)

Require Export List.
Require Export ListFacts.
Require Import Atom.

Import AtomSet.F.

#[global]
Hint Unfold E.eq : basic.

(* ********************************************************************** *)
(** * ## Overview *)

(** An environment is a list of pairs, where the first component of
    each pair is an [atom].  We view the second component of each pair
    as being bound to the first component.  In a well-formed
    environment, there is at most one binding for any given atom.
    Bindings at the head of the list are "more recent" than bindings
    toward the tail of the list, and we view an environment as growing
    on the left, i.e., at its head.

    We normally work only with environments built up from the
    following: the empty list, one element lists, and concatenations
    of two lists.  This seems to be more convenient in practice.  For
    example, we don't need to distinguish between consing on a binding
    and concatenating a binding, a difference that Coq's tactics can
    be sensitive to.

    However, basic definitions are by induction on the usual structure
    of lists ([nil] and [cons]).

    To make it convenient to write one element lists, we define a
    special notation.  Note that this notation is local to this
    particular library, to allow users to use alternate notations if
    they desire. *)

Notation "[ x ]" := (cons x nil).

(** In the remainder of this library, we define a number of
    operations, lemmas, and tactics that simplify working with
    environments. *)

(* ********************************************************************** *)
(** * ## Functions on environments *)

(** Implicit arguments will be declared by default for the definitions
    in this section. *)

Set Implicit Arguments.

Section Definitions.

Variables A B : Type.

(** The domain of an environment is the set of atoms that it maps. *)

Fixpoint dom (E : list (atom * A)) : atoms :=
  match E with
  | nil => empty
  | (x, _) :: E' => union (singleton x) (dom E')
  end.

(** [map] applies a function to all bindings in the environment. *)

Fixpoint map (f : A -> B) (E : list (atom * A)) : list (atom * B) :=
  match E with
  | nil => nil
  | (x, V) :: E' => (x, f V) :: map f E'
  end.

(** [get] returns the value bound to the given atom in an environment
    or [None] if the given atom is not bound.  If the atom has
    multiple bindings, the one nearest to the head of the environment
    is returned. *)

Fixpoint get (x : atom) (E : list (atom * A)) : option A :=
  match E with
  | nil => None
  | (y,a) :: E' => if eq_atom_dec x y then Some a else get x E'
  end.

End Definitions.

Unset Implicit Arguments.

(* ********************************************************************** *)
(** * ## Relations on environments *)

(** Implicit arguments will be declared by default for the definitions
    in this section. *)

Set Implicit Arguments.

Section Relations.

Variable A : Type.

(** An environment is well-formed if and only if each atom is bound at
    most once. *)

Inductive ok : list (atom * A) -> Prop :=
  | ok_nil :
      ok nil
  | ok_cons : forall (E : list (atom * A)) (x : atom) (a : A),
      ok E -> ~ In x (dom E) -> ok ((x, a) :: E).

(** ## An environment [E] contains a binding
    from [x] to [b], denoted [(binds x b E)], if and only if the most
    recent binding for [x] is mapped to [b]. *)

Definition binds x b (E : list (atom * A)) :=
  get x E = Some b.

End Relations.

Unset Implicit Arguments.

(* ********************************************************************** *)
(** * ## Properties of operations *)

Section OpProperties.
Variable A B : Type.
Implicit Types E F : list (atom * A).
Implicit Types a b : A.

(** ** Facts about concatenation *)

Lemma concat_nil : forall E,
  E ++ nil = E.
Proof.
  auto using List.app_nil_end.
Qed.

Lemma nil_concat : forall E,
  nil ++ E = E.
Proof.
  reflexivity.
Qed.

Lemma concat_assoc : forall E F G,
  (G ++ F) ++ E = G ++ (F ++ E).
Proof.
  auto using List.app_ass.
Qed.

(** ** [map] commutes with environment-building operations *)

Lemma map_nil : forall (f : A -> B),
  map f nil = nil.
Proof.
  reflexivity.
Qed.

Lemma map_single : forall (f : A -> B) y b,
  map f [(y,b)] = [(y, f b)].
Proof.
  reflexivity.
Qed.

Lemma map_push : forall (f : A -> B) y b E,
  map f ([(y,b)] ++ E) = [(y, f b)] ++ map f E.
Proof.
  reflexivity.
Qed.

Lemma map_concat : forall (f : A -> B) E F,
  map f (F ++ E) = (map f F) ++ (map f E).
Proof.
  induction F as [|(x,a)]; simpl; congruence.
Qed.

(** ** Facts about the domain of an environment *)

Lemma dom_nil :
  @dom A nil = empty.
Proof.
  reflexivity.
Qed.

Lemma dom_single : forall x a,
  dom [(x,a)] = singleton x.
Proof.
  simpl. intros. fsetdec.
Qed.

Lemma dom_push : forall x a E,
  dom ([(x,a)] ++ E) = union (singleton x) (dom E).
Proof.
  simpl. intros. reflexivity.
Qed.

Lemma dom_concat : forall E F,
  dom (F ++ E) = union (dom F) (dom E).
Proof.
  induction F as [|(x,a) F IH]; simpl.
  fsetdec.
  rewrite IH. fsetdec.
Qed.

Lemma dom_map : forall (f : A -> B) E,
  dom (map f E) = dom E.
Proof.
  induction E as [|(x,a)]; simpl; congruence.
Qed.

(** ** Other trivial rewrites *)

Lemma cons_concat_assoc : forall x a E F,
    ((x, a) :: E) ++ F = (x, a) :: (E ++ F).
Proof.
  reflexivity.
Qed.

End OpProperties.

(* ********************************************************************** *)
(** * ## Automation and tactics (I) *)

(** ** [simpl_env] *)

(** The [simpl_env] tactic can be used to put environments in the
    standardized form described above, with the additional properties
    that concatenation is associated to the right and empty
    environments are removed.  Similar to the [simpl] tactic, we
    define "[in *]" and "[in H]" variants of [simpl_env]. *)

Definition singleton_list (A : Type) (x : atom * A) := x :: nil.

Lemma cons_concat : forall (A : Type) (E : list (atom * A)) x a,
  (x, a) :: E = singleton_list A (x, a) ++ E.
Proof.
  reflexivity.
Qed.

Lemma map_singleton_list : forall (A B : Type) (f : A -> B) y b,
  map f (singleton_list A (y,b)) = [(y, f b)].
Proof.
  reflexivity.
Qed.

Lemma dom_singleton_list : forall (A : Type) (x : atom) (a : A),
  dom (singleton_list A (x,a)) = singleton x.
Proof.
  simpl. intros. fsetdec.
Qed.

Hint Rewrite
  cons_concat map_singleton_list dom_singleton_list
  concat_nil nil_concat concat_assoc
  map_nil map_single map_push map_concat
  dom_nil dom_single dom_push dom_concat dom_map : rew_env.

Ltac simpl_env_change_aux :=
  match goal with
    | H : context[?x :: nil] |- _ =>
      progress (change (x :: nil) with (singleton_list x) in H);
      simpl_env_change_aux
    | |- context[?x :: nil] =>
      progress (change (x :: nil) with (singleton_list x));
      simpl_env_change_aux
    | _ =>
      idtac
  end.

Ltac simpl_env :=
  simpl_env_change_aux;
  autorewrite with rew_env;
  unfold singleton_list in *.

Tactic Notation "simpl_env" "in" hyp(H) :=
  simpl_env_change_aux;
  autorewrite with rew_env in H;
  unfold singleton_list in *.

Tactic Notation "simpl_env" "in" "*" :=
  simpl_env_change_aux;
  autorewrite with rew_env in *;
  unfold singleton_list in *.

(** ** [rewrite_env] *)

(** The tactic [(rewrite_env E)] replaces an environment in the
    conclusion of the goal with [E].  Suitability for replacement is
    determined by whether [simpl_env] can put [E] and the chosen
    environment in the same normal form, up to convertability in Coq.
    We also define a "[in H]" variant that performs the replacement in
    a hypothesis [H]. *)

Tactic Notation "rewrite_env" constr(E) :=
  match goal with
    | |- context[?x] =>
      change x with E
    | |- context[?x] =>
      replace x with E; [ | try reflexivity; simpl_env; reflexivity ]
  end.

Tactic Notation "rewrite_env" constr(E) "in" hyp(H) :=
  match type of H with
    | context[?x] =>
      change x with E in H
    | context[?x] =>
      replace x with E in H; [ | try reflexivity; simpl_env; reflexivity ]
  end.

(** ** Hints *)

#[global]
Hint Constructors ok : core.

#[global]
Hint Extern 1 (~ In _ _) => simpl_env in *; fsetdec : core.

(* ********************************************************************** *)
(** * ## Properties of well-formedness and freshness *)

Section OkProperties.
Variable A B : Type.
Implicit Types E F : list (atom * A).
Implicit Types a b : A.

(** Facts about when an environment is well-formed. *)

Lemma ok_push :  forall (E : list (atom * A)) (x : atom) (a : A),
      ok E -> ~ In x (dom E) -> ok ([(x, a)] ++ E).
Proof.
  exact (@ok_cons A).
Qed.

Lemma ok_singleton : forall x a,
  ok [(x,a)].
Proof.
  auto.
Qed.

Lemma ok_remove_mid : forall F E G,
  ok (G ++ F ++ E) -> ok (G ++ E).
Proof with auto.
  induction G as [|(y,a)]; intros Ok.
    induction F as [|(y,a)]; simpl... inversion Ok...
    inversion Ok. simpl...
Qed.

Lemma ok_remove_mid_cons : forall x a E G,
  ok (G ++ (x, a) :: E) ->
  ok (G ++ E).
Proof.
  intros. simpl_env in *. eauto using ok_remove_mid.
Qed.

Lemma ok_map : forall E (f : A -> B),
  ok E -> ok (map f E).
Proof with auto.
  intros.
  induction E as [ | (y,b) E ] ; simpl...
  inversion H...
Qed.

Lemma ok_map_app_l : forall E F (f : A -> A),
  ok (F ++ E) -> ok (map f F ++ E).
Proof with auto.
  intros. induction F as [|(y,a)]; simpl...
  inversion H...
Qed.

(** A binding in the middle of an environment has an atom fresh from
    all bindings before and after it. *)

Lemma fresh_mid_tail : forall E F x a,
  ok (F ++ [(x,a)] ++ E) -> ~ In x (dom E).
Proof with auto.
  induction F as [|(y,b)]; intros x c Ok; simpl_env in *.
    inversion Ok...
    inversion Ok; subst. simpl_env in *. apply (IHF _ _ H1).
Qed.

Lemma fresh_mid_head : forall E F x a,
  ok (F ++ [(x,a)] ++ E) -> ~ In x (dom F).
Proof with auto.
  induction F as [|(y,b)]; intros x c Ok; simpl_env in *.
    inversion Ok...
    inversion Ok; subst. simpl_env in *. pose proof (IHF _ _ H1)...
Qed.

End OkProperties.

(* ********************************************************************** *)
(** * ## Properties of [binds] *)

Section BindsProperties.
Variable A B : Type.
Implicit Types E F : list (atom * A).
Implicit Types a b : A.

(** ** Introduction forms for [binds] *)

(** The following properties allow one to view [binds] as an
    inductively defined predicate.  This is the preferred way of
    working with the relation. *)

Lemma binds_singleton : forall x a,
  binds x a [(x,a)].
Proof.
  intros x a. unfold binds. simpl. destruct (eq_atom_dec x x); intuition.
Qed.

Lemma binds_tail : forall x a E F,
  binds x a E -> ~ In x (dom F) -> binds x a (F ++ E).
Proof with auto.
  unfold binds. induction F as [|(y,b)]; simpl...
  destruct (eq_atom_dec x y)... intros _ J. destruct J. fsetdec.
Qed.

Lemma binds_head : forall x a E F,
  binds x a F -> binds x a (F ++ E).
Proof.
  unfold binds. induction F as [|(y,b)]; simpl; intros H.
  discriminate.
  destruct (eq_atom_dec x y); intuition.
Qed.

(** ** Case analysis on [binds] *)

Lemma binds_concat_inv : forall x a E F,
  binds x a (F ++ E) -> (~ In x (dom F) /\ binds x a E) \/ (binds x a F).
Proof with auto.
  unfold binds. induction F as [|(y,b)]; simpl; intros H...
  destruct (eq_atom_dec x y).
    right...
    destruct (IHF H) as [[? ?] | ?]. left... right...
Qed.

Lemma binds_singleton_inv : forall x y a b,
  binds x a [(y,b)] -> x = y /\ a = b.
Proof.
  unfold binds. simpl. intros. destruct (eq_atom_dec x y).
    split; congruence.
    discriminate.
Qed.

(** ** Retrieving bindings from an environment *)

Lemma binds_mid : forall x a E F,
  ok (F ++ [(x,a)] ++ E) -> binds x a (F ++ [(x,a)] ++ E).
Proof with auto.
  unfold binds. induction F as [|(z,b)]; simpl; intros Ok.
  destruct (eq_atom_dec x x); intuition.
  inversion Ok; subst. destruct (eq_atom_dec x z)...
    destruct H3. simpl_env. fsetdec.
Qed.

Lemma binds_mid_eq : forall z a b E F,
  binds z a (F ++ [(z,b)] ++ E) -> ok (F ++ [(z,b)] ++ E) -> a = b.
Proof with auto.
  unfold binds. induction F as [|(x,c)]; simpl; intros H Ok.
  destruct (eq_atom_dec z z). congruence. intuition.
  inversion Ok; subst. destruct (eq_atom_dec z x)...
    destruct H4. simpl_env. fsetdec.
Qed.

Lemma binds_mid_eq_cons : forall x a b E F,
  binds x a (F ++ (x,b) :: E) ->
  ok (F ++ (x,b) :: E) ->
  a = b.
Proof.
  intros. simpl_env in *. eauto using binds_mid_eq.
Qed.

End BindsProperties.

(* ********************************************************************** *)
(** * ## Automation and tactics (II) *)

(** ** Hints *)

#[global]
Hint Immediate ok_remove_mid ok_remove_mid_cons : core.

#[global]
Hint Resolve
  ok_push ok_singleton ok_map ok_map_app_l
  binds_singleton binds_head binds_tail : core.

(** ** [binds_get] *)

(** The tactic [(binds_get H)] takes a hypothesis [H] of the form
    [(binds x a (F ++ [(x,b)] ++ E))] and introduces the equality
    [a=b] into the context.  Then, the tactic checks if the equality
    is discriminable and otherwise tries substituting [b] for [a].
    The [auto] tactic is used to show that [(ok (F ++ [(x,b)] ++ E))],
    which is needed to prove the equality [a=b] from [H]. *)

Ltac binds_get H :=
  match type of H with
    | binds ?z ?a (?F ++ [(?z,?b)] ++ ?E) =>
        let K := fresh in
          assert (K : ok (F ++ [(z,b)] ++ E));
          [ auto
          | let J := fresh in
              assert (J := @binds_mid_eq _ _ _ _ _ _ H K);
              clear K;
              try discriminate;
              try match type of J with
                    | ?a = ?b => subst a
                  end
          ]
  end.

(** ** [binds_cases] *)

(** The tactic [(binds_case H)] performs a case analysis on an
    hypothesis [H] of the form [(binds x a E)].  There will be one
    subgoal for each component of [E] that [x] could be bound in, and
    each subgoal will have appropriate freshness conditions on [x].
    Some attempts are made to automatically discharge contradictory
    cases. *)

Ltac binds_cases H :=
  let Fr := fresh "Fr" in
  let J1 := fresh in
  let J2 := fresh in
    match type of H with
      | binds _ _ nil =>
          inversion H
      | binds ?x ?a [(?y,?b)] =>
          destruct (@binds_singleton_inv _ _ _ _ _ H);
          clear H;
          try discriminate;
          try subst y;
          try match goal with
                | _ : ?z <> ?z |- _ => intuition
              end
      | binds ?x ?a (?F ++ ?E) =>
          destruct (@binds_concat_inv _ _ _ _ _ H) as [[Fr J1] | J2];
          clear H;
          [ binds_cases J1 | binds_cases J2 ]
      | _ => idtac
  end.

(* *********************************************************************** *)
(** * ## Additional properties of [binds] *)

(** The following lemmas are proven in manner that should be
    independent of the concrete definition of [binds]. *)

Section AdditionalBindsProperties.
Variable A B : Type.
Implicit Types E F : list (atom * A).
Implicit Types a b : A.

(** Lemmas about the relationship between [binds] and the domain of an
    environment. *)

Lemma binds_In : forall a x E,
  binds x a E -> In x (dom E).
Proof.
  induction E as [|(y,b)]; simpl_env; intros H.
  binds_cases H.
  binds_cases H; subst. auto using union_3. fsetdec.
Qed.

Lemma binds_fresh : forall x a E,
  ~ In x (dom E) -> ~ binds x a E.
Proof.
  induction E as [|(y,b)]; simpl_env; intros Fresh H.
  binds_cases H.
  binds_cases H. intuition. fsetdec.
Qed.

(** Additional lemmas for showing that a binding is in an
    environment. *)

Lemma binds_map : forall x a (f : A -> B) E,
  binds x a E -> binds x (f a) (map f E).
Proof.
  induction E as [|(y,b)]; simpl_env; intros H.
  binds_cases H.
  binds_cases H; auto. subst; auto.
Qed.

Lemma binds_concat_ok : forall x a E F,
  binds x a E -> ok (F ++ E) -> binds x a (F ++ E).
Proof.
  induction F as [|(y,b)]; simpl_env; intros H Ok.
  auto.
  inversion Ok; subst. destruct (eq_atom_dec x y); subst; auto.
    assert (In y (dom (F ++ E))) by eauto using binds_In.
    intuition.
Qed.

Lemma binds_weaken : forall x a E F G,
  binds x a (G ++ E) ->
  ok (G ++ F ++ E) ->
  binds x a (G ++ F ++ E).
Proof.
  induction G as [|(y,b)]; simpl_env; intros H Ok.
  auto using binds_concat_ok.
  inversion Ok; subst. binds_cases H; subst; auto.
Qed.

Lemma binds_weaken_at_head : forall x a F G,
  binds x a G ->
  ok (F ++ G) ->
  binds x a (F ++ G).
Proof.
  intros x a F G H J.
  rewrite_env (nil ++ F ++ G).
  apply binds_weaken; simpl_env; trivial.
Qed.

Lemma binds_remove_mid : forall x y a b F G,
  binds x a (F ++ [(y,b)] ++ G) ->
  x <> y ->
  binds x a (F ++ G).
Proof.
  intros x y a b F G H J.
  binds_cases H; auto.
Qed.

Lemma binds_remove_mid_cons : forall x y a b E G,
  binds x a (G ++ (y, b) :: E) ->
  x <> y ->
  binds x a (G ++ E).
Proof.
  intros. simpl_env in *. eauto using binds_remove_mid.
Qed.

End AdditionalBindsProperties.

(* *********************************************************************** *)
(** * ## Automation and tactics (III) *)

#[global]
Hint Resolve binds_map binds_concat_ok binds_weaken binds_weaken_at_head : core.

#[global]
Hint Immediate binds_remove_mid binds_remove_mid_cons : core.


Require Import List EqNat Bool.
Require Import IL Exp SetOperations Val DecSolve.

Set Implicit Arguments.

(**
evalSexp evaluates an SMT expression given an environment that must be total on
every variable that may occur in a formula.
**)

(* "Lower" an environment back to returning option types **)
Definition to_partial (E:env val) x : option val := Some (E x).

(* Make an environment total *)
Definition to_total (E:onv val) x : val :=
  match E x with
    |Some v => v
    |None => default_val
  end.

Lemma agree_on_partial lv E E'
: agree_on eq lv E E'
  -> agree_on eq lv (to_partial E) (to_partial E').
Proof.
  intros; unfold to_partial; hnf; intros; simpl.
  rewrite H; eauto.
Qed.

Lemma agree_on_total lv E E'
: agree_on eq lv E E'
  -> agree_on eq lv (to_total E) (to_total E').
Proof.
  intros; unfold to_total; hnf; intros; simpl.
  rewrite H; eauto.
Qed.

Lemma to_partial_to_total (E:onv val) x v
  : E x = Some v -> to_partial (to_total E) x = Some v.
Proof.
  intros.
  unfold to_partial, to_total. cases; eauto.
Qed.

(** Define what uninterpreted function symbols are **)
Definition pred := lab (*arglst -> bool*).

(** First define what an smt statement is **)
Inductive smt :Type :=
(** Conjunction **)
| smtAnd: smt -> smt -> smt
(** Disjunction **)
| smtOr: smt -> smt -> smt
(** Negation **)
| smtNeg: smt -> smt
(** Conditional **)
| ite: op -> smt -> smt -> smt
(** Implication **)
| smtImp: smt -> smt -> smt
(** Constraint *)
| constr: op -> op -> smt
(** Predicate evaluation **)
| funcApp: pred -> list op -> smt
(** Constant false **)
| smtFalse: smt
(** Constant true **)
| smtTrue:smt.

Instance smt_eq_dec (s t:smt) : Computable (s = t).
Proof.
  general induction s; destruct t; try dec_solve;
  try (decide (s1 = t1); decide (s2 = t2); subst; eauto; try dec_solve);
  try (decide (s = t); subst; eauto; try dec_solve).
  - decide (o = o0); subst; dec_solve.
  - decide (o = o1); decide (o0 = o2); subst; dec_solve.
  - decide (p = p0); decide (l = l0); subst; dec_solve.
Qed.

(** Now define the parameters for the translation function **)
Inductive pol:Type :=
| source :pol
| target :pol.

Fixpoint listGen (el:list op) :=
match el with
|nil => nil
|_:: el' => default_val :: listGen el'
end.

Parameter undef_substitute : val.

Definition smt_eval (E:env val) (e:op) :=
  match op_eval (to_partial E) e with
    | Some v => v
    | None => undef_substitute
  end.

(** models relation for smt. No need for options here too, because if models can be evaluated by an environment,
every variable must have been defined. **)
Fixpoint models (F:pred -> list val -> bool) (E:env val) (s:smt) : Prop:=
  match s with
  |smtAnd a b
   => (models F E a) /\ (models F E b)
  |smtOr a b
   => (models F E a) \/  (models F E b)
  |smtNeg a
   =>  (models F E a) -> False
  | ite c t f
    =>  if val2bool (smt_eval E c)
       then models F E t
       else models F E f
  |smtImp a b
   => (models F E a) ->(models F E b)
  |constr s1 s2 => (smt_eval E s1) = (smt_eval E s2)
  |funcApp f a => F f (List.map (smt_eval E) a)
  |smtFalse => False
  |smtTrue => True
  end.

Lemma smtand_comm a b F E
  : models F E (smtAnd a b)
    -> models F E (smtAnd b a).
Proof.
  intros.
  hnf in H. simpl. destruct H as [A B]. eauto.
Qed.

Lemma smtand_neg_comm:
forall a b F E,
~ models F E (smtAnd a b)
-> ~ models F E (smtAnd b a).

Proof.
intros.
hnf. intros. eapply smtand_comm in H0. eapply H. assumption.
Qed.

Lemma extend_not_models:
forall s Q,
(forall F E, ~ models F E s)
-> (forall F E, models F E Q -> ~ models F E s).

Proof.
intros.
specialize (H F E). assumption.
Qed.

(*
Instance bind_equiv (A B : Type) `{Equivalence A} `{Equivalence B}
         (f:A -> option B) `{Proper _ (Equivalence.equiv ==> Equivalence.equiv) f}
  : Proper (Equivalence.equiv ==> Equivalence.equiv) (@bind A B f).
Proof.
  unfold Proper, respectful; intros; subst.
  inv H2; simpl; eauto.
Qed.

Lemma eq_equiv X (x y:X) `{Equivalence X}
  : x = y -> x === y.
Proof.
  intros; subst; eauto.
Qed.
Hint Immediate eq_equiv.
 *)

Lemma op_eval_partial_total E e v
 : op_eval E e = Some v ->
   op_eval (to_partial (to_total E)) e = Some v.
Proof.
  intros.
  general induction e; simpl in * |- *; eauto.
  - erewrite to_partial_to_total; eauto.
  - monad_inv H; simpl; eauto.
    erewrite IHe; eauto.
  - intros.
    monad_inv H; simpl.
    erewrite IHe1, IHe2; eauto; simpl.
Qed.

Lemma op_eval_smt_eval E e v
 : op_eval E e = Some v ->
   smt_eval (to_total E) e = v.
Proof.
  intros. unfold smt_eval.
  erewrite op_eval_partial_total; eauto.
Qed.

Lemma smt_eval_op D E E' e v
  : op_eval E e = Some v
    -> agree_on eq D E E'
    -> Ops.freeVars e ⊆ D
    -> smt_eval (to_total E') e = v.
Proof.
  intros.
  repeat erewrite op_eval_smt_eval; eauto.
  eauto using op_eval_agree with cset.
Qed.

Lemma smt_eval_var D1 D2 E1 E2 E' x e v
  : op_eval E2 e = Some v
    -> agree_on eq D1 (E1 [x <- Some v]) E'
    -> agree_on eq D2 E2 E'
    -> singleton x ⊆ D1
    -> Ops.freeVars e ⊆ D2
    -> smt_eval (to_total E') (Var x) = smt_eval (to_total E') e.
Proof.
  intros.
  repeat erewrite op_eval_smt_eval; eauto.
  eauto using op_eval_agree with cset.
  eapply op_eval_agree; eauto with cset.
  simpl. lud; eauto.
Qed.

(** Next 2 Lemmata belong to Lemma 4 in subsection 3.4 in the thesis
They prove that evaluation without a total environment is equal
to evaluation under a total environment **)
Lemma op_eval_partial_total_list E el vl
:  omap (op_eval E) el = Some vl
-> omap (op_eval (to_partial (to_total  E))) el = Some vl.

Proof.
  intros. general induction el; eauto using op_eval_partial_total.
  - simpl in H. monad_inv H. simpl.
    erewrite op_eval_partial_total; eauto; simpl.
    erewrite IHel; simpl; eauto.
Qed.

Lemma list_eval_agree E el v:
  omap(op_eval E) el = Some v
  -> List.map (smt_eval (to_total E) ) el = v.

Proof.
  intros. general induction el.
  - eauto.
  - simpl in *.
    monad_inv H.
    eapply op_eval_partial_total in EQ.
    unfold smt_eval at 1.
    rewrite EQ.
    f_equal.
    erewrite (IHel E x0); eauto.
Qed.

Lemma list_length_agree E el v:
  omap (op_eval E) el = v
  ->(exists vl, List.map (smt_eval (to_total E)) el = vl
               /\ List.length el = List.length vl).

Proof.
  intros.
  general induction el.
  - simpl.
    exists nil; split; eauto.
  - simpl in *.
    specialize (IHel E (omap (op_eval E) el)).
    destruct IHel; eauto.
    destruct H.
    exists ( (smt_eval (to_total E) a):: x).
    simpl. rewrite H. split; eauto.
Qed.

Fixpoint freeVars (s:smt) :=
match s with
| funcApp f x => list_union (List.map (Ops.freeVars) x)
| smtAnd a b => freeVars a ∪ freeVars b
| smtOr a b => freeVars a ∪ freeVars b
| smtNeg a => freeVars a
| ite c t f => freeVars t ∪ freeVars f ∪ Ops.freeVars c
| smtImp a b => freeVars a ∪ freeVars b
| smtFalse => {}
| smtTrue =>  {}
|constr e1 e2 => Ops.freeVars e1 ∪ Ops.freeVars e2
end.

Lemma models_agree F E E' s:
  agree_on eq (freeVars s) E E'
  -> (models F E s <-> models F E' s).

Proof.
intros agree; general  induction s; simpl in *; try reflexivity.
- rewrite (IHs1 F E E'), (IHs2 F E E'); eauto with cset. reflexivity.
- rewrite (IHs1 F E E'), (IHs2 F E E'); eauto with cset. reflexivity.
- rewrite (IHs F E E'); eauto with cset. reflexivity.
- assert (agree_on eq (Ops.freeVars o) E E') by eauto with cset.
  assert (op_eval (to_partial E) o = op_eval (to_partial E') o). {
    eapply op_eval_agree; symmetry; eauto.
    eapply agree_on_partial; eauto.
  }
 unfold smt_eval in *.
  case_eq (op_eval (to_partial E) o); intros.
  +  rewrite <- H0. rewrite H1. case_eq(val2bool v); intros.
     * rewrite (IHs1 F E E'); eauto with cset.
     * rewrite (IHs2 F E E'); eauto with cset.
  + rewrite <- H0; rewrite H1. case_eq (val2bool undef_substitute); intros.
    * rewrite (IHs1 F E E'); eauto with cset.
    * rewrite (IHs2 F E E'); eauto with cset.
- rewrite (IHs1 F E E'), (IHs2 F E E'); eauto with cset. reflexivity.
- assert (op_eval (to_partial E) o = op_eval (to_partial E') o). {
    eapply op_eval_agree; symmetry; eauto.
    eapply agree_on_partial. eapply agree_on_incl; eauto.  }
  assert (op_eval (to_partial E) o0 = op_eval (to_partial E') o0). {
    eapply op_eval_agree; symmetry; eauto.
    eapply agree_on_partial. eapply agree_on_incl; eauto.  }
  unfold smt_eval in *.
  rewrite <- H; rewrite <- H0.
  unfold val2bool.
  case_eq (op_eval (to_partial E) o); case_eq (op_eval (to_partial E) o0); intros;
  try rewrite bvEq_equiv_eq; reflexivity.
- destruct p.
  assert (List.map (smt_eval E) l = List.map (smt_eval E') l).
  + general induction l.
    * eauto.
    * simpl.
      assert (smt_eval E a = smt_eval E' a).
      { unfold smt_eval.
      pose proof (op_eval_agree (E:=to_partial E) (E':=to_partial E') a (v:=op_eval (to_partial E) a)).
      rewrite H; eauto.
      eapply agree_on_partial.
      simpl in agree.
      eapply (agree_on_incl (bv:=Ops.freeVars a)
                            (lv:=list_union (Ops.freeVars a ::
                                                          List.map Ops.freeVars l))); eauto.
      cset_tac'; simpl.
      eapply list_union_start_swap.
      cset_tac. }
      { rewrite H. f_equal. eapply IHl; eauto.
        eapply (agree_on_incl (bv:=list_union (List.map Ops.freeVars l))
                              (lv:=list_union (List.map Ops.freeVars (a::l)))); eauto.
        simpl in *. setoid_rewrite list_union_start_swap at 2. cset_tac.
      }
  + rewrite H.  split; eauto.
Qed.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Cryptol.Coqlib.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.AST.
Require Import Cryptol.Semantics.
Require Import Cryptol.Utils.
Require Import Cryptol.Builtins.
Require Import Cryptol.BuiltinSem.
Require Import Cryptol.Values.

Require Import Cryptol.EvalTac.

Import HaskellListNotations.
Open Scope string.

Definition whole_prog := [(NonRecursive (Decl (0,"demote") DPrim)),(NonRecursive (Decl (1,"+") DPrim)),(NonRecursive (Decl (2,"-") DPrim)),(NonRecursive (Decl (3,"*") DPrim)),(NonRecursive (Decl (4,"/") DPrim)),(NonRecursive (Decl (5,"%") DPrim)),(NonRecursive (Decl (6,"^^") DPrim)),(NonRecursive (Decl (7,"lg2") DPrim)),(NonRecursive (Decl (9,"True") DPrim)),(NonRecursive (Decl (10,"False") DPrim)),(NonRecursive (Decl (11,"negate") DPrim)),(NonRecursive (Decl (12,"complement") DPrim)),(NonRecursive (Decl (13,"<") DPrim)),(NonRecursive (Decl (14,">") DPrim)),(NonRecursive (Decl (15,"<=") DPrim)),(NonRecursive (Decl (16,">=") DPrim)),(NonRecursive (Decl (17,"==") DPrim)),(NonRecursive (Decl (18,"!=") DPrim)),(NonRecursive (Decl (19,"===") (DExpr (ETAbs (30,"a") (ETAbs (31,"b") (EAbs (89,"f") (EAbs (90,"g") (EAbs (91,"x") (EApp (EApp (ETApp (EVar (17,"==")) (ETyp (TVar (TVBound 31 KType)))) (EApp (EVar (89,"f")) (EVar (91,"x")))) (EApp (EVar (90,"g")) (EVar (91,"x")))))))))))),(NonRecursive (Decl (20,"!==") (DExpr (ETAbs (40,"a") (ETAbs (41,"b") (EAbs (94,"f") (EAbs (95,"g") (EAbs (96,"x") (EApp (EApp (ETApp (EVar (18,"!=")) (ETyp (TVar (TVBound 41 KType)))) (EApp (EVar (94,"f")) (EVar (96,"x")))) (EApp (EVar (95,"g")) (EVar (96,"x")))))))))))),(NonRecursive (Decl (21,"min") (DExpr (ETAbs (50,"a") (EAbs (98,"x") (EAbs (99,"y") (EIf (EApp (EApp (ETApp (EVar (13,"<")) (ETyp (TVar (TVBound 50 KType)))) (EVar (98,"x"))) (EVar (99,"y"))) (EVar (98,"x")) (EVar (99,"y"))))))))),(NonRecursive (Decl (22,"max") (DExpr (ETAbs (56,"a") (EAbs (101,"x") (EAbs (102,"y") (EIf (EApp (EApp (ETApp (EVar (14,">")) (ETyp (TVar (TVBound 56 KType)))) (EVar (101,"x"))) (EVar (102,"y"))) (EVar (101,"x")) (EVar (102,"y"))))))))),(NonRecursive (Decl (23,"/\\") (DExpr (EAbs (103,"x") (EAbs (104,"y") (EIf (EVar (103,"x")) (EVar (104,"y")) (EVar (10,"False")))))))),(NonRecursive (Decl (24,"\\/") (DExpr (EAbs (105,"x") (EAbs (106,"y") (EIf (EVar (105,"x")) (EVar (9,"True")) (EVar (106,"y")))))))),(NonRecursive (Decl (25,"==>") (DExpr (EAbs (107,"a") (EAbs (108,"b") (EIf (EVar (107,"a")) (EVar (108,"b")) (EVar (9,"True")))))))),(NonRecursive (Decl (26,"&&") DPrim)),(NonRecursive (Decl (27,"||") DPrim)),(NonRecursive (Decl (28,"^") DPrim)),(NonRecursive (Decl (29,"zero") DPrim)),(NonRecursive (Decl (30,"<<") DPrim)),(NonRecursive (Decl (31,">>") DPrim)),(NonRecursive (Decl (32,"<<<") DPrim)),(NonRecursive (Decl (33,">>>") DPrim)),(NonRecursive (Decl (34,"#") DPrim)),(NonRecursive (Decl (35,"splitAt") DPrim)),(NonRecursive (Decl (36,"join") DPrim)),(NonRecursive (Decl (37,"split") DPrim)),(NonRecursive (Decl (38,"reverse") DPrim)),(NonRecursive (Decl (39,"transpose") DPrim)),(NonRecursive (Decl (40,"@") DPrim)),(NonRecursive (Decl (41,"@@") DPrim)),(NonRecursive (Decl (42,"!") DPrim)),(NonRecursive (Decl (43,"!!") DPrim)),(NonRecursive (Decl (44,"update") DPrim)),(NonRecursive (Decl (45,"updateEnd") DPrim)),(NonRecursive (Decl (46,"updates") (DExpr (ETAbs (121,"a") (ETAbs (122,"b") (ETAbs (123,"c") (ETAbs (124,"d") (EAbs (166,"xs0") (EAbs (167,"idxs") (EAbs (168,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (ETyp (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 124 KNum)]))) (ETyp (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)]))) (ETyp (TCon (TC (TCNum 0)) []))) (EVar (169,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 0)) []))) (ETyp (TCon (TC (TCNum 0)) [])))) [(Recursive [(Decl (169,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (ETyp (TCon (TC (TCNum 1)) []))) (ETyp (TVar (TVBound 124 KNum)))) (ETyp (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)]))) (EList [(EVar (166,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (44,"update")) (ETyp (TVar (TVBound 121 KNum)))) (ETyp (TVar (TVBound 122 KType)))) (ETyp (TVar (TVBound 123 KNum)))) (EVar (170,"xs"))) (EVar (171,"i"))) (EVar (172,"b"))) [[(From (170,"xs") (EVar (169,"xss")))],[(From (171,"i") (EVar (167,"idxs")))],[(From (172,"b") (EVar (168,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (47,"updatesEnd") (DExpr (ETAbs (156,"a") (ETAbs (157,"b") (ETAbs (158,"c") (ETAbs (159,"d") (EAbs (177,"xs0") (EAbs (178,"idxs") (EAbs (179,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (ETyp (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 159 KNum)]))) (ETyp (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)]))) (ETyp (TCon (TC (TCNum 0)) []))) (EVar (180,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 0)) []))) (ETyp (TCon (TC (TCNum 0)) [])))) [(Recursive [(Decl (180,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (ETyp (TCon (TC (TCNum 1)) []))) (ETyp (TVar (TVBound 159 KNum)))) (ETyp (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)]))) (EList [(EVar (177,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (45,"updateEnd")) (ETyp (TVar (TVBound 156 KNum)))) (ETyp (TVar (TVBound 157 KType)))) (ETyp (TVar (TVBound 158 KNum)))) (EVar (181,"xs"))) (EVar (182,"i"))) (EVar (183,"b"))) [[(From (181,"xs") (EVar (180,"xss")))],[(From (182,"i") (EVar (178,"idxs")))],[(From (183,"b") (EVar (179,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (48,"fromThen") DPrim)),(NonRecursive (Decl (49,"fromTo") DPrim)),(NonRecursive (Decl (50,"fromThenTo") DPrim)),(NonRecursive (Decl (51,"infFrom") DPrim)),(NonRecursive (Decl (52,"infFromThen") DPrim)),(NonRecursive (Decl (53,"error") DPrim)),(NonRecursive (Decl (54,"pmult") DPrim)),(NonRecursive (Decl (55,"pdiv") DPrim)),(NonRecursive (Decl (56,"pmod") DPrim)),(NonRecursive (Decl (57,"random") DPrim)),(NonRecursive (Decl (61,"take") (DExpr (ETAbs (214,"front") (ETAbs (215,"back") (ETAbs (216,"elem") (EAbs (212,"__p1") (EWhere (EVar (214,"x")) [(NonRecursive (Decl (213,"__p2") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (ETyp (TVar (TVBound 214 KNum)))) (ETyp (TVar (TVBound 215 KNum)))) (ETyp (TVar (TVBound 216 KType)))) (EVar (212,"__p1")))))),(NonRecursive (Decl (214,"x") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 0))))),(NonRecursive (Decl (215,"__p0") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (62,"drop") (DExpr (ETAbs (231,"front") (ETAbs (232,"back") (ETAbs (233,"elem") (EAbs (219,"__p4") (EWhere (EVar (222,"y")) [(NonRecursive (Decl (220,"__p5") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (ETyp (TVar (TVBound 231 KNum)))) (ETyp (TVar (TVBound 232 KNum)))) (ETyp (TVar (TVBound 233 KType)))) (EVar (219,"__p4")))))),(NonRecursive (Decl (221,"__p3") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 0))))),(NonRecursive (Decl (222,"y") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (63,"tail") (DExpr (ETAbs (249,"a") (ETAbs (250,"b") (EAbs (225,"xs") (EApp (ETApp (ETApp (ETApp (EVar (62,"drop")) (ETyp (TCon (TC (TCNum 1)) []))) (ETyp (TVar (TVBound 249 KNum)))) (ETyp (TVar (TVBound 250 KType)))) (EVar (225,"xs"))))))))),(NonRecursive (Decl (64,"width") (DExpr (ETAbs (255,"bits") (ETAbs (256,"len") (ETAbs (257,"elem") (EAbs (229,"__p6") (ETApp (ETApp (EVar (0,"demote")) (ETyp (TVar (TVBound 256 KNum)))) (ETyp (TVar (TVBound 255 KNum))))))))))),(NonRecursive (Decl (65,"undefined") (DExpr (ETAbs (260,"a") (EApp (ETApp (ETApp (EVar (53,"error")) (ETyp (TVar (TVBound 260 KType)))) (ETyp (TCon (TC (TCNum 9)) []))) (EList [(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 117)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 110)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 100)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 101)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 102)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 105)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 110)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 101)) []))) (ETyp (TCon (TC (TCNum 8)) []))),(ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 100)) []))) (ETyp (TCon (TC (TCNum 8)) [])))])))))),(NonRecursive (Decl (66,"groupBy") (DExpr (ETAbs (265,"each") (ETAbs (266,"parts") (ETAbs (267,"elem") (ETApp (ETApp (ETApp (EVar (37,"split")) (ETyp (TVar (TVBound 266 KNum)))) (ETyp (TVar (TVBound 265 KNum)))) (ETyp (TVar (TVBound 267 KType)))))))))),(NonRecursive (Decl (68,"trace") DPrim)),(NonRecursive (Decl (69,"traceVal") (DExpr (ETAbs (273,"n") (ETAbs (274,"a") (EAbs (240,"msg") (EAbs (241,"x") (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (68,"trace")) (ETyp (TVar (TVBound 273 KNum)))) (ETyp (TVar (TVBound 274 KType)))) (ETyp (TVar (TVBound 274 KType)))) (EVar (240,"msg"))) (EVar (241,"x"))) (EVar (241,"x")))))))))),(NonRecursive (Decl (242,"x") (DExpr (ETAbs (283,"a") (EAbs (249,"v") (EApp (ETApp (EVar (29,"zero")) (ETyp (TCon (TC TCFun) [TVar (TVBound 283 KType),TCon (TC TCSeq) [TCon (TC (TCNum 16)) [],TCon (TC TCBit) []]]))) (EVar (249,"v")))))))),(NonRecursive (Decl (243,"xprop") (DExpr (ETAbs (290,"") (EAbs (250,"v") (EApp (EApp (ETApp (EVar (17,"==")) (ETyp (TCon (TC TCSeq) [TCon (TC (TCNum 16)) [],TCon (TC TCBit) []]))) (EApp (ETApp (EVar (242,"x")) (ETyp (TVar (TVBound 290 KType)))) (EVar (250,"v")))) (ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 0)) []))) (ETyp (TCon (TC (TCNum 16)) []))))))))),(NonRecursive (Decl (244,"y") (DExpr (EAbs (251,"a") (EAbs (252,"b") (EApp (EApp (ETApp (EVar (29,"zero")) (ETyp (TCon (TC TCFun) [TCon (TC TCSeq) [TCon (TC (TCNum 12)) [],TCon (TC TCBit) []],TCon (TC TCFun) [TCon (TC TCSeq) [TCon (TC (TCNum 4)) [],TCon (TC TCBit) []],TCon (TC TCSeq) [TCon (TC (TCNum 17)) [],TCon (TC TCBit) []]]]))) (EVar (251,"a"))) (EVar (252,"b")))))))),(NonRecursive (Decl (245,"yprop") (DExpr (EAbs (253,"v") (EAbs (254,"w") (EApp (EApp (ETApp (EVar (17,"==")) (ETyp (TCon (TC TCSeq) [TCon (TC (TCNum 17)) [],TCon (TC TCBit) []]))) (EApp (EApp (EVar (244,"y")) (EVar (253,"v"))) (EVar (254,"w")))) (ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 0)) []))) (ETyp (TCon (TC (TCNum 17)) []))))))))),(NonRecursive (Decl (246,"t1") (DExpr (EApp (ETApp (EVar (242,"x")) (ETyp (TCon (TC TCSeq) [TCon (TC (TCNum 4)) [],TCon (TC TCBit) []]))) (ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 13)) []))) (ETyp (TCon (TC (TCNum 4)) []))))))),(NonRecursive (Decl (247,"t2") (DExpr (EApp (EApp (EVar (244,"y")) (ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 2)) []))) (ETyp (TCon (TC (TCNum 12)) [])))) (ETApp (ETApp (EVar (0,"demote")) (ETyp (TCon (TC (TCNum 3)) []))) (ETyp (TCon (TC (TCNum 4)) [])))))))].

Definition ge := bind_decl_groups whole_prog gempty.

Definition t1 : ident := (246,"t1").
Definition t2 : ident := (247,"t2").


(* TLC in Coq
 *
 * Module: tlc.semantics.error
 * Purpose: Contains the error type.
 *)

Require Import mathcomp.ssreflect.seq.
Require Import mathcomp.ssreflect.ssreflect.
Require Import tlc.semantics.pattern.
Require Import tlc.syntax.all_syntax.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Errors that may be encountered while operating on terms and assertions *)
Inductive error :=
| EFuel (t : term)
| EEmptyMatch (a : term)
| EMatch (p : pattern) (pe : pattern_error) (a : term) (e : error)
| EOpenTerm (t : term) (us : seq term) (k : nat) (x : parameter)
| EOpenAssertion (A : assertion) (us : seq term) (k : nat) (x : parameter).


Require Import ABS.Rel.Definitions.
Require Import ABS.Lang.BindingsFacts.
Require Import ABS.Lang.OperationalFacts.
Require Import ABS.Lang.Sim.
Require Import ABS.Lang.SimFacts.

Section section_𝓞_is_adequate.

Lemma 𝓞_left_is_not_stuck n :
∀ ξ₁ ξ₂ t₁ t₂,
n ⊨ 𝓞 ξ₁ ξ₂ t₁ t₂ →
(∃ v₁ : val0, t₁ = v₁) ∨
(∃ ξ₁' t₁', step ⟨ξ₁, t₁⟩ ⟨ξ₁', t₁'⟩).
Proof.
induction n ; intros ξ₁ ξ₂ t₁ t₂ Ot.
+ apply 𝓞_unroll in Ot.
  idestruct Ot as Ot Ot.
  - ielim_prop Ot.
    destruct Ot as [ [? ?] [? [? ?]] ].
    left ; eexists ; eassumption.
  - idestruct Ot as ξ₁' Ot ; idestruct Ot as t₁' Ot ;
    idestruct Ot as St₁ Ot_later.
    ielim_prop St₁.
    right ; repeat eexists ; eassumption.
+ eapply (IHn _ _ _ t₂) ; clear IHn.
  apply 𝓞_roll.
  apply 𝓞_unroll in Ot.
  idestruct Ot as Ot Ot.
  - ielim_prop Ot.
    destruct Ot as [ [v₁ ?] [ξ₂' [v₂ ?]] ] ; subst.
    ileft.
    iintro_prop.
    split ; repeat eexists ; eauto.
  - idestruct Ot as ξ₁' Ot ; idestruct Ot as t₁' Ot ;
    idestruct Ot as St₁ Ot_later.
    ielim_prop St₁.
    apply I_valid_elim in Ot_later ; simpl in Ot_later.
    iright.
    repeat ieexists ; isplit.
    * iintro_prop ; eassumption.
    * iintro_later ; assumption.
Qed.

Lemma sim_preserves_𝓞_l_aux n ξ' t' :
n ⊨ ∀ᵢ ξ₁ ξ₂ t₁ t₂,
(LibList.noduplicates ξ₁)ᵢ ⇒ (LibList.noduplicates ξ₂)ᵢ ⇒
(tm_sim ξ₁ ξ₂ t₁ t₂)ᵢ ⇒ 𝓞 ξ₁ ξ' t₁ t' ⇒ 𝓞 ξ₂ ξ' t₂ t'.
Proof.
loeb_induction.
iintro ξ₁ ; iintro ξ₂ ; iintro t₁ ; iintro t₂.
iintro NoDup_ξ₁ ; iintro NoDup_ξ₂.
iintro Sim ; iintro Obs.
ielim_prop Sim.
apply 𝓞_unroll in Obs ; apply 𝓞_roll.
idestruct Obs as Obs Obs.
+ ileft.
  ielim_prop Obs.
  destruct Obs as [[v₁ ?] [ξ'next [v₂ ?]]] ; subst t₁.
  inversion Sim ; subst ; clear Sim.
  iintro_prop ; eauto.
+ iright.
  idestruct Obs as ξ₁next Obs ; idestruct Obs as t₁next Obs ;
  idestruct Obs as Step₁ Obs.
  ielim_prop Step₁.
  eapply sim_preserves_step in Sim as Step₂ ; eauto.
  destruct Step₂ as [ξ₂next [t₂next Step₂]].
  eapply step_preserves_sim in Step₂ as H ; [
    | exact Step₁ | reflexivity | reflexivity | auto | auto | exact Sim
  ].
  destruct H as [? _].
  repeat ieexists ; isplit.
  - eauto.
  - later_shift.
    ispecialize LöbIH ξ₁next ; ispecialize LöbIH ξ₂next ;
    ispecialize LöbIH t₁next ; ispecialize LöbIH t₂next.
    ispecialize LöbIH ; [ eauto using step_preserves_noduplicates | ].
    ispecialize LöbIH ; [ eauto using step_preserves_noduplicates | ].
    ispecialize LöbIH ; [ eauto | ].
    ispecialize LöbIH ; [ apply Obs | apply LöbIH ].
Qed.

Lemma sim_preserves_𝓞_l n ξ' t' ξ₁ ξ₂ t₁ t₂ :
LibList.noduplicates ξ₁ → LibList.noduplicates ξ₂ → tm_sim ξ₁ ξ₂ t₁ t₂ →
n ⊨ 𝓞 ξ₁ ξ' t₁ t' →
n ⊨ 𝓞 ξ₂ ξ' t₂ t'.
Proof.
specialize (sim_preserves_𝓞_l_aux n ξ' t') as H.
ispecialize H ξ₁ ; ispecialize H ξ₂ ; ispecialize H t₁ ; ispecialize H t₂.
intros.
repeat (ispecialize H ; [ eauto | ]).
assumption.
Qed.

Lemma 𝓞_left_is_sound n cfg cfg' :
  step_n n cfg cfg' →
  ∀ ξ ξ' t t',
  cfg = ⟨ξ, t⟩ →
  cfg' = ⟨ξ', t'⟩ →
  LibList.noduplicates ξ →
  Xs_tm t \c from_list ξ →
  ∀ ζ s,
  n ⊨ 𝓞 ξ ζ t s →
  (∃ v : val0, t' = v) ∨
  (∃ ξ'' t'', step ⟨ξ', t'⟩ ⟨ξ'', t''⟩).
Proof.
induction 1 as [ | n cfg [ξ'' t''] cfg' t_steps t''_steps IH ] ;
intros ξ ξ' t t' Eq_cfg Eq_cfg' NoDupξ Xst ζ s Obs.
+ rewrite Eq_cfg' in Eq_cfg ; inversion Eq_cfg ; subst ξ' t'.
  clear - Obs ; apply 𝓞_unroll in Obs ; unfold 𝓞_Fun in Obs.
  idestruct Obs as Obs Obs.
  - ielim_prop Obs ; crush.
  - idestruct Obs as ξ' Obs ; idestruct Obs as t' Obs ;
    idestruct Obs as t_steps Obs.
    eauto.
+ subst cfg cfg'.
  apply 𝓞_unroll in Obs ; unfold 𝓞_Fun in Obs.
  idestruct Obs as Obs Obs.
  - ielim_prop Obs ; destruct Obs as [ [v ?] [ζ' [u ?]] ].
    subst t.
    inversion t_steps.
  - idestruct Obs as _ξ'' Obs ; idestruct Obs as _t'' Obs ;
    idestruct Obs as _t_steps Obs.
    ielim_prop _t_steps.
    assert (LibList.noduplicates ξ'') as NoDupξ''.
    { eapply step_preserves_noduplicates ; try apply t_steps ; eauto. }
    assert (LibList.noduplicates _ξ'') as NoDup_ξ''.
    { eapply step_preserves_noduplicates ; try apply _t_steps ; eauto. }
    eapply IH ; [
      reflexivity | reflexivity | eassumption |
      eapply (step_preserves_closedness t_steps) ; [reflexivity|reflexivity|exact Xst] |
      clear IH
    ].
    rewrite I_later_shift in Obs.
    eapply sim_preserves_𝓞_l ; [ eassumption | eassumption | | eassumption ].
    eapply step_preserves_sim in t_steps as H ; [
      idtac | exact _t_steps | reflexivity | reflexivity |
      exact NoDupξ | exact NoDupξ | apply tm_sim_refl ; apply Xst
    ].
    destruct H as [H _] ; exact H.
Qed.

Theorem 𝓞_is_adequate n :
∀ ξ₁ ξ₂ t₁ t₂,
n ⊨ 𝓞 ξ₁ ξ₂ t₁ t₂ →
LibList.noduplicates ξ₁ →
Xs_tm t₁ \c from_list ξ₁ →
∀ ξ₁' (v₁ : val0), step_n n ⟨ξ₁, t₁⟩ ⟨ξ₁', v₁⟩ →
∃ ξ₂' (v₂ : val0), step_refl_tran ⟨ξ₂, t₂⟩ ⟨ξ₂', v₂⟩.
Proof.
induction n as [|n] ; intros ? ? ? ? Obs NoDup_ξ₁ Xst ξ₁' v₁ Step_n_t₁.
+ inversion Step_n_t₁ ; subst.
  apply 𝓞_unroll in Obs.
  idestruct Obs as Obs Obs.
  - ielim_prop Obs ; crush.
  - idestruct Obs as ξ₁'' Obs ; idestruct Obs as t₁'' Obs ;
    idestruct Obs as Step_v₁ Obs.
    ielim_prop Step_v₁ ; inversion Step_v₁.
+ inversion Step_n_t₁ as [ | ? ? [ξ₁'' t₁'' ] ? Step_t₁_t₁'' Step_n_t₁'' ] ; subst.
  apply 𝓞_unroll in Obs.
  idestruct Obs as Obs Obs.
  - ielim_prop Obs ; crush.
  - idestruct Obs as ξ₁''' Obs ; idestruct Obs as t₁''' Obs ;
    idestruct Obs as Step_t₁_t₁''' Obs ; ielim_prop Step_t₁_t₁'''.
    apply I_valid_elim in Obs ; simpl in Obs.
    assert (LibList.noduplicates ξ₁'') as NoDup_ξ₁''.
    { eauto using step_preserves_noduplicates. }
    assert (LibList.noduplicates ξ₁''') as NoDup_ξ₁'''.
    { eauto using step_preserves_noduplicates. }
    eapply IHn ; [
      idtac | exact NoDup_ξ₁'' |
      eauto using (step_preserves_closedness Step_t₁_t₁'') | exact Step_n_t₁''
    ].
    eapply sim_preserves_𝓞_l ; [ eassumption | eassumption | | exact Obs ].
    eapply step_preserves_sim in Step_t₁_t₁'' as H ; [
      idtac | exact Step_t₁_t₁''' | reflexivity | reflexivity |
      exact NoDup_ξ₁ | exact NoDup_ξ₁ | auto using tm_sim_refl
    ].
    destruct H as [H _] ; exact H.
Qed.

End section_𝓞_is_adequate.

Section section_logref_is_adequate.

Hint Rewrite dom_empty.
Hint Resolve subset_empty_l.
Hint Unfold step_refl_tran.
Hint Constructors Relation_Operators.clos_refl_trans_1n.

Lemma n_adequacy Ξ ξ₁ ξ₂ (t₁ t₂ : tm0) T n :
  𝜩 Ξ ξ₁ ξ₂ →
  n ⊨ ⟦ Ξ ∅→ ∅→ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # [] ⟧ →
  n ⊨ 𝓞 ξ₁ ξ₂ t₁ t₂.
Proof.
  intro HΞ.
  intro Ht.
  ispecialize Ht ξ₁ ; ispecialize Ht ξ₂.
  repeat ispecialize Ht (∅→ : ∅ → eff0).
  ispecialize Ht (∅→ : ∅ → IRel 𝓤_Sig).
  repeat ispecialize Ht (∅→ : ∅ → hd0).
  ispecialize Ht (∅→ : ∅ → IRel 𝓣_Sig).
  repeat ispecialize Ht (∅→ : ∅ → val0).
  ispecialize Ht.
  { iintro_prop ; crush. }
  ispecialize Ht.
  { iintro ; auto. }
  ispecialize Ht.
  { iintro_prop ; split ; crush. }
  ispecialize Ht.
  { iintro ; auto. }
  ispecialize Ht.
  { iintro ; auto. }
  repeat (erewrite V_bind_tm_id, HV_bind_tm_id, EV_bind_tm_id in Ht ; auto).
  repeat ispecialize Ht (ktx_hole : ktx0).
  iapply Ht.

  isplit.
  + repeat iintro ; simpl.
    apply 𝓞_roll.
    ileft.
    iintro_prop ; split ; repeat eexists ; auto.
  + iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
    iintro K₁ ; iintro K₂ ; iintro s₁ ; iintro s₂ ; iintro HKs.
    idestruct HKs as ψ HKs ; idestruct HKs as Xs₁ HKs ; idestruct HKs as Xs₂ HKs.
    idestruct HKs as HFalse HKs.
    icontradict HFalse.
Qed.

Hint Rewrite from_list_nil.

Theorem adequacy t₁ t₂ T :
⊨ ⟦ empty ∅→ ∅→ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # [] ⟧ →
Xs_tm t₁ = \{} →
∀ ξ₁ (v₁ : val0), step_refl_tran ⟨[], t₁⟩ ⟨ξ₁, v₁⟩ →
∃ ξ₂ (v₂ : val0), step_refl_tran ⟨[], t₂⟩ ⟨ξ₂, v₂⟩.
Proof.
intros Ht Closed_t₁ ξ₁ v₁ Step_t₁.
apply step_refl_tran_to_step_n in Step_t₁.
destruct Step_t₁ as [n Step_t₁].
eapply 𝓞_is_adequate with (ξ₁ := []) ; [ |constructor|crush|exact Step_t₁].
specialize (Ht n).
eapply n_adequacy with (Ξ := empty) ; [split;crush|eauto].
Qed.

End section_logref_is_adequate.


(* ******************************************************************************* *)
(** * Fiber category of a displayed bicategory whose displayed 2-cells form a
      proposition. In addition, we ask the displayed bicategory to be locally
      univalent and to be equipped with a local iso-cleaving.
 ********************************************************************************* *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Section Discrete_Fiber_Precategory.
  Context {C : bicat}.

  Variable (D : disp_prebicat C)
           (h : local_iso_cleaving D)
           (c : C).

  Definition discrete_fiber_ob_mor : precategory_ob_mor.
  Proof.
    use tpair.
    - exact (D c).
    - cbn. exact (λ (d : D c) (d' : D c), d -->[identity c] d').
  Defined.

  Definition idempunitor : invertible_2cell (identity c) (identity c · identity c).
  Proof.
    exists (linvunitor (identity c)).
    apply is_invertible_2cell_linvunitor.
  Defined.

  Definition discrete_fiber_precategory_data : precategory_data.
  Proof.
    exists discrete_fiber_ob_mor.
    split; cbn.
    - intro d. exact (id_disp d).
    - intros x y z ff gg.
      use (local_iso_cleaving_1cell h).
      + exact (identity c · identity c).
      + exact (ff ;; gg).
      + exact idempunitor.
  Defined.
End Discrete_Fiber_Precategory.

Section Discrete_Fiber.
Context {C : bicat}.

  Variable (D : disp_bicat C)
           (HD : disp_2cells_isaprop D)
           (HD_2_1 : disp_univalent_2_1 D)
           (h : local_iso_cleaving D)
           (c : C).

  (** Laws of category *)

  (** Left unitality *)
  Definition discrete_fiber_lunitor
             {d d' : D c}
             (ff : d -->[ id₁ c] d')
    : (local_iso_cleaving_1cell h (id_disp d;; ff) (idempunitor c))
        ==>[ id₂ (id₁ c)] ff.
  Proof.
    set (PP := disp_local_iso_cleaving_invertible_2cell h (id_disp d;; ff) (idempunitor c)).
    set (RR := PP •• disp_lunitor ff).
    assert (Heq : idempunitor c • lunitor (identity c) = id2 (identity c)).
    { abstract (apply linvunitor_lunitor). }
    exact (transportf (λ x, _ ==>[x] _) Heq RR).
  Defined.

  Definition discrete_fiber_linvunitor
             {d d' : D c}
             (ff : d -->[ id₁ c] d')
    : ff ==>[id₂ (id₁ c) ]
         (local_iso_cleaving_1cell h (id_disp d;; ff) (idempunitor c)).
  Proof.
    set (PP := disp_inv_cell
                 (disp_local_iso_cleaving_invertible_2cell
                    h
                    (id_disp d;; ff) (idempunitor c))).
    assert (Heq : linvunitor (identity c) • (idempunitor c)^-1 = id2 (identity c)).
    { abstract (apply linvunitor_lunitor). }
    exact (transportf (λ x, _ ==>[x] _) Heq (disp_linvunitor ff •• PP)).
  Defined.

  Definition discrete_fiber_lunitor_disp_invertible
             {d d' : D c}
             (ff : d -->[ id₁ c] d')
    : disp_invertible_2cell
        (id2_invertible_2cell (id₁ c))
        (local_iso_cleaving_1cell h (id_disp d;; ff) (idempunitor c))
        ff.
  Proof.
    use tpair.
    - exact (discrete_fiber_lunitor ff).
    - use tpair.
      + exact (discrete_fiber_linvunitor ff).
      + abstract (split ; apply HD).
  Defined.

  (** Right unitality *)
  Definition discrete_fiber_runitor
             {d d' : D c}
             (ff : d -->[ id₁ c] d')
    : (local_iso_cleaving_1cell h (ff;;id_disp d') (idempunitor c))
        ==>[ id₂ (id₁ c)] ff.
  Proof.
    assert (Heq : idempunitor c • runitor (identity c) = id2 (identity c)).
    { abstract (cbn
                ; rewrite <- lunitor_runitor_identity, linvunitor_lunitor
                ; reflexivity).
    }
    set (PP := disp_local_iso_cleaving_invertible_2cell h (ff;; id_disp d') (idempunitor c)).
    exact (transportf (λ x, _ ==>[x] _) Heq (PP •• disp_runitor ff)).
  Defined.

  Definition discrete_fiber_rinvunitor
             {d d' : D c}
             (ff : d -->[ id₁ c] d')
    : ff ==>[ id₂ (id₁ c) ]
         (local_iso_cleaving_1cell h (ff;;id_disp d') (idempunitor c)).
  Proof.
    set (PP := disp_inv_cell
                 (disp_local_iso_cleaving_invertible_2cell
                    h (ff;; id_disp d') (idempunitor c))).
    assert (Heq : rinvunitor (identity c) • (idempunitor c)^-1 = id2 (identity c)).
    { unfold idempunitor. cbn.
      abstract (rewrite lunitor_runitor_identity, rinvunitor_runitor
                ; reflexivity).
    }
    exact (transportf (λ x, _ ==>[x] _) Heq (disp_rinvunitor ff •• PP)).
  Defined.

  Definition discrete_fiber_runitor_disp_invertible
             {d d' : D c}
             (ff : d -->[ id₁ c] d')
    : disp_invertible_2cell
        (id2_invertible_2cell (id₁ c))
        (local_iso_cleaving_1cell h (ff;;id_disp d') (idempunitor c))
        ff.
  Proof.
    use tpair.
    - exact (discrete_fiber_runitor ff).
    - use tpair.
      + exact (discrete_fiber_rinvunitor ff).
      + abstract (split ; apply HD).
  Defined.

  (** Associativity *)
  Definition discrete_fiber_lassociator
             {d0 d1 d2 d3 : D c}
             (ff : d0 -->[ id₁ c] d1)
             (gg : d1 -->[ id₁ c] d2)
             (hh : d2 -->[ id₁ c] d3)
    : local_iso_cleaving_1cell
        h
        (ff;; local_iso_cleaving_1cell h (gg;; hh) (idempunitor c))
        (idempunitor c)
      ==>[ id₂ (id₁ c)]
      local_iso_cleaving_1cell h
        (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh)
        (idempunitor c).
  Proof.
    assert ((idempunitor c
               • (identity c ◃ idempunitor c))
              • lassociator _ _ _
              • ((lunitor _ ▹ identity c)
                   • lunitor _) = id2 _) as Heq.
      {
        abstract
          (cbn ;
           rewrite !lwhisker_hcomp, !rwhisker_hcomp ;
           rewrite !vassocl ;
           rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ;
           rewrite triangle_r_inv ;
           rewrite !vassocl ;
           rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ;
           rewrite rassociator_lassociator, id2_left ;
           rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite <- hcomp_vcomp ;
           rewrite <- lunitor_V_id_is_left_unit_V_id ;
           rewrite id2_left, linvunitor_lunitor ;
           rewrite hcomp_identity, id2_left ;
           apply linvunitor_lunitor
          ).
      }
      refine (transportf (λ z, _ ==>[ z ] _) Heq _).
      cbn.
      refine (_ •• disp_lassociator ff gg hh •• _).
      - refine (_ •• _).
        + exact (disp_local_iso_cleaving_invertible_2cell
                   h (ff;;local_iso_cleaving_1cell h (gg;; hh) (idempunitor c))
                   (idempunitor c)).
        + refine (disp_lwhisker _ _).
          exact (disp_local_iso_cleaving_invertible_2cell
                   h (gg ;; hh) (idempunitor c)).
      - refine (_ •• _).
        + refine (disp_rwhisker _ _).
          exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell
                                  h (ff ;; gg) (idempunitor c))).
        + exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell
                                  h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);;
                                                              hh) (idempunitor c))).
  Defined.

  Definition discrete_fiber_rassociator
             {d0 d1 d2 d3 : D c}
             (ff : d0 -->[ id₁ c] d1)
             (gg : d1 -->[ id₁ c] d2)
             (hh : d2 -->[ id₁ c] d3)
    : local_iso_cleaving_1cell
         h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh)
         (idempunitor c)
      ==>[ id₂ (id₁ c)]
      local_iso_cleaving_1cell
        h
        (ff;; local_iso_cleaving_1cell h (gg;; hh) (idempunitor c)) (idempunitor c).
  Proof.
    assert ((idempunitor c • (idempunitor c ▹ identity c))
              • rassociator _ _ _
              • ((identity c ◃ lunitor _)
                   • lunitor _)
            = id2 _) as Heq.
    {
      abstract
        (cbn ;
         rewrite !lwhisker_hcomp, !rwhisker_hcomp ;
         rewrite lunitor_V_id_is_left_unit_V_id ;
         rewrite !vassocl ;
         rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ;
         rewrite <- triangle_l_inv ;
         rewrite !vassocl ;
         rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ;
         rewrite lassociator_rassociator, id2_left ;
         rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
         rewrite <- hcomp_vcomp ;
         rewrite id2_left, linvunitor_lunitor ;
         rewrite hcomp_identity, id2_left ;
         rewrite <- lunitor_V_id_is_left_unit_V_id ;
         rewrite linvunitor_lunitor ;
         reflexivity
        ).
    }
    refine (transportf (λ z, _ ==>[ z ] _) Heq _).
    cbn.
    refine (_ •• disp_rassociator ff gg hh •• _).
    - refine (disp_local_iso_cleaving_invertible_2cell
                h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh) (idempunitor c)
                •• _).
      refine (disp_rwhisker _ _).
      exact (disp_local_iso_cleaving_invertible_2cell h (ff ;; gg) (idempunitor c)).
    - refine (_ •• _).
      + refine (disp_lwhisker _ _).
        exact (disp_inv_cell
                 (disp_local_iso_cleaving_invertible_2cell
                    h (gg ;; hh) (idempunitor c))).
      + exact (disp_inv_cell ((disp_local_iso_cleaving_invertible_2cell
                                 h
                                 (ff;;local_iso_cleaving_1cell
                                    h (gg;; hh)
                                    (idempunitor c))
                                 (idempunitor c)))).
  Defined.

  Definition discrete_fiber_lassociator_disp_invertible
             {d0 d1 d2 d3 : D c}
             (ff : d0 -->[ id₁ c] d1)
             (gg : d1 -->[ id₁ c] d2)
             (hh : d2 -->[ id₁ c] d3)
    : disp_invertible_2cell
        (id2_invertible_2cell (id₁ c))
        (local_iso_cleaving_1cell
           h
           (ff;; local_iso_cleaving_1cell h (gg;; hh) (idempunitor c))
           (idempunitor c))
        (local_iso_cleaving_1cell
           h
           (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh)
           (idempunitor c)).
  Proof.
    use tpair.
    - exact (discrete_fiber_lassociator ff gg hh).
    - use tpair.
      + exact (discrete_fiber_rassociator ff gg hh).
      + abstract (split ; apply HD).
  Defined.

  Definition discrete_fiber_is_precategory
    : is_precategory (discrete_fiber_precategory_data D h c).
  Proof.
    apply is_precategory_one_assoc_to_two.
    repeat split.
    - cbn ; intros a b f.
      exact (disp_isotoid_2_1
               D HD_2_1
               (idpath _)
               _
               _
               (discrete_fiber_lunitor_disp_invertible f)).
    - cbn ; intros a b f.
      exact (disp_isotoid_2_1
               D HD_2_1
               (idpath _)
               _
               _
               (discrete_fiber_runitor_disp_invertible f)).
    -intros d0 d1 d2 d3 ff gg hh.
      exact (disp_isotoid_2_1
               D HD_2_1
               (idpath _)
               _
               _
               (discrete_fiber_lassociator_disp_invertible ff gg hh)).
  Qed.

  Definition discrete_fiber_precategory : precategory.
  Proof.
    use make_precategory.
    - exact (discrete_fiber_precategory_data D h c).
    - exact discrete_fiber_is_precategory.
  Defined.

  Definition discrete_fiber_category : category.
  Proof.
    use make_category.
    - exact discrete_fiber_precategory.
    - intros x y f g.
      apply (isofhlevelweqb 1 (make_weq _ (HD_2_1 _ _ _ _ (idpath _) x y f g))).
      use isofhleveltotal2.
      + apply HD.
      + intros.
        apply isaprop_is_disp_invertible_2cell.
  Defined.

  Section IsoInDiscreteFiber.
    Context {x y : discrete_fiber_category}
            (f : x --> y)
            (Hf : disp_left_adjoint_equivalence
                    (internal_adjoint_equivalence_identity c)
                    f).

    Let finv : y --> x := pr11 Hf.

    Let η : disp_invertible_2cell
              (linvunitor_invertible_2cell _)
              (id_disp x)
              (f ;; pr11 Hf)
      := pr121 Hf ,, pr122 Hf.

    Let ε : disp_invertible_2cell
              (lunitor_invertible_2cell _)
              (pr11 Hf ;; f)
              (id_disp y)
      := pr221 Hf ,, pr222 Hf.

    Local Lemma is_z_iso_discrete_fiber_left_inv
      : finv · f = id₁ y.
    Proof.
      use (disp_isotoid_2_1 D HD_2_1 (idpath _)).
      refine (transportf
                (λ z, disp_invertible_2cell z _ _)
                _
                (vcomp_disp_invertible
                   (disp_local_iso_cleaving_invertible_2cell
                      h
                      (finv ;; f)
                      (idempunitor c))
                   ε)).
      use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn.
      apply linvunitor_lunitor.
    Qed.

    Local Lemma is_z_iso_discrete_fiber_right_inv
      : f · finv = id₁ x.
    Proof.
      use (disp_isotoid_2_1 D HD_2_1 (idpath _)).
      refine (transportf
                (λ z, disp_invertible_2cell z _ _)
                _
                (vcomp_disp_invertible
                   (disp_local_iso_cleaving_invertible_2cell
                      h
                      (f ;; finv)
                      (idempunitor c))
                   (inverse_of_disp_invertible_2cell η))).
      use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn.
      apply linvunitor_lunitor.
    Qed.

    Definition is_z_iso_discrete_fiber
      : is_z_isomorphism f.
    Proof.
      use make_is_z_isomorphism.
      - exact finv.
      - split.
        + exact is_z_iso_discrete_fiber_right_inv.
        + exact is_z_iso_discrete_fiber_left_inv.
    Defined.
  End IsoInDiscreteFiber.
End Discrete_Fiber.


(** * Mapping predicates over [StringLike] things *)
Require Import Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Basics.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.StringLike.ForallChars.
Require Import Fiat.Parsers.StringLike.FirstChar.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope string_like_scope.

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

  Definition is_first_char_such_that
             (might_be_empty : Prop)
             (str : String)
             (n : nat)
             P
    := forall_chars (take n str) (fun ch => ~P ch)
       /\ ((for_first_char (drop n str) P /\ n < length str)
           \/ (might_be_empty /\ length str <= n)).

  Lemma first_char_such_that_past_end
        (might_be_empty : Prop)
        (str : String)
        (n : nat)
        P
        (H : length str <= n)
        (H' : is_first_char_such_that might_be_empty str n P)
  : might_be_empty.
  Proof.
    destruct_head_hnf and.
    destruct_head_hnf or;
      destruct_head_hnf and; trivial.
    exfalso; omega.
  Qed.

  Lemma first_char_such_that_0
        {might_be_empty : Prop}
        {str : String}
        {P}
  : is_first_char_such_that might_be_empty str 0 P
    <-> (for_first_char str P /\ (might_be_empty \/ length str > 0)).
  Proof.
    unfold is_first_char_such_that.
    rewrite drop_0.
    split; intro;
    destruct_head_hnf and;
    destruct_head_hnf or;
      destruct_head_hnf and; repeat split; trivial;
    try solve [ left; assumption
              | right; omega
              | apply for_first_char_nil; omega
              | apply forall_chars_nil; rewrite ?take_length; try apply Min.min_case_strong; intros; omega
              | destruct (length str);
                try solve [ left; repeat split; eauto; omega
                          | right; repeat split; eauto; omega ] ].
  Qed.

  Lemma is_first_char_such_that_drop
        (might_be_empty : Prop)
        (str : String)
        (n : nat)
        P
  : is_first_char_such_that might_be_empty str (S n) P
    <-> (is_first_char_such_that might_be_empty (drop 1 str) n P /\ for_first_char str (fun ch => ~P ch)).
  Proof.
    generalize dependent str; induction n; intros;
    unfold is_first_char_such_that in *;
    [
    | specialize (IHn (drop 1 str));
      rewrite (forall_chars__split _ _ 1) ];
    repeat match goal with
             | _ => assumption
             | _ => intro
             | _ => progress destruct_head and
             | _ => progress destruct_head iff
             | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
             | _ => progress simpl in *
             | [ H : _ |- _ ] => apply forall_chars__impl__for_first_char, for_first_char__take in H; assumption
             | [ H : for_first_char (take (S _) _) _ |- _ ] => apply for_first_char__take in H
             | [ H : for_first_char ?str ?P, H' : for_first_char ?str ?P' |- _ ]
               => destruct (fun H0 => for_first_char_combine (T := False) H0 H H'); cbv beta; [ tauto | clear H H' | tauto ]
             | [ H : ?x = 0 |- context[?x] ] => rewrite H
             | _ => apply forall_chars_nil; [ (rewrite ?take_length, ?drop_length; reflexivity).. ]
             | _ => omega
             | [ H : ?A /\ ?B -> ?C |- _ ] => specialize (fun x y => H (conj x y))
             | [ H : _ -> ?A /\ ?B -> ?C |- _ ] => specialize (fun a x y => H a (conj x y))
             | [ H : _ |- _ ] => progress rewrite ?drop_0, ?drop_drop, ?take_take, ?drop_length, ?take_length, ?drop_take, ?Nat.add_1_r, ?Nat.le_sub_le_add_r, <- ?(Plus.plus_comm 2), <- ?Nat.lt_add_lt_sub_r in H
             | _ => progress rewrite ?drop_0, ?drop_drop, ?take_take, ?drop_length, ?take_length, ?drop_take, ?Nat.add_1_r, ?Nat.le_sub_le_add_r, <- ?(Plus.plus_comm 2), <- ?Nat.lt_add_lt_sub_r
             | _ => progress destruct_head or
             | [ |- _ /\ _ ] => split
             | [ |- _ <-> _ ] => split
             | _ => left; repeat split; trivial; omega
             | _ => right; repeat split; trivial; omega
             | _ => apply for_first_char__for_first_char__iff_short;
                   [ rewrite take_length; destruct (length str); simpl in *; omega
                   | apply -> (for_first_char__take 0); assumption ]
           end.
  Qed.

  Global Instance is_first_char_such_that_Proper
  : Proper (impl ==> beq ==> eq ==> pointwise_relation _ iff ==> impl) is_first_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_first_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel impl.
    setoid_subst_rel (pointwise_relation Char iff).
    assumption.
  Qed.

  Global Instance is_first_char_such_that_Proper_flip
  : Proper (flip impl ==> beq ==> eq ==> pointwise_relation _ iff ==> flip impl) is_first_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_first_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel (pointwise_relation Char iff).
    unfold flip in *.
    setoid_subst_rel impl.
    assumption.
  Qed.

  Global Instance is_first_char_such_that_Proper_iff
  : Proper (iff ==> beq ==> eq ==> pointwise_relation _ iff ==> iff) is_first_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_first_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel iff.
    setoid_subst_rel (pointwise_relation Char iff).
    reflexivity.
  Qed.

  Lemma is_first_char_such_that_eq_nat_iff
        (might_be_empty : Prop)
        (str : String)
        (n n' : nat)
        P
        (H0 : is_first_char_such_that might_be_empty str n P)
        (H1 : is_first_char_such_that might_be_empty str n' P)
  : n = n' \/ (n >= length str /\ n' >= length str /\ might_be_empty).
  Proof.
    generalize dependent n'; generalize dependent str; induction n; intros.
    { destruct n'; intros.
      { left; reflexivity. }
      { right.
        unfold is_first_char_such_that in *.
        repeat match goal with
                 | _ => assumption
                 | [ H : and _ _ |- _ ] => destruct H
                 | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
                 | [ H : _ |- _ ] => rewrite drop_0 in H
                 | [ H : _ |- _ ] => apply forall_chars__impl__for_first_char in H
                 | [ H : for_first_char (take (S _) _) _ |- _ ] => apply for_first_char__take in H
                 | [ H : for_first_char ?str ?P, H' : for_first_char ?str ?P' |- _ ]
                   => destruct (fun H0 => for_first_char_combine (T := False) H0 H H'); cbv beta; [ tauto | clear H H' | tauto ]
                 | [ H : ?x = 0 |- context[?x] ] => rewrite H
                 | _ => omega
                 | _ => progress destruct_head and
                 | _ => progress destruct_head or
                 | [ |- _ /\ _ ] => split
               end. } }
    { specialize (IHn (drop 1 str)).
      destruct n'; [ right; case_eq (length str) | ];
      repeat match goal with
               | [ H : is_first_char_such_that _ _ (S _) _ |- _ ] => apply is_first_char_such_that_drop in H
               | _ => progress destruct_head and
               | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
               | _ => intro
               | [ H : _ |- _ ] => progress rewrite ?drop_length, ?Nat.le_sub_le_add_r in H
               | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H'
               | _ => progress simpl in *
               | [ |- _ /\ _ ] => split; try omega; []
               | _ => eapply first_char_such_that_past_end; [ | eassumption ]; omega
               | [ H : _ |- _ ] => unique pose proof (proj1 (proj1 first_char_such_that_0 H))
               | [ H : for_first_char ?str ?P, H' : for_first_char ?str ?P' |- _ ]
                 => destruct (fun H_new => for_first_char_combine (T := False) H_new H H'); cbv beta; [ tauto | clear H H' | tauto ]
               | _ => omega
               | _ => progress unfold ge in *
               | [ H : forall n', is_first_char_such_that ?P ?str n' ?P' -> _, H' : is_first_char_such_that ?P ?str _ ?P' |- _ ]
                 => specialize (H _ H')
               | _ => progress subst
               | _ => left; reflexivity
               | _ => right; repeat split; trivial; omega
               | _ => progress destruct_head or
             end. }
  Qed.
End is_first_char_such_that.

Global Opaque is_first_char_such_that.

Definition find_first_char_such_that' {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
           (P : Char -> bool)
           (len : nat)
: String -> nat
  := nat_rect
       (fun _ => String -> nat)
       (fun _ => 0)
       (fun len' find_first_char_such_that' str
        => let otherwise := S (find_first_char_such_that' str) in
           match get (length str - S len') str with
             | Some ch => if P ch
                          then 0
                          else otherwise
             | None => otherwise
           end)
       len.

Lemma find_first_char_such_that'_S {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
      (P : Char -> bool)
      (len : nat)
      (str : String)
: find_first_char_such_that' P (S len) str
  = let otherwise := S (find_first_char_such_that' P len str) in
    match get (length str - S len) str with
      | Some ch => if P ch
                   then 0
                   else otherwise
      | None => otherwise
    end.
Proof.
  reflexivity.
Qed.

Definition find_first_char_such_that {Char} {HSLM} {HSL} str P
  := @find_first_char_such_that' Char HSLM HSL P (length str) str.


Require Import
  Fiat.Common
  Fiat.Computation.Core
  Fiat.Computation.SetoidMorphisms.

Open Scope comp_scope.

Fixpoint foldComp `(f : A -> B -> Comp A) (s : A) (l : list B) : Comp A :=
  match l with
    | nil => ret s
    | cons y ys => f s y >>= fun s' => foldComp f s' ys
  end.

Add Parametric Morphism A B : (@foldComp A B)
  with signature
  (eq ==> eq ==> @refine A) ++> eq ++> eq ==> (@refine A)
    as refine_foldComp_mor.
Proof.
  intros x y H z ls.
  revert z.
  revert ls.
  induction ls; intros; simpl; trivial.
    reflexivity.
  f_equiv.
    apply H; trivial.
  unfold pointwise_relation in *; intros.
  apply IHls.
Qed.

Add Parametric Morphism A B : (@foldComp A B)
  with signature
  (eq ==> eq ==> @refineEquiv A)
    ++> eq ++> eq ==> (@refineEquiv A)
    as refineEquiv_foldComp_mor.
Proof.
  intros x y H z ls.
  revert z.
  revert ls.
  induction ls; intros; simpl; trivial.
  { reflexivity. }
  { apply refineEquiv_bind.
    { apply H; trivial. }
    { unfold pointwise_relation in *; intros.
      apply IHls. } }
Qed.

Add Parametric Morphism A B : (@foldComp A B)
  with signature
  (Basics.flip eq ==> eq ==> Basics.flip (@refine A))
    ++> eq ++> (Basics.flip eq) ==> (Basics.flip (@refine A))
    as refine_foldComp_flip_mor.
Proof.
  intros x y H z ls0 ls1 Heqe.
  revert z.
  revert Heqe.
  revert ls0.
  revert ls1.
  induction ls1; intros; simpl; trivial.
    rewrite <- Heqe; simpl.
    reflexivity.
  rewrite <- Heqe; simpl.
  f_equiv.
    apply H; trivial.
  unfold pointwise_relation in *; intros.
  apply IHls1; trivial.
Qed.

Lemma refine_foldComp :
  forall (A B : Type) (s : A) (l : list B) (f g : A -> B -> Comp A),
    pointwise_relation2 refine f g
      -> refine (foldComp f s l) (foldComp g s l).
Proof.
  intros.
  subst.
  f_equiv.
  unfold pointwise_relation2 in H.
  intros st0 st1 Hst x0 x1 Hx.
  rewrite H.
  subst.
  reflexivity.
Qed.

Lemma refine_foldComp_bind :
  forall (A B : Type) (s : A) (l : list B) (f f' : A -> B -> Comp A)
         ResultT (k k' : A -> Comp ResultT),
    pointwise_relation2 refine f f'
      -> pointwise_relation _ refine k k'
      -> refine (x <- foldComp f s l; k x) (x <- foldComp f' s l; k' x).
Proof.
  intros.
  rewrite refine_foldComp.
    f_equiv.
    exact H0.
  exact H.
Qed.

Require Import Fiat.ADT.

Lemma refine_foldComp_fold :
  forall A B (st : A) (f : A -> B -> A) (xs : list B),
    refineEquiv (foldComp (fun st x => ret (f st x)) st xs)
                (ret (List.fold_left f xs st)).
Proof.
  intros.
  generalize dependent st.
  induction xs; simpl; intros.
    reflexivity.
  autorewrite with monad laws.
  apply IHxs.
Qed.

Require Import Coq.Lists.List.

Lemma refine_foldComp_fold_left_helper :
  forall A (xs : list A) S (f : S -> A -> Comp S) (z : Comp S),
    refineEquiv (x <- z; foldComp f x xs)
                (fold_left (fun acc x => s <- acc; f s x) xs z).
Proof.
  intros.
  generalize dependent z.
  induction xs; simpl; intros.
    autorewrite with monad laws.
    reflexivity.
  rewrite <- IHxs.
  autorewrite with monad laws.
  reflexivity.
Qed.

Lemma refine_foldComp_fold_left :
  forall A (xs : list A) S (f : S -> A -> Comp S) (z : S),
    refineEquiv (foldComp f z xs)
                (fold_left (fun acc x => s <- acc; f s x) xs (ret z)).
Proof.
  intros.
  rewrite <- refine_foldComp_fold_left_helper.
  autorewrite with monad laws.
  reflexivity.
Qed.

Lemma refine_bind_pick {A B} :
  forall (P : A -> Prop) (c : Comp B) (c' : A -> Comp B),
    (forall a', P a' -> refine c (c' a'))
      -> refine c (a <- {a | P a}; c' a).
Proof.
  unfold refine; intros.
  computes_to_inv; eauto.
Qed.

Lemma refine_foldComp_invariant' :
   forall {A S S'}
          (P : S -> S' -> Prop)
          (f : S -> A -> Comp S)
          (f' : S' -> A -> Comp S')
          (xs : list A)
          (z : S) (z' : S') ResultT
          (k : S -> Comp ResultT)
          (k' : S' -> Comp ResultT),
     (* refined function preserves invariant *)
     (forall z z',
         P z z'
         -> pointwise_relation _ refine
              (fun a => z'' <- f z a; {z' | P z'' z'})
              (fun a => f' z' a))
      -> (forall st_n st_n', P st_n st_n' -> refine (k st_n) (k' st_n'))
     -> P z z'
     -> refine (st_n  <- foldComp f  z  xs; k  st_n)
               (st_n' <- foldComp f' z' xs; k' st_n').
Proof.
  induction xs; intros;
  autorewrite with monad laws.
    eauto.
  rewrite <- (H _ _ H1 a), refineEquiv_bind_bind.
  f_equiv; intros x.
  apply refine_bind_pick; intros.
  apply IHxs; eauto.
Qed.

Corollary refine_foldComp_invariant :
  forall {A S S'} (P : S -> S' -> Prop)
         (f : S -> A -> Comp S)
         (f' : S' -> A -> Comp S')
         (z : S) (xs : list A),
    pointwise_relation2 refine (fun st_o a =>
                                  st_n <- f st_o a;
                                  {st_n' | P st_n st_n'})
                               (fun st_o a =>
                                  st_o' <- {st_o' | P st_o st_o'};
                                  f' st_o' a)
      -> refine (st_n <- foldComp f z xs;
                 {st_n' | P st_n st_n'})
                (z' <- { z' | P z z'};
                 foldComp f' z' xs).
Proof.
  intros.
  apply refine_bind_pick; intros.
  setoid_rewrite <- refineEquiv_unit_bind.
  simplify with monad laws.
  eapply refine_foldComp_invariant'; eauto; intros.
    intros ?.
    rewrite (H _ _).
    refine pick val z'; trivial.
    simplify with monad laws.
    reflexivity.
  refine pick val st_n'; trivial.
  reflexivity.
Qed.