              Require Import Classical
                             ClassicalEpsilon
                             Program.
From CompCert Require Import Coqlib.
From Utils    Require Import Smallstep.

Create HintDb semMetaThy.

Inductive behaviour {value error: Type} : Type :=
  | Terminates: value -> behaviour
  | Faultstops: error -> behaviour
  | Diverges: behaviour
  | Goes_wrong: behaviour.

Inductive state_behaves (L: semantics) (s: state L)
  : behaviour -> Prop :=
  | state_terminates: forall s' res,
      Star L s s' -> final_state L s' res ->
      state_behaves L s (Terminates res)
  | state_fstops: forall s' err,
      Star L s s' -> error_state L s' err ->
      state_behaves L s (Faultstops err)
  | state_diverges: forall s',
      Star L s s' -> Forever L s' ->
      state_behaves L s Diverges
  | state_goes_wrong: forall s',
      Star L s s' ->
      Nostep L s' ->
      (forall res, ~final_state L s' res) ->
      (forall err, ~error_state L s' err) ->
      state_behaves L s Goes_wrong.

Definition not_wrong {value error: Type}
                     (beh: @behaviour value error) :=
  match beh with
  | Goes_wrong => False
  | _          => True
  end.

Definition behaviour_matches
  {v1 e1 v2 e2: Type}
  (mv: v1 -> v2 -> Prop)
  (me: e1 -> e2 -> Prop)
  (beh1: @behaviour v1 e1)
  (beh2: @behaviour v2 e2) : Prop :=
  match beh1, beh2 with
  | Diverges  , Diverges
  | Goes_wrong, Goes_wrong => True
  | Terminates res1, Terminates res2 => mv res1 res2
  | Faultstops err1, Faultstops err2 => me err1 err2
  | _, _ => False
  end.

Definition behaviour_improves
  {v1 e1 v2 e2: Type}
  (mv: v1 -> v2 -> Prop)
  (me: e1 -> e2 -> Prop)
  (beh1: @behaviour v1 e1)
  (beh2: @behaviour v2 e2) : Prop :=
  match beh1, beh2 with
  | Goes_wrong, _
  | Diverges  , Diverges => True
  | Terminates res1, Terminates res2 => mv res1 res2
  | Faultstops err1, Faultstops err2 => me err1 err2
  | _, _ => False
  end.
Hint Unfold behaviour_matches behaviour_improves : semMetaThy.

Lemma matching_behaviour_improves:
  forall
  {v1 e1 v2 e2: Type}
  (mv: v1 -> v2 -> Prop)
  (me: e1 -> e2 -> Prop)
  (beh1: @behaviour v1 e1)
  (beh2: @behaviour v2 e2),
  @behaviour_matches  v1 e1 v2 e2 mv me beh1 beh2 ->
  @behaviour_improves v1 e1 v2 e2 mv me beh1 beh2.
Proof ltac:(
  destruct beh1, beh2; simpl;auto).

Lemma behaviour_improves_refl:
  forall {v e: Type}
  (mv: v -> v -> Prop)
  (me: e -> e -> Prop) beh,
  (forall x, mv x x) ->
  (forall x, me x x) ->
  @behaviour_improves v e v e mv me beh beh.
Proof with auto with semMetaThy.
  destruct beh; intros mv_refl me_refl...
Qed.

Lemma behaviour_improves_trans:
  forall {v1 e1 v2 e2 v3 e3: Type}
  (mv12: v1 -> v2 -> Prop)
  (me12: e1 -> e2 -> Prop)
  (mv23: v2 -> v3 -> Prop)
  (me23: e2 -> e3 -> Prop)
    (beh1: @behaviour v1 e1)
    (beh2: @behaviour v2 e2)
    (beh3: @behaviour v3 e3),
  @behaviour_improves v1 e1 v2 e2 mv12 me12 beh1 beh2 ->
  @behaviour_improves v2 e2 v3 e3 mv23 me23 beh2 beh3 ->
  @behaviour_improves v1 e1 v3 e3 (fun x1 x3 => exists x2, mv12 x1 x2 /\ mv23 x2 x3)
(fun x1 x3 => exists x2, me12 x1 x2 /\ me23 x2 x3)
 beh1 beh3.
Proof with auto.
  destruct beh1, beh2, beh3;
  try solve [inversion 1|auto with semMetaThy];
  unfold behaviour_improves in *; intros.
  - exists v0...
  - exists e0...
Qed.

Section PROGRAM_BEHAVIOURS.
Variable L: semantics.

Inductive program_behaves: behaviour -> Prop :=
  | program_runs: forall s beh,
      initial_state L s -> state_behaves L s beh ->
      program_behaves beh
  | program_goes_initially_wrong:
      (forall s, ~initial_state L s) ->
      program_behaves Goes_wrong.

Lemma diverges_forever:
  forall s0,
  (forall s1, Star L s0 s1 ->
   exists s2, Step L s1 s2) ->
  Forever L s0.
Proof with eauto.
  cofix COINDHYP; intros.
  destruct (H s0) as [s1 ST].
  - constructor.
  - econstructor...
    apply COINDHYP. intros.
    eapply H. eapply one_star_star...
Qed.

Lemma state_behaves_exists:
  forall s, exists beh, state_behaves L s beh.
Proof with eauto; try econstructor; eauto.
  intros s0.
  destruct (classic
    (forall s1, Star L s0 s1 ->
     exists s2, Step L s1 s2)).
  - exists Diverges. econstructor;
    [ econstructor
    | apply diverges_forever]...
  - destruct (not_all_ex_not _ _ H)
      as [s1 A]; clear H.
    destruct (not_all_ex_not _ _ A)
      as [t1 H]; clear A.
    destruct (classic
      (exists r, final_state L s1 r))
      as [[r FINAL] | NOTFINAL].
    + exists (Terminates r)...
    + destruct (classic
        (exists e, error_state L s1 e))
        as [[e ERR] | NOTERR].
      * exists (Faultstops e)...
      * exists Goes_wrong...
        intros s'.
        exact (not_ex_all_not _ _ H s').
Qed.

Theorem program_behaves_exists:
  exists beh, program_behaves beh.
Proof with eauto.
  destruct (classic
    (exists s, initial_state L s))
    as [[s0 INIT] | NOTINIT].
(* 1. Initial state is defined. *)
  - destruct (state_behaves_exists s0) as [beh SB].
    exists beh; econstructor...
(* 2. Initial state is undefined *)
  - exists Goes_wrong.
    apply program_goes_initially_wrong.
    intros. eapply not_ex_all_not...
Qed.

Theorem program_behaves_one_of_four:
  (exists v, program_behaves (Terminates v)) \/
  (exists e, program_behaves (Faultstops e)) \/
  program_behaves Diverges \/
  program_behaves Goes_wrong.
Proof with eauto.
  destruct program_behaves_exists as [[] ?];
  [
  | right
  | right; right
  | right; right; right]...
Qed.

(* Theorem program_behaves_unique_Terminates:
  (exists v, program_behaves (Terminates v)) ->
  (forall e, ~ program_behaves (Faultstops e)) /\
  ~ program_behaves Diverges /\
  ~ program_behaves Goes_wrong.
Proof with auto.
  intros [beh ?].
  repeat split; intros * ?.
  inversion H; inversion H0; subst. *)

End PROGRAM_BEHAVIOURS.

(* Variable match_values: (matching_of value L1 L2).
Variable match_errors: (matching_of error L1 L2).
 *)

Section FORWARD_SIMULATIONS.

Context L1 L2 index order match_values match_errors match_states
  (S: fsim_properties L1 L2 index order match_values match_errors match_states).

Local Notation b_improvs :=
(@behaviour_improves
  (value L1) (error L1)
  (value L2) (error L2)
  match_values match_errors).

Lemma forward_simulation_state_behaves:
  forall i s1 s2 beh1,
  match_states match_values match_errors i s1 s2 -> state_behaves L1 s1 beh1 ->
  exists beh2, state_behaves L2 s2 beh2
            /\ b_improvs beh1 beh2.
Proof with eauto.
  intros. inv H0.
  - (* termination *)
    exploit simulation_star... intros [i' [s2' [A B]]].
    exploit fsim_match_final_states... intros [res2 [FIN2 MV2]].
    exists (Terminates res2). split; [econstructor|]...
  - (* fault stop *)
    exploit simulation_star... intros [i' [s2' [A B]]].
    exploit fsim_match_error_states... intros [err2 [ERS2 ME2]].
    exists (Faultstops err2). split; [econstructor|]...
  - (* divergence *)
    exploit simulation_star... intros [i' [s2' [A B]]].
    exploit simulation_forever... intros.
    exists Diverges; split; simpl... econstructor...
  - (* going wrong *)
    exploit simulation_star... intros [i' [s2' [A B]]].
    destruct (state_behaves_exists L2 s2) as [beh' SB].
    exists beh'; split; simpl...
Qed.

End FORWARD_SIMULATIONS.

(*
Section bob.
Variable L1 L2 : semantics.

Context (* L1 L2 *) index order match_values match_errors match_states
  (S: fsim_properties L1 L2 index order match_values match_errors match_states).

Local Notation b_improvs :=
(@behaviour_improves
  (value L1) (error L1)
  (value L2) (error L2)
  match_values match_errors). *)

Theorem forward_simulation_behavior_improves:
  forall L1 L2 mv me,
  forward_simulation L1 L2 mv me ->
  forall beh1, program_behaves L1 beh1 ->
  exists beh2, program_behaves L2 beh2
  /\ behaviour_improves mv me beh1 beh2.
Proof with eauto.
  do 2 (inversion 1; subst).
  - (* initial state defined *)
    exploit (fsim_match_initial_states props)... intros [i [s' [INIT MATCH]]].
    exploit forward_simulation_state_behaves... intros [beh2 [SB Bimpl]].
    exists beh2; split... * econstructor...
  - (* initial state undefined *)
    destruct (classic (exists s', initial_state L2 s')) as
    [[s' INIT]| noINIT].
    + destruct (state_behaves_exists L2 s') as [beh' SB].
      exists beh'; split; simpl... * econstructor...
    + exists Goes_wrong; split; simpl...
      * apply program_goes_initially_wrong.
        intros * ?. apply noINIT; exists s...
Qed.

Corollary forward_simulation_same_safe_behavior:
  forall L1 L2 mv me,
  forward_simulation L1 L2 mv me ->
  forall beh1, program_behaves L1 beh1 ->
  not_wrong beh1 ->
    exists beh2, program_behaves L2 beh2
 /\ behaviour_matches mv me beh1 beh2.
Proof with eauto.
  intros.
  exploit forward_simulation_behavior_improves...
  intros [beh2 [A B]]. exists beh2; split...
  destruct beh1, beh2...
Qed.

Section BACKWARD_SIMULATIONS.

Context L1 L2 index order match_values match_errors match_states
    (S: bsim_properties L1 L2 index order match_values match_errors match_states).

(* Definition safe_along_behavior (s: state L1) (b: program_behaviour) : Prop :=
  forall s', Star L1 s s' ->
     (exists r, final_state L1 s' r)
  \/ (exists s'', Step L1 s' s'').

Remark safe_along_safe:
  forall s b, safe_along_behavior s b -> safe L1 s.
Proof with eauto.
  red. intros. eapply H...
Qed.
 *)

(* Remark star_safe_along:
  forall s b s',
  safe_along_behavior s b ->
  Star L1 s s' ->
  safe_along_behavior s' b.
Proof with eauto.
  red. intros. eapply H. eapply star_trans...
Qed. *)

Remark not_safe:
  forall s,
  ~ safe L1 s ->
  exists s',
     Star L1 s s'
  /\ Nostep L1 s'
  /\ (forall r, ~final_state L1 s' r)
  /\ (forall e, ~error_state L1 s' e).
Proof with eauto.
  intros.
  destruct (not_all_ex_not _ _ H) as [s' A]; clear H.
  destruct (not_all_ex_not _ _ A) as [B C]; clear A.
  destruct (not_or_and _ _ C) as [P Q]; clear C.
  exists s'. repeat split...
  - intros s''' ?. apply Q...
Qed.

Lemma backward_simulation_star:
  forall s2 s2', Star L2 s2 s2' ->
  forall i s1, match_states match_values match_errors i s1 s2 -> safe L1 s1 ->
  exists i', exists s1', Star L1 s1 s1'
          /\ match_states match_values match_errors i' s1' s2'.
Proof with eauto.
  induction 1; intros.
  - exists i, s1; split... apply star_refl.
  - exploit (bsim_simulation S)...
    intros [i' [s1' [A B]]].
    assert (Star L1 s0 s1'). {
      intuition.  apply plus_star...
    }
    exploit IHstar...
    + eapply star_safe...
    + intros [i'' [s2'' [C D]]].
      exists i'', s2''; split...
      eapply star_trans...
Qed.

Lemma backward_simulation_forever:
  forall i s1 s2,
  Forever L2 s2 -> match_states match_values match_errors i s1 s2 ->
  safe L1 s1 -> Forever L1 s1.
Proof with eauto.
  assert
  (forall i s1 s2,
    Forever L2 s2 -> match_states match_values match_errors i s1 s2 -> safe L1 s1 ->
    forever_N (step L1) order (globalenv L1) i s1). {
      cofix COINDHYP; intros. inv H.
      destruct (bsim_simulation S _ _ H2 _ H0 H1)
        as [i' [s2' [A B]]].
      destruct A as [C | [C D]].
      eapply forever_N_plus...
      eapply COINDHYP...
      eapply star_safe...
      apply plus_star...
      eapply forever_N_star...
      eapply COINDHYP...
      eapply star_safe... }
  intros.
  eapply forever_N_forever...
  eapply bsim_order_wf...
Qed.

Lemma backward_simulation_state_behaves:
  forall i s1 s2 beh2,
  match_states match_values match_errors i s1 s2 -> state_behaves L2 s2 beh2 ->
  exists beh1, state_behaves L1 s1 beh1
            /\ behaviour_improves match_values match_errors beh1 beh2.
Proof with eauto with semMetaThy.
  intros. destruct (classic (safe L1 s1)).
  - (* 1. Safe *)
    inv H0;
    exploit backward_simulation_star; eauto;
    intros [i' [s1' [A B]]].
    + (* termination *)
(*       exploit backward_simulation_star; eauto.
      intros [i' [s1' [A B]]]. *)
      exploit (bsim_match_final_states S)...
      * eapply star_safe...
      * intros [s1'' [res1 [D [FIN MV]]]].
        exists (Terminates res1); split;
        [ eapply (state_terminates _ _ _ _ (star_trans A D) FIN)
        | ]...
    + (* fault stop *)
(*       exploit backward_simulation_star...
      intros [i' [s1' [A B]]]. *)
      exploit (bsim_match_error_states S)...
      * eapply star_safe...
      * intros [s1'' [err1 [C [ERR ME]]]].
        exists (Faultstops err1); split;
        [ eapply (state_fstops _ _ _ _ (star_trans A C) ERR)
        | ]...
    + (* divergence *)
(*       exploit backward_simulation_star...
      intros [i' [s1' [A B]]]. *)
      exists Diverges; split;
      [ econstructor;
        [ exact A
        | eapply backward_simulation_forever, star_safe]
      |]...
    + (* goes wrong *)
(*       exploit backward_simulation_star...
      intros [i' [s1' [A B]]]. *)
      exploit (bsim_progress S)...
      * eapply star_safe...
      * intros [[r FIN] | [[e ERROR] | [s2' STEP2]]]; exfalso;
        [ exact (H4 _ FIN)
        | exact (H5 _ ERROR)
        | exact (H3 _ STEP2)].
  - (* 2. Not safe along *)
    exploit not_safe...
    intros [s1' [STEPS [NOSTEP [NOFIN NOERR]]]].
    exists Goes_wrong; split;
    [ econstructor
    | simpl ]...
Qed.

End BACKWARD_SIMULATIONS.

Theorem backward_simulation_behavior_improves:
  forall L1 L2 mv me, backward_simulation L1 L2 mv me ->
  forall beh2, program_behaves L2 beh2 ->
  exists beh1, program_behaves L1 beh1
 /\ behaviour_improves mv me beh1 beh2.
Proof with eauto.
  intros * S beh2 H.
  destruct S as [index order match_states S]. inv H.
  - (* L2's initial state is defined. *)
    destruct (classic (exists s1, initial_state L1 s1))
      as [[s1 INIT] | NOINIT].
    + (* L1's initial state is defined too. *)
      exploit (bsim_match_initial_states S)...
      intros [i [s1' [INIT1' MATCH]]].
      exploit backward_simulation_state_behaves...
      intros [beh1 [A B]]. exists beh1; split...
      econstructor...
    + (* L1 has no initial state *)
      exists Goes_wrong; split.
      * apply program_goes_initially_wrong.
        intros * ?. destruct NOINIT. exists s0...
      * simpl...
  - (* L2 has no initial state *)
    exists Goes_wrong; split.
    + apply program_goes_initially_wrong. intros * INIT1.
      exploit (bsim_initial_states_exist S)...
      intros [s2 INIT2]. destruct (H0 s2)...
    + simpl...
Qed.

Corollary backward_simulation_same_safe_behavior:
  forall L1 L2 mv me, backward_simulation L1 L2 mv me ->
  (forall beh, program_behaves L1 beh -> not_wrong beh) ->
  (forall beh2, program_behaves L2 beh2 -> exists beh1,
  program_behaves L1 beh1 /\ behaviour_matches mv me beh1 beh2).
Proof with eauto.
  intros.
  exploit backward_simulation_behavior_improves...
  intros [beh [A B]]. pose proof (H0 _ A) as C.
  exists beh; split...
  destruct beh, beh2; simpl in *; try solve [inv B|inv C]...
Qed.


Require Import Common Computation Ensembles
        ADT.ADTSig ADT.Core
        ADTRefinement.Core ADTRefinement.SetoidMorphisms
        ADTRefinement.GeneralRefinements.

Generalizable All Variables.
Set Implicit Arguments.

(** Oftentimes in order to show that a refinement is valid, we need
    some invariant to hold on an ADT's representation- a value cached
    in an ADT's representation should be the result of running an
    observer on the current state, for example.

    One solution to this problem is to use dependent products to
    package proofs of an invariant into an ADT's representation: [
    {rep | Invariant rep} ].
    While conceptually simple, this forces methods to be 'internally'
    verified- mutator methods in particular have to simultaneously
    produce a new state /and/ a proof that it satisfies the ADT's
    invariant.  This can make derivations more painful while
    potentially being bewildering to those unfamiliar with dependent
    products.

    Dependent products introduce another wrinkle to refinement: since
    an ADT refinement can change the proof produced by a method, we
    can't always use equality as the abstraction relation in
    [ADTrefine]. (As an example of a case where the proof changes, a
    refinement might use a cached value instead of running a method on
    the current state.)

    An alternative approach is to have the [ADT] include invariants
    and the corresponding proofs that methods maintain them as a
    separate fields. This more familiar presentation allows method
    refinements to be defined and then verified interactively during a
    derivation, at the cost of polluting ADT definitions with extra
    fields. Since proofs aren't packaged into the representation in
    this approach, equality suffices for expressing method refinement.

    Yet another approach is to use the abstract relation to derive
    an ad hoc invariant for a particular refinement step. The basic
    idea is that the abstraction relation relates two equal states for
    which the invariant holds. By baking the invariant into the
    abstraction relation, it becomes a hypothesis to all of our
    refinement proofs.  The cost of this approach is that it requires
    a proof that each mutator preserves the invariant on an ad hoc
    basis, which could leave to some duplicate proofs (One way to
    mitigate this would be to include invariant hypotheses around in
    the context, which we could bake into the honing
    tactics). Otherwise, I [Ben] would argue it includes the best of
    both worlds- there's no need to pollute the definition of [ADT]
    with [repInv] /and/ methods don't have to bother with maintaining
    proofs.

 *)

Section RepInv.

  Variable rep : Type.
  Variable repInv : Ensemble rep.

  (** This is the abstraction relation we use to mimic invariants- the
      representations are always the same /and/ the invariant
      holds. *)

  Definition repInvAbsR (r_o r_n : rep) :=
    r_o = r_n /\ repInv r_n.

  (** Refining an adt using the [repInvAbsR] relation allows us to
      utilize [repInv] when proving method refinement. Of course, we
      also have to show that mutators preserve the invariant.
      Hopefully we can include additional information into the honing
      tactics to avoid reproving invariant preservation.  *)

  Lemma refineADT_Build_ADT_RepInv
        Sig
  : forall constr constr',
      (forall idx, @refineConstructor _ _ repInvAbsR
                                  (ConstructorDom Sig idx)
                                  (constr idx) (constr' idx))
      -> forall meth meth',
           (forall idx, @refineMethod _ _ repInvAbsR
                                        (fst (MethodDomCod Sig idx))
                                        (snd (MethodDomCod Sig idx))
                                        (meth idx) (meth' idx))
           -> refineADT (@Build_ADT Sig rep constr meth)
                        (@Build_ADT Sig rep constr' meth').
  Proof.
    intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
  Qed.

  Lemma refine_pick_repInvAbsR :
    forall r_o, repInv r_o ->
    refineEquiv {r_n | repInvAbsR r_o r_n}
                (ret r_o).
  Proof.
    unfold repInvAbsR; split; intros v CompV; inversion_by computes_to_inv; intuition;
    subst; econstructor; eauto.
  Qed.

  Lemma refine_pick_repInvAbsR' :
    forall r_n, repInv r_n ->
    refineEquiv {r_o | repInvAbsR r_o r_n}
                (ret r_n).
  Proof.
    unfold repInvAbsR; split; intros v CompV; inversion_by computes_to_inv; intuition;
    subst; econstructor; eauto.
  Qed.

End RepInv.

(* A more user-friendly version of [refineADT_Build_ADT_Rep]. *)

Lemma refinesADTRepInv Sig
      (adt : ADT Sig)
      (repInv : Ensemble (Rep adt))
      Constructors'
      Methods'
      (RefConstr : forall idx d,
                  refine
                    (r_o' <- Constructors adt idx d;
                      {r_n  | r_o' = r_n /\ repInv r_n})
                    (Constructors' idx d))
      (RefMeth : forall idx (r : Rep adt) n,
                  repInv r ->
                  refine
                    (r' <- Methods adt idx r n;
                     r'' <- {r'' : Rep adt |
                             repInvAbsR repInv (fst r') r''};
                    ret (r'', snd r'))
                    (Methods' idx r n))
      (cachedIndex : ConstructorIndex Sig)
: refineADT adt
            {| Rep := Rep adt;
               Constructors := Constructors';
               Methods := Methods'
            |}.
Proof.
  destruct adt.
  eapply refineADT_Build_ADT_RepInv with
  (repInv := repInv); unfold pointwise_relation, repInvAbsR in *;
  simpl in *; intros; intuition; subst; eauto.
Qed.

Tactic Notation "hone" "method" constr(mutIdx) "using" constr(mutBody)
       "under" "invariant" constr(repInv) :=
    let A :=
        match goal with
            |- Sharpened ?A => constr:(A) end in
    let ASig := match type of A with
                    ADT ?Sig => Sig
                end in
    let mutIdx_eq' := fresh in
    let Rep' := eval simpl in (Rep A) in
    let MethodIndex' := eval simpl in (MethodIndex ASig) in
    let ConstructorIndex' := eval simpl in (ConstructorIndex ASig) in
    let Methods' := eval simpl in (Methods A) in
    let Constructors' := eval simpl in (Constructors A) in
      assert (forall idx idx' : MethodIndex', {idx = idx'} + {idx <> idx'})
        as mutIdx_eq' by (decide equality);
      eapply SharpenStep;
        [eapply (@refineADT_Build_ADT_RepInv Rep' repInv
                   _
                   _
                   (fun idx : MethodIndex ASig => if (mutIdx_eq' idx mutIdx) then
                                 mutBody
                               else
                                 Methods' idx));
          try instantiate (1 := Constructors')
        | idtac]; cbv beta in *; simpl in *.


Require Import list_examples.

Definition length_def := FunDef "length" ["x"]
 (SIf ("x" = 0)
   (SReturn 0)
   (SReturn (1 + ECall "length" [arr_next "x"]))).

Inductive length_spec : Spec kcfg :=
  length_claim : forall H l x, heap_fun length_spec nil
  length_def [Int x]
    (asP H (rep_list l x))
    (fun r => constraint (r = zlength l) :* litP H).

Lemma length_proof : sound kstep length_spec.
Proof. list_solver. Qed.


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.Arrays.
Require Import Rupicola.Lib.Loops.
From bedrock2 Require BasicC32Semantics BasicC64Semantics.

Module Type FNV1A_params.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {wordok : word.ok word} {mapok : map.ok mem}.
  Context {localsok : map.ok locals}.
  Context {envok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Parameter prime : word.
  Parameter offset : word.
End FNV1A_params.

Module FNV1A (Import P: FNV1A_params).
  Existing Instances BW word locals mem env ext_spec wordok mapok localsok envok ext_spec_ok.
  Import SizedListArrayCompiler.

  Definition update (hash data : word) :=
    let/n p := P.prime in
    let/n hash := word.xor hash data in
    let/n hash := word.mul hash p in
    hash.

  Implicit Type R : mem -> Prop.
  Instance spec_of_update : spec_of "update" :=
    fnspec! "update" (hash: word) (data: word) ~> hash',
    { requires tr mem := True;
      ensures tr' mem' := tr = tr' /\ mem = mem' /\ hash' = update hash data }.

  Derive update_br2fn SuchThat
         (defn! "update"("hash", "data") ~> "hash" { update_br2fn },
          implements update)
         As update_br2fn_ok.
  Proof.
    compile.
  Qed.

  Definition fnv1a (data: ListArray.t byte) len :=
    let/n p := P.prime in
    let/n hash := P.offset in
    let/n from := word.of_Z 0 in
    let/n hash := ranged_for_u
                   from len
                   (fun hash tok idx Hlt =>
                      let/n b := ListArray.get data idx in
                      let/n hash := word.mul (word.xor hash (word_of_byte b)) p in
                      (tok, hash)) hash in
    hash.

  Instance spec_of_fnv1a : spec_of "fnv1a" :=
    fnspec! "fnv1a" data_ptr len /
           (data: ListArray.t byte) n R
           (pr: word.unsigned len < Z.of_nat n)
           ~> hash,
    { requires tr mem :=
        (sizedlistarray_value AccessByte n data_ptr data ⋆ R) mem;
      ensures tr' mem' :=
        tr = tr' /\
        (sizedlistarray_value AccessByte n data_ptr data ⋆ R) mem' /\
        hash = fnv1a data len }.

  Import LoopCompiler.
  #[local] Hint Extern 1 (_ < _) => lia : compiler_side_conditions.

  Derive fnv1a_br2fn SuchThat
         (defn! "fnv1a"("data", "len") ~> "hash" { fnv1a_br2fn },
          implements fnv1a)
         As fnv1a_br2fn_ok.
  Proof. compile. Qed.
End FNV1A.

Module FNV1A32_params <: FNV1A_params.
  Definition width := 32%Z.
  Definition BW := Bitwidth32.BW32.
  Include BasicC32Semantics.
  Definition prime : Naive.word32 := Eval compute in word.of_Z 16777619.
  Definition offset : Naive.word32 := Eval compute in word.of_Z 2166136261.
End FNV1A32_params.

Module FNV1A32 := FNV1A FNV1A32_params.

Module FNV1A64_params <: FNV1A_params.
  Definition width := 64%Z.
  Definition BW := Bitwidth64.BW64.
  Include BasicC64Semantics.
  Definition prime : Naive.word64 := Eval compute in word.of_Z 1099511628211.
  Definition offset : Naive.word64 := Eval compute in word.of_Z 14695981039346656037.
End FNV1A64_params.

Module FNV1A64 := FNV1A FNV1A64_params.

Require Import bedrock2.NotationsCustomEntry.
Compute FNV1A32.fnv1a_br2fn.
Compute FNV1A64.fnv1a_br2fn.

Module Murmur3.
  Import BasicC32Semantics.

  Definition scramble (k : word) :=
    let/n k := word.mul k (word.of_Z 513432918353) in
    let/n k := word.or (word.slu k (word.of_Z 15)) (word.sru k (word.of_Z 17)) in
    let/n k := word.mul k (word.of_Z 461845907) in
    k.

  Implicit Type R : mem -> Prop.
  Instance spec_of_scramble : spec_of "scramble" :=
    fnspec! "scramble" (k: word) ~> k',
    { requires tr mem := True;
      ensures tr' mem' := tr = tr' /\ mem = mem' /\ k' = scramble k }.

  Derive scramble_br2fn SuchThat
         (defn! "scramble"("k") ~> "k" { scramble_br2fn },
          implements scramble)
         As scramble_br2fn_ok.
  Proof.
    compile.
  Qed.
End Murmur3.

Require Import Rupicola.Lib.ToCString.
Definition fnv1a64_update_cbytes := Eval vm_compute in
  list_byte_of_string (c_module [FNV1A64.update_br2fn]).
Definition fnv1a64_cbytes := Eval vm_compute in
  list_byte_of_string (c_module [FNV1A64.fnv1a_br2fn]).
Definition murmur3_scramble_cbytes := Eval vm_compute in
  list_byte_of_string (c_module [("dummy_main_for_static",([],[],cmd.skip)); Murmur3.scramble_br2fn]).


From Coq Require Import micromega.Lia.
From Coq Require Import ZArith.ZArith.

From VST Require Import floyd.library. (* for rep_lia *)

Local Open Scope Z.

Definition MAX_SPACES: Z := 12.
Definition MAX_SPACES_eq: MAX_SPACES = 12 := eq_refl.
#[global]Hint Rewrite MAX_SPACES_eq: rep_lia.
Global Opaque MAX_SPACES.

Definition NURSERY_SIZE: Z := Z.shiftl 1 16.
Definition NURSERY_SIZE_eq: NURSERY_SIZE = Z.shiftl 1 16 := eq_refl.
#[global]Hint Rewrite NURSERY_SIZE_eq: rep_lia.
Global Opaque NURSERY_SIZE.

Definition generation_size (n: nat) := (NURSERY_SIZE * two_p (Z.of_nat n))%Z.

Lemma generation_size_le_S (n: nat): generation_size n <= generation_size (S n).
Proof.
  unfold generation_size.
  rewrite Nat2Z.inj_succ, two_p_S by lia.
  assert
    (two_p (Z.of_nat n) > 0)
    as H
    by (apply two_p_gt_ZERO; lia).
  assert
    (0 < NURSERY_SIZE)
    as H0
    by easy.
  rewrite Z.mul_assoc, (Z.mul_comm NURSERY_SIZE 2).
  assert
    (0 < NURSERY_SIZE * two_p (Z.of_nat n))
    as H1
    by (apply Z.mul_pos_pos; lia).
  rewrite <- Z.add_diag, Z.mul_add_distr_r.
  lia.
Qed.

Lemma ngs_0_lt (i: nat): 0 < generation_size i.
Proof.
  unfold generation_size.
  rewrite NURSERY_SIZE_eq.
  remember
    (Z.of_nat i)
    as z eqn:Heqz.
  unfold two_p.
  simpl Z.shiftl.
  destruct z as [|z|z] ; try lia.
  unfold two_power_pos.
  lia.
Qed.

Definition MAX_ARGS: Z := 1024.
Definition MAX_ARGS_eq: MAX_ARGS = 1024 := eq_refl.
#[global]Hint Rewrite MAX_ARGS_eq: rep_lia.
Global Opaque MAX_ARGS.

Definition NO_SCAN_TAG: Z := 251.
Definition NO_SCAN_TAG_eq: NO_SCAN_TAG = 251 := eq_refl.
#[global]Hint Rewrite NO_SCAN_TAG_eq: rep_lia.
Global Opaque NO_SCAN_TAG.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From QuickChick Require Import QuickChick.
From adtind Require Import goal50.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (not (@eq natural (Zero) (Zero))).
Admitted.
QuickChick lfind_hyp_test.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

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

          Buchberger : Application of Dickson lemma

          Henrik Persson

  ****************************************************************************)
Require Import List.
Require Import ListProps.
Require Import Bar.
Require Import Dickson.
Require Import Monomials.
Require Export BuchAux.
Section thRO.
Load "hCoefStructure".
Load "hOrderStructure".
Load "hBuchAux".

Definition get_mon : poly A0 eqA ltM -> mon n.
intros sp; case sp.
intros x H'; case x.
exact (M1 n).
intros a H'1; exact (T2M a).
Defined.

Theorem get_is_correct :
 forall (a b : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
 ~
 zerop A A0 eqA n ltM
   (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os a
      P) ->
 In b P ->
 ~ zerop A A0 eqA n ltM b ->
 ~
 mdiv n (get_mon b)
   (get_mon
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os a P)).
intros a b P H' H'0 H'1.
cut
 (irreducible A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P
    (s2p A A0 eqA n ltM
       (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
          os a P))).
2: try exact (nf_irreducible a P); auto.
generalize H';
 case
  (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os a
     P); simpl in |- *; auto.
intros x; case x; simpl in |- *.
intros H'2 H'3; elim H'3; auto.
intros a0 l H'2 H'3 H'4; red in |- *; intros H'5; red in H'4.
red in H'4.
generalize H'0 H'1 H'5; case b.
intros x0; case x0; simpl in |- *.
intros o H'6 H'7; elim H'7; auto.
intros a1 l0 o H'6 H'7 H'8.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a1); [ intros nZa1 | idtac ].
apply
 H'4
   with
     (q := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
             a0 a1 nZa1 l l0); auto.
change
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P
     (pX a0 l)
     (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a0 a1
        nZa1 l l0)) in |- *.
apply reducetop_sp with (1 := cs) (b := a1) (nZb := nZa1) (q := l0); auto.
change
  (inPolySet A A0 eqA n ltM
     (s2p A A0 eqA n ltM (mks A A0 eqA n ltM (pX a1 l0) o)) P)
 in |- *.
apply in_inPolySet; auto.
simpl in |- *; auto.
red in |- *; intros H'9; inversion H'9.
apply divTerm_def with (nZb := nZa1); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
apply divTerm_on_plusM_minusM with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
simpl in |- *; auto.
apply sym_equal; auto.
apply mdiv_div; auto.
apply canonical_nzeroP with (ltM := ltM) (p := l0); auto.
apply nf_irreducible; auto.
Qed.

Definition get_monL : list (poly A0 eqA ltM) -> list (mon n) := map get_mon.

Inductive RO : list (poly A0 eqA ltM) -> list (poly A0 eqA ltM) -> Prop :=
    RO0 :
      forall (a : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
      ~
      zerop A A0 eqA n ltM
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a P) ->
      RO
        (P ++
         nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a P :: nil) P.

Definition BadM (l : list (mon n)) := GoodR (mon n) (mdiv n) l -> False.

Lemma l1 :
 forall (cs : list (poly A0 eqA ltM)) (ms : list (mon n)),
 Bar (mon n) (GoodR (mon n) (mdiv n)) ms ->
 forall bs : list (poly A0 eqA ltM),
 ms = get_monL bs ->
 (forall f : poly A0 eqA ltM, In f bs -> ~ zerop A A0 eqA n ltM f) ->
 BadM ms -> Acc RO (cs ++ rev bs).
intros cs1 ms1 H; elim H; auto.
intros l H' bs H'0 H'1 H'2.
case H'2; auto.
intros l H' H'0 bs Heq Hnz H'1; auto.
apply Acc_intro; auto.
intros y H'2; inversion H'2; auto.
rewrite <- ass_app.
change
  (Acc RO
     (cs1 ++
      rev bs ++
      rev
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a (cs1 ++ rev bs) :: nil))) in |- *.
rewrite <- distr_rev; simpl in |- *.
change
  (Acc RO
     (cs1 ++
      rev
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a (cs1 ++ rev bs) :: bs))) in |- *.
apply
 H'0
  with
    (a := get_mon
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a (cs1 ++ rev bs))); unfold get_monL in |- *;
 try rewrite Heq; simpl in |- *; auto.
intros f H'3; elim H'3;
 [ intros H'4; rewrite <- H'4; clear H'3 | intros H'4; clear H'3 ];
 auto.
apply tdivGoodP with (trm := mon n) (tdiv := mdiv n); auto.
rewrite <- Heq; auto.
intros g.
intros H'3; cut (ex (fun b : poly A0 eqA ltM => g = get_mon b /\ In b bs)).
intros H'4; elim H'4; intros b E; elim E; intros H'5 H'6; rewrite H'5;
 clear E H'4; auto.
apply get_is_correct; auto.
apply in_or_app; apply or_intror; apply in_rev; auto.
apply map_in; auto.
Qed.

Theorem wf_incl : well_founded RO.
unfold well_founded in |- *; intros.
apply Acc_intro; intros.
inversion H.
apply
 l1
  with
    (bs := nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
             ltM_dec os a0 a :: nil)
    (ms := get_monL
             (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
                ltM_dec os a0 a :: nil)); auto.
change
  (GRBar (mon n) (mdiv n)
     (get_mon
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a0 a) :: nil)) in |- *.
apply nilGRBar; auto.
apply dicksonL with (n := n); auto.
simpl in |- *; intros f H3; case H3; intros.
rewrite <- H4; auto.
elim H4.
red in |- *; intros H4; inversion H4; inversion H5.
Qed.

Lemma RO_lem :
 forall (a : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
 ~
 zerop A A0 eqA n ltM
   (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os a
      P) ->
 RO
   (addEnd A A0 eqA n ltM
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os a P) P) P.
intros a P H'; rewrite addEnd_app.
apply RO0; auto.
Qed.
End thRO.


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(*    FullAtomicJl:
        Decidable, Tag-Based Semantic Subtyping
        for Nominal Types, Pairs, and Unions.  *)

(** * FullAtomicJl: Propositions about Reductive Subtyping *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..". (* root directory of the repo *)

Require Import Mechanization.Aux.Identifier.

Require Import Mechanization.FullAtomicJl.BaseDefs.
Require Import Mechanization.FullAtomicJl.BaseProps.
Require Import Mechanization.FullAtomicJl.MatchProps.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.

Close Scope btj_scope.
Open  Scope btjm_scope.
Open  Scope btjnf_scope.
Open  Scope btjr_scope.

(* ################################################################# *)
(** ** Auxiliary Statements *)
(* ################################################################# *)

(* ================================================================= *)
(** *** Union of Normal Form *)
(* ================================================================= *)

(* DEP: mk_nf_nf__equal *)
Lemma union_nf_sub_r__components_sub_r : forall (t1 t2 t' : ty),
    |- TUnion t1 t2 << t' ->
    InNF(t1) -> InNF(t2) ->
    |- t1 << t' /\ |- t2 << t'.
Proof.
  intros t1 t2 t' H. remember (TUnion t1 t2) as t eqn:Heq.
  induction H; intros Hnf1 Hnf2; try solve [inversion Heq].
  - (* UnionL *)
    inversion Heq; subst. split; assumption.
  - (* UnionR1 *)
    inversion Heq; subst. specialize (IHsub_r H0).
    split; (apply SR_UnionR1 || apply SR_UnionR2); tauto.
  - (* UnionR2 *)
    inversion Heq; subst. specialize (IHsub_r H0).
    split; (apply SR_UnionR2 || apply SR_UnionR2); tauto.
  - (* NF *)
    subst. simpl in *. apply IHsub_r; try assumption.
    rewrite (mk_nf_nf__equal _ Hnf1).
    rewrite (mk_nf_nf__equal _ Hnf2).
    reflexivity.
Qed.

(* ================================================================= *)
(** *** About [unite_pairs] *)
(* ================================================================= *)

(* DEP: sub_r__rflxv, unite_pairs_t_union, unite_pairs_union_t,
        union_in_nf__components_in_nf,
        mk_nf_nf__equal, mk_nf__in_nf, mk_nf__preserves_valid *)
Lemma unite_pairs_of_nf__preserves_sub_r : forall (t1 t2 t1' t2' : ty),
    valid t1 ->
    valid t2 ->
    |- t1 << t1' ->
    |- t2 << t2' ->
    InNF(t1) -> InNF(t1') ->
    InNF(t2) -> InNF(t2') ->
    |- unite_pairs t1 t2 << unite_pairs t1' t2'.
Proof.
  intros ta tb ta' tb' HTY1 HTY2 Hsub1.
  generalize dependent tb'; generalize dependent tb;
    induction Hsub1; intros tb HTY2 tb' Hsub2;
    try solve [
          induction Hsub2; intros Hnfa Hnfa' Hnfb Hnfb';
          try solve [
                simpl; constructor; constructor; assumption
              (* UnionL *)
              | inversion HTY2; subst;
                rewrite unite_pairs_t_union; try resolve_not_union;
                destruct (union_in_nf__components_in_nf _ _ Hnfb) as [Hnfb1 Hnfb2];
                constructor; [apply IHHsub2_1 | apply IHHsub2_2];
                assumption || constructor
              (* UnionR1 *)
              | rewrite unite_pairs_t_union; try resolve_not_union;
                destruct (union_in_nf__components_in_nf _ _ Hnfb') as [Hnfb1 Hnfb2];
                apply SR_UnionR1; apply IHHsub2; assumption || constructor
              (* UnionR2 *)
              | rewrite unite_pairs_t_union; try resolve_not_union;
                destruct (union_in_nf__components_in_nf _ _ Hnfb') as [Hnfb1 Hnfb2];
                apply SR_UnionR2; apply IHHsub2; assumption || constructor
              (* NF *)
              | rewrite <- (mk_nf_nf__equal _ Hnfb);
                pose proof (mk_nf__preserves_valid _ HTY2) as HTYnf;
                apply IHHsub2; try assumption; apply mk_nf__in_nf; assumption ]
        ].
  - (* UnionL, tb *)
    intros Hnfa Hnfa' Hnfb Hnfb'. rewrite unite_pairs_union_t.
    destruct (union_in_nf__components_in_nf _ _ Hnfa) as [Hnfa1 Hnfa2].
    inversion HTY1; subst.
    constructor; [apply IHHsub1_1 | apply IHHsub1_2]; assumption.
  - (* UnionR1, tb *)
    intros Hnfa Hnfa' Hnfb Hnfb'. rewrite unite_pairs_union_t.
    destruct (union_in_nf__components_in_nf _ _ Hnfa') as [Hnfa1 Hnfa2].
    apply SR_UnionR1; apply IHHsub1; assumption.
  - (* UnionR2, tb *)
    intros Hnfa Hnfa' Hnfb Hnfb'. rewrite unite_pairs_union_t.
    destruct (union_in_nf__components_in_nf _ _ Hnfa') as [Hnfa1 Hnfa2].
    apply SR_UnionR2; apply IHHsub1; assumption.
  - (* NF, tb *)
    intros Hnfa Hnfa' Hnfb Hnfb'.
    rewrite <- (mk_nf_nf__equal _ Hnfa).
    apply IHHsub1; try assumption.
    apply mk_nf__preserves_valid; assumption.
    apply mk_nf__in_nf; assumption.
Qed.

(* DEP: unite_pairs_t_union, unite_pairs_union_t,
        union_in_nf__components_in_nf, union_nf_sub_r__components_sub_r *)
Lemma unite_pairs_of_nf__preserves_sub_r1 : forall (t1 t2 t1' t2' : ty),
    InNF(t1) -> |- t1 << t1' ->
    InNF(t2) -> |- t2 << t2' ->
    |- unite_pairs t1 t2 << TPair t1' t2'.
Proof.
  intros ta; induction ta;
    intros tb; induction tb;
      intros ta' tb' Hnf1 Hsub1 Hnf2 Hsub2;
      try solve [
            simpl; constructor; assumption
          | match goal with
            | [Hnf1: InNF(?t), Hnf2: InNF(TUnion ?t1 ?t2),
               Hsub: |- TUnion ?t1 ?t2 << _
               |- |- unite_pairs ?t (TUnion ?t1 ?t2) << TPair _ _] =>
              rewrite unite_pairs_t_union; try resolve_not_union;
              destruct (union_in_nf__components_in_nf _ _ Hnf2) as [Hnfb1 Hnfb2];
              destruct (union_nf_sub_r__components_sub_r _ _ _ Hsub Hnfb1 Hnfb2) as [Hsubb1 Hsubb2];
              constructor; [apply IHtb1 | apply IHtb2]; assumption
            | [Hnf1: InNF(?t), Hnf2: InNF(TUnion ?t1 ?t2),
               Hsub: |- TUnion ?t1 ?t2 << _
               |- |- unite_pairs (TUnion ?t1 ?t2) ?t << TPair _ _] =>
              rewrite unite_pairs_union_t;
              destruct (union_in_nf__components_in_nf _ _ Hnf2) as [Hnfb1 Hnfb2];
              destruct (union_nf_sub_r__components_sub_r _ _ _ Hsub Hnfb1 Hnfb2) as [Hsubb1 Hsubb2];
              constructor; [apply IHta1 | apply IHta2]; assumption
            end
          ].
Qed.

(* ================================================================= *)
(** *** About [MkNF] *)
(* ================================================================= *)

(* DEP: unite_pairs_of_nf__preserves_sub_r1 *)
Lemma sub_r__mk_nf_sub_r1 : forall (t t' : ty),
    valid t ->
    |- t << t' ->
    |- MkNF(t) << t'.
Proof.
  intros t t' HTYt Hsub; induction Hsub;
    try solve [simpl; constructor; constructor].
  - (* Pair *)
    simpl. inversion HTYt; subst.
    apply unite_pairs_of_nf__preserves_sub_r1;
      tauto || apply mk_nf__in_nf; assumption.
  - (* Union *)
    simpl. inversion HTYt; subst.
    constructor; tauto.
  - (* UnionR1 *)
    apply SR_UnionR1; tauto.
  - (* UnionR2 *)
    apply SR_UnionR2; tauto.
  - (* NF *)
    assumption.
Qed.

(* DEP: unite_pairs_of_nf__preserves_sub_r1, mk_nf__in_nf *)
Lemma mk_nf__sub_r1 : forall (t : ty),
    valid t ->
    |- MkNF(t) << t.
Proof.
  intros t HTY.
  apply sub_r__mk_nf_sub_r1. assumption.
  apply sub_r__rflxv; assumption.
Qed.

(* DEP: mk_nf__preserves_valid, sub_r__rflxv *)
Lemma mk_nf__sub_r2 : forall (t : ty),
    valid t ->
    |- t << MkNF(t).
Proof.
  intros t HTY.
  apply SR_NormalForm. apply sub_r__rflxv.
  apply mk_nf__preserves_valid; assumption.
Qed.

(* ================================================================= *)
(** *** Related to Transitivity *)
(* ================================================================= *)

(* DEP: sub_r__mk_nf_sub_r1, union_nf_sub_r__components_sub_r *)
Lemma union_sub_r__components_sub_r : forall (t1 t2 t' : ty),
    valid t1 -> valid t2 ->
    |- TUnion t1 t2 << t' ->
    |- t1 << t' /\ |- t2 << t'.
Proof.
  intros t1 t2 t' HTY1 HTY2 Hsub.
  assert (HTY: valid (TUnion t1 t2)) by (constructor; assumption).
  pose proof (sub_r__mk_nf_sub_r1 _ _ HTY Hsub).
  simpl in H.
  assert (Hsubnf: |- MkNF(t1) << t' /\ |- MkNF(t2) << t').
  { apply union_nf_sub_r__components_sub_r;
      assumption || apply mk_nf__in_nf; assumption. }
  split; apply SR_NormalForm; tauto.
Qed.

(* DEP: sub_r_value_types__equal, union_in_nf__components_in_nf,
        mk_nf_nf__equal, mk_nf__in_nf, mk_nf__preserves_valid *)
Lemma sub_r_nf__transitive : forall (t1 t2 t3 : ty),
    valid t2 ->
    |- t1 << t2 ->
    InNF(t1) -> InNF(t2) ->
    |- t2 << t3 ->
    |- t1 << t3.
Proof.
  intros t1 t2 t3 HTY2 Hsub1. generalize dependent t3.
  induction Hsub1; intros t3 Hnf1 Hnf2 Hsub2;
    try solve [
          assumption
        | inversion Hnf2; subst;
          match goal with [H: value_type _ |- _] => inversion H end
        | remember treal as t2 eqn:Heq2; induction Hsub2;
          inversion Heq2; subst; try solve [constructor | auto]
        | remember tnum as t2 eqn:Heq2; induction Hsub2;
          inversion Heq2; subst; try solve [constructor | auto]
        ].
  - (* Pair *)
    inversion Hnf1; subst. inversion Hnf2; subst.
    inversion HTY2; subst.
    inversion H; inversion H0; subst.
    remember (TPair t1' t2') as tx eqn:Heqx; induction Hsub2;
      inversion Heqx; subst.
    + (* Pair *)
      constructor; [apply IHHsub1_1 | apply IHHsub1_2];
        try assumption || constructor; assumption.
    + (* UnionR1 *)
      apply SR_UnionR1; auto.
    + (* UnionR2 *)
      apply SR_UnionR2; auto.
    + (* NF *)
      apply IHHsub2.
      apply mk_nf_nf__equal; assumption.
      apply mk_nf__preserves_valid; assumption.
      apply mk_nf__in_nf; assumption.
      rewrite mk_nf_nf__equal; assumption.
  - (* UnionL *)
    destruct (union_in_nf__components_in_nf _ _ Hnf1) as [Hnfa1 Hnfa2].
    constructor; [apply IHHsub1_1 | apply IHHsub1_2]; assumption.
  - (* UnionR1 *)
    inversion HTY2; subst.
    destruct (union_in_nf__components_in_nf _ _ Hnf2) as [Hnfa1 Hnfa2].
    apply IHHsub1; try assumption.
    pose proof (union_nf_sub_r__components_sub_r _ _ _ Hsub2 Hnfa1 Hnfa2); tauto.
  - (* UnionR2 *)
    inversion HTY2; subst.
    destruct (union_in_nf__components_in_nf _ _ Hnf2) as [Hnfa1 Hnfa2].
    apply IHHsub1; try assumption.
    pose proof (union_nf_sub_r__components_sub_r _ _ _ Hsub2 Hnfa1 Hnfa2); tauto.
  - (* NF *)
    rewrite mk_nf_nf__equal in IHHsub1; try assumption.
    apply IHHsub1; assumption.
Qed.

(* ################################################################# *)
(** ** Properties related to matching *)
(* ################################################################# *)

(* ================================================================= *)
(** *** Correctness of Subtyping with respect to Matching *)
(* ================================================================= *)

Theorem match_ty__sub_r_sound : forall (v t : ty),
    valid v ->
    |- v <$ t ->
    |- v << t.
Proof.
  intros v t HTYv H; induction H;
    try solve [constructor | inversion HTYv].
  - (* Pair *)
    inversion HTYv; subst.
    constructor; tauto.
  - (* Union1 *)
    apply SR_UnionR1; tauto.
  - (* Union2 *)
    apply SR_UnionR2; tauto.
Qed.

(* ================================================================= *)
(** ** Matching value Type is Complete for Subtyping *)
(* ================================================================= *)

(* DEP: value_type_valid__atom, mk_nf_nf__equal,
        mk_nf__preserves_valid, mk_nf__preserves_value_type *)
Theorem match_valty__sub_r_complete : forall (v t : ty),
    valid v -> valid t ->
    |- v << t ->
    value_type v ->
    |- v <$ t.
Proof.
  intros v t HTYv HTYt H; induction H; subst; intros Hval;
    try solve [constructor | inversion Hval].
  - (* Pair *)
    inversion Hval; inversion HTYv; inversion HTYt; subst.
    constructor; tauto.
  - (* UnionR1 *)
    inversion HTYt; subst.
    apply MT_Union1; tauto.
  - (* UnionR2 *)
    inversion HTYt; subst.
    apply MT_Union2; tauto.
  - (* NF *)
    assert (Hnf: InNF(t)) by (constructor; apply value_type_valid__atom; assumption).
    rewrite <- (mk_nf_nf__equal _ Hnf). apply IHsub_r; try assumption.
    apply mk_nf__preserves_valid; assumption.
    apply mk_nf__preserves_value_type; assumption.
Qed.

(* ################################################################# *)
(** ** Properties related to Normal Form *)
(* ################################################################# *)

(** If types are subtypes, their normal forms are also subtypes. *)
(* DEP: unite_pairs_of_nf__preserves_sub_r,
        mk_nf__in_nf, mk_nf__idempotent,
        mk_nf__preserves_valid *)
Lemma sub_r__mk_nf_sub_r : forall (t t' : ty),
    valid t -> valid t' ->
    |- t << t' ->
    |- MkNF(t) << MkNF(t').
Proof.
  intros t t' HTYt HTYt' Hsub; induction Hsub;
    try solve [simpl; do 4 constructor].
  - (* Pair *)
    simpl. inversion HTYt; inversion HTYt'; subst.
    apply unite_pairs_of_nf__preserves_sub_r;
      (apply mk_nf__preserves_valid; assumption) || tauto
      ||  apply mk_nf__in_nf; assumption.
  - (* Union *)
    simpl. inversion HTYt; subst.
    constructor; tauto.
  - (* UnionR1 *)
    simpl. inversion HTYt'; subst.
    apply SR_UnionR1; tauto.
  - (* UnionR2 *)
    simpl. inversion HTYt'; subst.
    apply SR_UnionR2; tauto.
  - (* NF *)
    rewrite <- mk_nf__idempotent; try assumption.
    apply IHHsub; try assumption.
    apply mk_nf__preserves_valid; assumption.
Qed.

(* DEP: sub_r_nf__transitive, mk_nf__in_nf,
        mk_nf__preserves_valid, mk_nf__sub_r1 *)
Lemma mk_nf_sub_r__sub_r : forall (t t' : ty),
    valid t -> valid t' ->
    |- MkNF(t) << MkNF(t') ->
    |- t << t'.
Proof.
  intros t t' HTYt HTYt' Hsub.
  apply SR_NormalForm.
  apply sub_r_nf__transitive with (MkNF(t'));
    try (apply mk_nf__in_nf; try assumption) || assumption.
  apply mk_nf__preserves_valid; assumption.
  apply mk_nf__sub_r1; assumption.
Qed.

(*
(* DEP: match_ty__sub_r_sound, match_valty__rflxv *)
Theorem nf_sem_sub__sub_r : forall (t : ty),
    InNF(t) ->
    forall (t' : ty),
      valid t' ->
      ||- [t] <= [t'] ->
      |- t << t'.
Proof.
  intros t Hnf; induction Hnf; intros t' HTYt' Hval;
    unfold sem_sub.
  - (* Value *)
    apply match_ty__sub_r_sound. apply atom__valid; assumption.
    apply Hval. (* assumption. apply match_valty__rflxv. assumption.
  - (* Union *)
    constructor; [apply IHHnf1 | apply IHHnf2]; intros v Hv Hsub;
      try assumption; apply Hval; try assumption.
    apply MT_Union1; assumption.
    apply MT_Union2; assumption.
Qed.
*)
*)

(* ################################################################# *)
(** ** Properties related to Declarative Subtyping *)
(* ################################################################# *)

(* ================================================================= *)
(** *** Reflexivity *)
(* ================================================================= *)

(* DEP: sub_r__rflxv *)
Lemma sub_r__reflexive : forall (t : ty),
    valid t ->
    |- t << t.
Proof.
  apply sub_r__rflxv.
Qed.

(* ================================================================= *)
(** *** Transitivity *)
(* ================================================================= *)

(* DEP: sub_r__mk_nf_sub_r, sub_r_nf__transitive,
        mk_nf__in_nf, union_sub_r__components_sub_r *)
Lemma sub_r__transitive : forall (t1 t2 t3 : ty),
    valid t1 -> valid t2 ->
    |- t1 << t2 ->
    |- t2 << t3 ->
    |- t1 << t3.
Proof.
  intros t1 t2 t3 HTY1 HTY2 Hsub1. generalize dependent t3.
  induction Hsub1; intros t3 Hsub2;
    try solve [auto | inversion HTY1; auto];
    try solve [
          remember treal as t2 eqn:Heq2; induction Hsub2;
          inversion Heq2; subst; try solve [constructor | auto]
        | remember tnum as t2 eqn:Heq2; induction Hsub2;
          inversion Heq2; subst; try solve [constructor | auto]
        ].
  - (* Pair *)
    inversion HTY1; inversion HTY2; subst.
    remember (TPair t1' t2') as tm eqn:Heq.
    induction Hsub2; try solve [inversion Heq].
    + (* Pair *)
      inversion Heq; subst.
      constructor; auto.
    + (* UnionR1 *)
      apply SR_UnionR1; tauto.
    + (* UnionR2 *)
      apply SR_UnionR2; tauto.
    + (* NF *)
      inversion Heq; subst. clear H.
      assert (Hsub1: |- TPair t1 t2 << TPair t1' t2') by (constructor; assumption).
      pose proof (sub_r__mk_nf_sub_r _ _ HTY1 HTY2 Hsub1) as Hsub1nf.
      apply SR_NormalForm.
      apply sub_r_nf__transitive with (MkNF( TPair t1' t2'));
        try assumption || apply mk_nf__in_nf; try assumption.
      apply mk_nf__preserves_valid; assumption.
  - (* Union1 *)
    apply (sub_r__mk_nf_sub_r1 _ _ HTY2) in Hsub2; simpl in Hsub2.
    inversion HTY2; subst.
    pose proof (mk_nf__preserves_valid _ H1) as HTYnf1.
    pose proof (mk_nf__preserves_valid _ H2) as HTYnf2.
    destruct (union_sub_r__components_sub_r _ _ _ HTYnf1 HTYnf2 Hsub2) as [Hsub21 Hsub22].
    auto.
  - (* Union2 *)
    apply (sub_r__mk_nf_sub_r1 _ _ HTY2) in Hsub2; simpl in Hsub2.
    inversion HTY2; subst.
    pose proof (mk_nf__preserves_valid _ H1) as HTYnf1.
    pose proof (mk_nf__preserves_valid _ H2) as HTYnf2.
    destruct (union_sub_r__components_sub_r _ _ _ HTYnf1 HTYnf2 Hsub2) as [Hsub21 Hsub22].
    auto.
  - (* NF *)
    apply SR_NormalForm.
    pose proof (mk_nf__preserves_valid _ HTY1) as HTYnf1.
    auto.
Qed.

(* ================================================================= *)
(** *** Distributivity *)
(* ================================================================= *)

(* ----------------------------------------------------------------- *)
(** **** Aux *)
(* ----------------------------------------------------------------- *)

(* DEP: unite_pairs_t_union, unite_pairs_union_t,
        sub_r__reflexive, sub_r__transitive,
        unite_pairs__preserves_nf, nf__valid *)
Lemma unite_pairs__distr21 : forall (t1 t21 t22 : ty),
    InNF(t1) ->
    InNF(t21) -> InNF(t22) ->
    |- unite_pairs t1 (TUnion t21 t22) <<
       TUnion (unite_pairs t1 t21) (unite_pairs t1 t22).
Proof.
  intros t1 t21 t22 Hnf1.
  generalize dependent t22. generalize dependent t21.
  induction Hnf1; intros t21 t22 Hnf21 Hnf22.
  - (* Atom *)
    rewrite unite_pairs_t_union.
    + apply sub_r__reflexive.
      constructor; apply nf__valid; apply unite_pairs__preserves_nf;
        (constructor; assumption) || assumption.
    + intros Hcontra. destruct Hcontra as [tx [ty Heq]].
      induction H; inversion Heq.
  - (* Union *)
    repeat rewrite unite_pairs_union_t.
    constructor.
    + apply sub_r__transitive with (TUnion (unite_pairs t1 t21) (unite_pairs t1 t22)).
      * apply nf__valid.
        apply unite_pairs__preserves_nf; assumption || apply NF_Union; assumption.
      * constructor; apply nf__valid;
        apply unite_pairs__preserves_nf; assumption.
      * apply IHHnf1_1; assumption.
      * constructor; [apply SR_UnionR1 | apply SR_UnionR2];
          apply SR_UnionR1; apply sub_r__reflexive;
          apply nf__valid; apply unite_pairs__preserves_nf; assumption.
    + apply sub_r__transitive with (TUnion (unite_pairs t2 t21) (unite_pairs t2 t22)).
      * apply nf__valid.
        apply unite_pairs__preserves_nf; assumption || apply NF_Union; assumption.
      * constructor; apply nf__valid;
        apply unite_pairs__preserves_nf; assumption.
      * apply IHHnf1_2; assumption.
      * constructor; [apply SR_UnionR1 | apply SR_UnionR2];
          apply SR_UnionR2; apply sub_r__reflexive;
          apply nf__valid; apply unite_pairs__preserves_nf; assumption.
Qed.

(* ----------------------------------------------------------------- *)
(** **** Main Properties *)
(* ----------------------------------------------------------------- *)

(* DEP: unite_pairs_union_t, sub_r__reflexive *)
Lemma mk_nf__distr11 : forall (t11 t12 t2 : ty),
    valid t11 -> valid t12 -> valid t2 ->
    |- MkNF(TPair (TUnion t11 t12) t2) << MkNF(TUnion (TPair t11 t2) (TPair t12 t2)).
Proof.
  intros t11 t12 t2 HTY11 HTY12 HTY2.
  change (|- MkNF( TPair (TUnion t11 t12) t2) << TUnion (MkNF(TPair t11 t2)) (MkNF(TPair t12 t2))).
  change (|- unite_pairs (MkNF(TUnion t11 t12)) (MkNF(t2)) <<
             TUnion (MkNF(TPair t11 t2)) (MkNF(TPair t12 t2))).
  change (|- unite_pairs (TUnion (MkNF(t11)) (MkNF(t12))) (MkNF(t2)) <<
             TUnion (MkNF(TPair t11 t2)) (MkNF(TPair t12 t2))).
  rewrite unite_pairs_union_t.
  apply sub_r__reflexive.
  constructor; apply mk_nf__preserves_valid; constructor; assumption.
Qed.

(* DEP: unite_pairs__distr21, mk_nf__in_nf *)
Lemma mk_nf__distr21 : forall (t1 t21 t22 : ty),
    valid t1 -> valid t21 -> valid t22 ->
    |- MkNF(TPair t1 (TUnion t21 t22)) << MkNF(TUnion (TPair t1 t21) (TPair t1 t22)).
Proof.
  intros t1 t21 t22 HTY1 HTY21 HTY22.
  change (|- MkNF(TPair t1 (TUnion t21 t22)) << TUnion (MkNF(TPair t1 t21)) (MkNF(TPair t1 t22))).
  change (|- unite_pairs (MkNF(t1)) (TUnion (MkNF(t21)) (MkNF(t22))) <<
             TUnion (MkNF(TPair t1 t21)) (MkNF(TPair t1 t22))).
  change (|- unite_pairs (MkNF(t1)) (TUnion (MkNF(t21)) (MkNF(t22))) <<
                               TUnion (unite_pairs (MkNF(t1)) (MkNF(t21))) (unite_pairs (MkNF(t1)) (MkNF(t22)))).
  apply unite_pairs__distr21; apply mk_nf__in_nf; assumption.
Qed.

(* ################################################################# *)
(** ** Examples *)
(* ################################################################# *)

Lemma not__real_sub_r_int :
  ~ (|- treal << tint).
Proof.
  remember treal as t1 eqn:Heq1. remember tint as t2 eqn:Heq2.
  intros Hcontra; induction Hcontra;
    try solve [inversion Heq1 | inversion Heq2].
  subst. tauto.
Qed.

Lemma not__real_sub_r_flt :
  ~ (|- treal << tflt).
Proof.
  remember treal as t1 eqn:Heq1. remember tflt as t2 eqn:Heq2.
  intros Hcontra; induction Hcontra;
    try solve [inversion Heq1 | inversion Heq2].
  subst. tauto.
Qed.

Lemma not__real_sub_r_u_int_flt :
  ~ (|- treal << TUnion tint tflt).
Proof.
  remember treal as t1 eqn:Heq1. remember (TUnion tint tflt) as t2 eqn:Heq2.
  intros Hcontra; induction Hcontra;
    try solve [inversion Heq1 | inversion Heq2].
  - inversion Heq1; inversion Heq2; subst.
    apply not__real_sub_r_int; tauto.
  - inversion Heq1; inversion Heq2; subst.
    apply not__real_sub_r_flt; tauto.
  - subst; tauto.
Qed.

(* ################################################################# *)
(** ** Decidability *)
(* ################################################################# *)

(* ----------------------------------------------------------------- *)
(** **** Aux *)
(* ----------------------------------------------------------------- *)

Lemma not__aname_sub_r_cname : forall (a : aname) (c : cname),
  ~ (|- TAName a << TCName c).
Proof.
  intros a c.
  remember (TAName a) as t1 eqn:Heq1. remember (TCName c) as t2 eqn:Heq2.
  intros Hcontra; induction Hcontra;
    try solve [inversion Heq1 | inversion Heq2].
  subst. tauto.
Qed.

Lemma not__aname_sub_r_pair : forall (a : aname) (t1 t2 : ty),
  ~ (|- TAName a << TPair t1 t2).
Proof.
  intros a t1 t2.
  remember (TAName a) as t eqn:Heq1. remember (TPair t1 t2) as t' eqn:Heq2.
  intros Hcontra; induction Hcontra;
    try solve [inversion Heq1 | inversion Heq2].
  subst. tauto.
Qed.

(*
Lemma aname_sub_r_union__aname_sub_r_component : forall (a : aname) (t1 t2 : ty),
    |- TAName a << TUnion t1 t2 ->
    |- TAName a << t1 \/ |- TAName a << t2.
Proof.
  intros a t1 t2.
  remember (TAName a) as t eqn:Heq1. remember (TUnion t1 t2) as t' eqn:Heq2.
  intros Hsub; induction Hsub;
    try solve [inversion Heq1 | inversion Heq2].
  - (* UnionR1 *)
    inversion Heq2; subst; tauto.
  - (* UnionR2 *)
    inversion Heq2; subst; tauto.
  - (* NF *)
    subst. simpl in IHHsub. tauto.
Qed.
*)

(* DEP: mk_nf_nf__equal, atomty_in_nf *)
Lemma atom_sub_r_union__atom_sub_r_component : forall (t t1 t2 : ty),
    atom_type t ->
    |- t << TUnion t1 t2 ->
    |- t << t1 \/ |- t << t2.
Proof.
  intros t t1 t2 Hat.
  remember (TUnion t1 t2) as t' eqn:Heq2.
  intros Hsub; induction Hsub;
    try solve [inversion Heq1 | inversion Heq2].
  - (* UnionL *)
    inversion Hat.
  - (* UnionR1 *)
    inversion Heq2; subst; tauto.
  - (* UnionR2 *)
    inversion Heq2; subst; tauto.
  - (* NF *)
    rewrite mk_nf_nf__equal in IHHsub.
    apply IHHsub; try assumption.
    apply atomty_in_nf; assumption.
Qed.

(* DEP: mk_nf_nf__equal *)
Lemma not__atom_pair_sub_r_cname : forall (c : cname) (t1 t2 : ty),
  atom_type t1 -> atom_type t2 ->
  ~ (|- TPair t1 t2 << TCName c).
Proof.
  intros c t1 t2 Hat1 Hat2.
  remember (TCName c) as t eqn:Heq1. remember (TPair t1 t2) as t' eqn:Heq2.
  intros Hcontra; induction Hcontra;
    try solve [inversion Heq1 | inversion Heq2].
  (* MkNF *)
  subst. apply IHHcontra. reflexivity.
  apply mk_nf_nf__equal. constructor. constructor; assumption.
Qed.

(* DEP: mk_nf_nf__equal *)
Lemma not__atom_pair_sub_r_aname : forall (a : aname) (t1 t2 : ty),
  atom_type t1 -> atom_type t2 ->
  ~ (|- TPair t1 t2 << TAName a).
Proof.
  intros a t1 t2 Hat1 Hat2.
  remember (TAName a) as t eqn:Heq1. remember (TPair t1 t2) as t' eqn:Heq2.
  intros Hcontra; induction Hcontra;
    try solve [inversion Heq1 | inversion Heq2].
  (* MkNF *)
  subst. apply IHHcontra. reflexivity.
  apply mk_nf_nf__equal. constructor. constructor; assumption.
Qed.

(* DEP: mk_nf_nf__equal *)
Lemma atom_pair_sub_r_pair__sub_r_components : forall (ta1 ta2 t1 t2 : ty),
    atom_type ta1 -> atom_type ta2 ->
    |- TPair ta1 ta2 << TPair t1 t2 ->
    |- ta1 << t1 /\ |- ta2 << t2.
Proof.
  intros ta1 ta2 t1 t2 Hta1 Hta2.
  remember (TPair ta1 ta2) as t eqn:Heq1. remember (TPair t1 t2) as t' eqn:Heq2.
  intros Hsub; induction Hsub;
    try solve [inversion Heq1 | inversion Heq2].
  - (* Pair *)
    inversion Heq1; inversion Heq2; subst; tauto.
  - (* NF *)
    subst. apply IHHsub; try reflexivity.
    apply mk_nf_nf__equal; repeat constructor; assumption.
Qed.

(* DEP: match_ty__dcdbl, match_ty__sub_r_sound, match_valty__sub_r_complete,
        not__aname_sub_r_cname, not__aname_sub_r_pair,
        atom_pair_sub_r_pair__sub_r_components,
        atom_sub_r_union__atom_sub_r_component *)
Lemma atom_sub_r__decidable : forall (t1 t2 : ty),
    atom_type t1 ->
    valid t2 ->
    Decidable.decidable (|- t1 << t2).
Proof.
  intros t1 t2 Hat1. generalize dependent t2.
  induction Hat1.
  - (* CName *)
    intros t2 HTY2. destruct (match_ty__dcdbl (TCName n) t2) as [Hm | Hm].
    + left. apply match_ty__sub_r_sound. constructor. assumption.
    + right; intros Hcontra.
      assert (Hcontra': |- (TCName n) <$ t2)
        by (apply match_valty__sub_r_complete; assumption || constructor).
      contradiction.
  - (* AName *)
    intros t2; induction t2; intros HTY2.
    + (* CName *)
      right. apply not__aname_sub_r_cname.
    + (* AName *)
      destruct n; destruct a;
        try solve [left; (apply sub_r__rflxv; constructor) || constructor].
      right. intros Hcontra.
      remember (TAName NNum) as t1 eqn:Heq1. remember (TAName NReal) as t2 eqn:Heq2.
      induction Hcontra;
        try solve [inversion Heq1 | inversion Heq2].
      inversion Heq1; inversion Heq2; subst.
      inversion H1. subst. tauto.
    + (* Pair *)
      right. apply not__aname_sub_r_pair.
    + (* Union *)
      inversion HTY2; subst.
      destruct (IHt2_1 H1) as [IH1 | IH1];
        destruct (IHt2_2 H2) as [IH2 | IH2];
        try solve [
              left; apply SR_UnionR1; tauto
            | left; apply SR_UnionR2; tauto ].
      right; intros Hcontra.
      apply atom_sub_r_union__atom_sub_r_component in Hcontra.
      tauto. constructor.
    + (* Ext *)
      inversion HTY2.
  - (* Pair *)
    intros t' HTYt'. induction t'.
    + (* CName *)
      right; apply not__atom_pair_sub_r_cname; assumption.
    + (* AName *)
      right; apply not__atom_pair_sub_r_aname; assumption.
    + (* Pair *)
      inversion HTYt'; subst.
      destruct (IHHat1_1 t'1 H1) as [IH1 | IH1];
        destruct (IHHat1_2 t'2 H2) as [IH2 | IH2];
        solve [
            left; constructor; assumption
          | right; intros Hcontra;
            apply atom_pair_sub_r_pair__sub_r_components in Hcontra;
            try assumption;
            destruct Hcontra as [Hsub1 Hsub2]; contradiction ].
    + (* Union *)
      inversion HTYt'; subst.
      destruct (IHt'1 H1) as [IH1 | IH1];
        destruct (IHt'2 H2) as [IH2 | IH2];
        try solve [
              left; apply SR_UnionR1; assumption
            | left; apply SR_UnionR2; assumption ].
      right; intros Hcontra.
      apply atom_sub_r_union__atom_sub_r_component in Hcontra.
      tauto. constructor; assumption.
    + (* Ext *)
      inversion HTYt'.
Qed.

(* ----------------------------------------------------------------- *)
(** **** Main Properties *)
(* ----------------------------------------------------------------- *)

(* DEP: atom_sub_r__decidable, union_sub_r__components_sub_r *)
Lemma nf_sub_r__decidable : forall (t1 t2 : ty),
    InNF(t1) ->
    valid t2 ->
    Decidable.decidable (|- t1 << t2).
Proof.
  intros t1 t2 Hnf1. generalize dependent t2.
  induction Hnf1.
  - (* Atom *)
    intros t2 HTY2.
    destruct (atom_sub_r__decidable ta t2 H HTY2) as [Hm | Hm].
    + left; assumption.
    + right; assumption.
  - (* Union *)
    intros t' HTYt'.
    pose proof (nf__valid _ Hnf1_1) as HTY1. pose proof (nf__valid _ Hnf1_2) as HTY2.
    destruct (IHHnf1_1 t' HTYt') as [IH1 | IH1];
      destruct (IHHnf1_2 t' HTYt') as [IH2 | IH2];
      try solve [
            right; intros Hcontra;
            destruct (union_sub_r__components_sub_r _ _ _ HTY1 HTY2 Hcontra) as [Hsub1 Hsub2];
            contradiction ].
    left; constructor; assumption.
Qed.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.ProgramState.
Require Import Logic.HoareLogic.BigStepSemantics.

(***************************************)
(* Type Classes                        *)
(***************************************)

Class HoareTriple (L: Language) (P: ProgrammingLanguage) (HLan: Language): Type := {
  Assertion := @expr L;
  triple: Assertion -> cmd -> Assertion -> @expr HLan
}.

Definition triple_valid {L: Language} {P: ProgrammingLanguage} {HLan: Language} {TI: Semantics HLan unit_MD} (t: @expr HLan): Prop := @satisfies _ _ TI tt t.

Declare Scope hoare_logic.

Notation "|==  x" := (triple_valid x) (at level 71, no associativity) : hoare_logic.
Notation "{{ P }} c {{ Q }}" := (triple P c Q) (at level 80, no associativity) : hoare_logic.

Local Open Scope hoare_logic.
(*
Class TripleInterpretation_Partial (L: Language) (P: ProgrammingLanguage) (HLan: Language) {HT: HoareTriple L P HLan} (MD: Model) (BSS: BigStepSemantics P model) (SM: Semantics L MD) (TI: Semantics HLan unit_MD) : Type := {
  partial_valid_spec: forall (P: Assertion) (c: cmd) (Q: Assertion),
    (|== {{ P }} c {{ Q }}) <->
    triple_partial_valid P c Q
}.

Class TripleInterpretation_Total (L: Language) (P: ProgrammingLanguage) (HLan: Language) {HT: HoareTriple L P HLan} (MD: Model) (BSS: BigStepSemantics P model) (SM: Semantics L MD) (TI: Semantics HLan unit_MD) : Type := {
  total_valid_spec: forall (P: Assertion) (c: cmd) (Q: Assertion),
    (|== {{ P }} c {{ Q }}) <->
    triple_total_valid P c Q
}.
*)


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** This module contains additional definitions and lemmas on strings,
 including a total order relation. *)

Require Import Orders.
Require Import Ascii.
Require Import List.
Require Import String.
Require Import Arith.
Require Import Min.
Require Import Equivalence.
Require Import EquivDec.
Require Import Compare_dec.
Require Import Lia.
Require Import CoqLibAdd.

(** * Total order on characters *)

Module AsciiOrder <: OrderedTypeFull with Definition t:=ascii.
  Definition t:= ascii.
  Definition eq := @eq t.
  Definition eq_equiv : (Equivalence eq) := eq_equivalence.
  Definition eq_dec := ascii_dec.

  (* This could be done more directly, but this suffices *)
  Definition compare (a b:ascii) : comparison :=
    Nat.compare (nat_of_ascii a) (nat_of_ascii b).

  Definition lt (a b:ascii) := compare a b = Lt.

  Lemma lt_strorder : StrictOrder lt.
  Proof.
    split; repeat red; unfold lt, compare; intros;
      repeat match goal with
             | [H:Nat.compare _ _ = Lt |- _ ] => apply nat_compare_lt in H
             | [|- Nat.compare _ _ = Lt ] => apply nat_compare_lt
             end; lia.
  Qed.

  Lemma lt_compat : Proper (eq ==> eq ==> iff) lt.
  Proof.
    unfold Proper, respectful, eq; intros; subst; intuition.
  Qed.

  Lemma compare_eq_iff a b: compare a b = Eq <-> a = b.
  Proof.
    unfold AsciiOrder.compare.
    generalize (Nat.compare_eq_iff (nat_of_ascii a) (nat_of_ascii b)).
    destruct 1; split; intros; subst.
    - specialize (H H1).
      apply (f_equal ascii_of_nat) in H.
      repeat rewrite ascii_nat_embedding in H.
      trivial.
    - auto.
  Qed.

  Lemma compare_spec :
    forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
  Proof.
    intros. unfold eq, lt, compare.
    generalize (Nat.compare_spec (nat_of_ascii x) (nat_of_ascii y)); intros nc.
    inversion nc.
    - apply (f_equal ascii_of_nat) in H0.
      repeat rewrite ascii_nat_embedding in H0.
      subst. auto.
    - eauto.
    - constructor.
      apply nat_compare_lt. trivial.
  Qed.

  Lemma trichotemy a b : {lt a b} + {eq a b} + {lt b a}.
  Proof.
    generalize (compare_spec a b); intros nc.
    destruct (compare a b);
      [left; right|left;left|right]; inversion nc; trivial.
  Defined.

  Definition le (a b:ascii) :=
    match compare a b with
    | Lt => True
    | Eq => True
    | Gt => False
    end.

  Lemma le_lteq : forall x y : t, le x y <-> lt x y \/ eq x y.
  Proof.
    intros.
    generalize (compare_spec x y); inversion 1;
      unfold le, lt, eq in *;
      case_eq (compare x y); intuition congruence.
  Qed.

  Lemma compare_refl_eq a: compare a a = Eq.
  Proof.
    unfold AsciiOrder.compare.
    rewrite (Nat.compare_eq_iff (nat_of_ascii a) (nat_of_ascii a)); trivial.
  Qed.

End AsciiOrder.

(** * Total order on strings *)

Module StringOrder <: OrderedTypeFull with Definition t:=string.
  Definition t:= string.
  Definition eq := @eq t.
  Definition eq_equiv : (Equivalence eq) := eq_equivalence.
  Definition eq_dec := string_dec.

  Fixpoint compare (a:string) (b:string) : comparison :=
    match a, b with
    | EmptyString, EmptyString => Eq
    | EmptyString, String _ _ => Lt
    | String _ _, EmptyString => Gt
    | String a' a's, String b' b's =>
      match AsciiOrder.compare a' b' with
      | Lt => Lt
      | Eq => compare a's b's
      | Gt => Gt
      end
    end.

  Definition lt (a b:string) := compare a b = Lt.

  Lemma compare_spec :
    forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
  Proof.
    unfold eq, lt.
    induction x; destruct y; simpl in *; eauto.
    specialize (IHx y).
    case_eq (AsciiOrder.compare_spec a a0); intros.
    - unfold AsciiOrder.eq in *; subst.
      rewrite AsciiOrder.compare_refl_eq.
      inversion IHx; simpl; subst; eauto.
    - eauto.
    - unfold AsciiOrder.lt in *; rewrite l; eauto.
  Qed.

  Lemma trichotemy a b : {lt a b} + {eq a b} + {lt b a}.
  Proof.
    generalize (compare_spec a b); intros nc.
    destruct (compare a b);
      [left; right|left;left|right]; inversion nc; trivial.
  Defined.

  Lemma compare_refl_eq a: compare a a = Eq.
  Proof.
    induction a; simpl in *; eauto.
    rewrite AsciiOrder.compare_refl_eq; trivial.
  Qed.

  Lemma compare_eq_iff a b: compare a b = Eq <-> a = b.
  Proof.
    split; [| intros; subst; apply compare_refl_eq].
    revert b.
    induction a; destruct b; simpl in *; eauto; try congruence.
    generalize (AsciiOrder.compare_eq_iff a a1).
    intros. specialize (IHa b).
    destruct (AsciiOrder.compare a a1); intuition; congruence.
  Qed.

  Instance lt_strorder : StrictOrder lt.
  Proof.
    split; repeat red; unfold lt.
    - intros a H; rewrite compare_refl_eq in H. discriminate.
    - induction x; destruct y; destruct z; simpl; eauto; try congruence.
      intros. specialize (IHx y z).
      generalize (@StrictOrder_Transitive _ _ (AsciiOrder.lt_strorder) a a0 a1).
      unfold AsciiOrder.lt. intros AC.
      case_eq (AsciiOrder.compare a a0);
        intros re; rewrite re in *; try congruence;
          case_eq (AsciiOrder.compare a0 a1);
          intros re2; rewrite re2 in *; try congruence;
            try rewrite AsciiOrder.compare_eq_iff in *; subst;
              try rewrite re in*; try rewrite re2 in *;
                try rewrite AC by trivial;
                try rewrite AsciiOrder.compare_refl_eq;
                auto.
  Qed.

  Lemma lt_compat : Proper (eq ==> eq ==> iff) lt.
  Proof.
    unfold Proper, respectful, eq; intros; subst; intuition.
  Qed.

  Program Definition lt_dec (a b:string) : {lt a b} + {~lt a b}
    := match compare a b with
       | Lt => left _
       | Eq => right _
       | Gt => right _
       end.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    trivial.
  Qed.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    rewrite H0. apply irreflexivity.
  Qed.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    intro l2. apply (asymmetry H0 l2).
  Qed.

  Definition le (a b:string) :=
    match compare a b with
    | Lt => True
    | Eq => True
    | Gt => False
    end.

  Lemma le_lteq : forall x y : t, le x y <-> lt x y \/ eq x y.
  Proof.
    intros.
    generalize (compare_spec x y); inversion 1;
      unfold le, lt, eq in *;
      case_eq (compare x y); intuition congruence.
  Qed.

  Program Definition le_dec (a b:string) : {le a b} + {~le a b}
    := match compare a b with
       | Lt => left _
       | Eq => left _
       | Gt => right _
       end.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    apply le_lteq.
    intuition.
  Qed.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    apply le_lteq.
    intuition.
  Qed.
  Next Obligation.
    generalize (compare_spec a b); rewrite <- Heq_anonymous; inversion 1.
    intro l2.
    apply le_lteq in l2.
    destruct l2.
    - apply (asymmetry H0 H1).
    - rewrite H1 in H0. apply (irreflexivity H0).
  Qed.

End StringOrder.

(** * String prefixes *)

Section Prefix.
  Lemma substring_zero s :
    substring 0 0 s = ""%string.
  Proof.
    induction s; reflexivity.
  Qed.

  Lemma substring_S a m s :
    substring 0 (S m) (String a s) = String a (substring 0 m s).
  Proof.
    reflexivity.
  Qed.

  Lemma append_string_distr a s1 s2 :
    (String a s1 ++ s2 = String a (s1 ++ s2))%string.
  Proof.
    auto.
  Qed.

  Lemma append_eq_inv1 x y z : append x y = append x z -> y = z.
  Proof.
    revert y z.
    induction x; simpl; trivial; intros.
    inversion H; subst.
    auto.
  Qed.

  Lemma prefix_refl y : prefix y y = true.
  Proof.
    induction y; simpl; trivial.
    match_destr; congruence.
  Qed.

  Lemma substring_append_cancel x y :
    substring (String.length x) (String.length y) (append x y) = y.
  Proof.
    revert y.
    induction x; simpl; intros.
    - apply prefix_correct. apply prefix_refl.
    - trivial.
  Qed.

  Lemma string_length_append x y :
    String.length (append x y) = String.length x + String.length y.
  Proof.
    revert y.
    induction x; simpl; auto.
  Qed.

  Lemma prefix_nil post : prefix ""%string post = true.
  Proof.
    destruct post; trivial.
  Qed.

  Lemma prefix_app pre post : prefix pre (append pre post) = true.
  Proof.
    revert post.
    induction pre; intros; simpl.
    - apply prefix_nil.
    - match_destr; intuition.
  Qed.

  Lemma prefix_break {pre x} :
    prefix pre x = true ->
    {y | x = append pre y}.
  Proof.
    revert x.
    induction pre; simpl.
    - eauto.
    - destruct x; simpl; try discriminate.
      match_destr.
      subst; intros p.
      destruct (IHpre _ p).
      subst.
      eauto.
  Qed.

  Lemma substring_split s n m l :
    append (substring s n l) (substring (s+n) m l) = substring s (n+m) l.
  Proof.
    revert n m s.
    induction l; simpl; destruct s; destruct n; simpl; trivial.
    - f_equal.
      apply IHl.
    - rewrite IHl; simpl; trivial.
    - rewrite IHl. simpl; trivial.
  Qed.

  Lemma substring_all l :
    substring 0 (String.length l) l = l.
  Proof.
    induction l; simpl; congruence.
  Qed.

  Lemma substring_bounded s n l :
    substring s n l = substring s (min n (String.length l - s)) l.
  Proof.
    revert s n.
    induction l; destruct s; destruct n; simpl; trivial.
    - rewrite IHl; simpl.
      f_equal.
      f_equal.
      f_equal.
      lia.
    - rewrite IHl.
      match_case.
  Qed.

  Lemma substring_le_prefix s n m l :
    n <= m ->
    prefix (substring s n l) (substring s m l) = true.
  Proof.
    revert s n m.
    induction l; destruct s; destruct n; destruct m; simpl; trivial;
      try lia; intuition.
    match_destr; intuition.
  Qed.

  Lemma substring_prefix n l :
    prefix (substring 0 n l) l = true.
  Proof.
    rewrite substring_bounded.
    rewrite <- (substring_all l) at 3.
    apply substring_le_prefix.
    replace (String.length l - 0) with (String.length l) by lia.
    apply le_min_r.
  Qed.

  Lemma in_of_append pre y l :
    In (append pre y) l <->
    In y (map
            (fun x => substring (String.length pre) (String.length x - String.length pre) x)
            (filter (prefix pre) l)).
  Proof.
    rewrite in_map_iff.
    split; intros.
    - exists (append pre y).
      rewrite string_length_append.
      replace ((String.length pre + String.length y - String.length pre))
        with (String.length y) by lia.
      rewrite substring_append_cancel.
      split; trivial.
      apply filter_In.
      split; trivial.
      apply prefix_app.
    - destruct H as [x [subx inx]]; subst.
      apply filter_In in inx.
      destruct inx as [inx prex].
      destruct (prefix_break prex).
      subst.
      rewrite string_length_append.
      replace ((String.length pre + String.length x0 - String.length pre))
        with (String.length x0) by lia.
      rewrite substring_append_cancel.
      trivial.
  Qed.

  Lemma append_ass s1 s2 s3 : ((s1 ++ s2) ++ s3 = s1 ++ s2 ++ s3)%string.
  Proof.
    revert s2 s3.
    induction s1; simpl.
    - trivial.
    - intros. rewrite IHs1; trivial.
  Qed.

End Prefix.

(** * Character map over strings *)

Section MapString.
  Fixpoint map_string (f:ascii->ascii) (s:string)
    := match s with
       | EmptyString => EmptyString
       | String a s' => String (f a) (map_string f s')
       end.

  Fixpoint flat_map_string (f:ascii->string) (s:string)
    := match s with
       | EmptyString => EmptyString
       | String a s' => append (f a) (flat_map_string f s')
       end.

  Global Instance ascii_dec : EqDec ascii eq
    := ascii_dec.
End MapString.

(** Support for 'like' on strings *)

Section Join.
  Definition map_concat {A} separator (f:A -> string) (elems:list A) : string :=
    match elems with
    | nil => ""
    | e :: elems' =>
      (fold_left (fun acc e => acc ++ separator ++ (f e)) elems' (f e))%string
    end.

End Join.

(** * Conversion between lists of characters and strings *)

Section AsciiToString.

  Fixpoint string_reverse_helper (s:string) (acc:string)
    := match s with
       | EmptyString => acc
       | String x xs => string_reverse_helper xs (String x acc)
       end.

  Definition string_reverse (s:string) := string_reverse_helper s EmptyString.

  Fixpoint string_to_list (s:string) : list ascii
    := match s with
       | EmptyString => nil
       | String x xs => cons x (string_to_list xs)
       end.

  Fixpoint list_to_string (l:list ascii) : string
    := match l with
       | nil => EmptyString
       | cons x xs => String x (list_to_string xs)
       end.

  Lemma string_to_list_to_string (s:string) :
    list_to_string (string_to_list s) = s.
  Proof.
    induction s; simpl; intuition congruence.
  Qed.

  Lemma list_to_string_to_list (l:list ascii) :
    string_to_list (list_to_string l) = l.
  Proof.
    induction l; simpl; intuition congruence.
  Qed.

  Lemma string_to_list_inj (x y:string) :
    string_to_list x = string_to_list y -> x = y.
  Proof.
    intros.
    generalize (f_equal list_to_string H); intros fe.
    repeat rewrite  string_to_list_to_string in fe; trivial.
  Qed.

  Lemma list_to_string_inj (x y:list ascii) :
    list_to_string x = list_to_string y -> x = y.
  Proof.
    intros.
    generalize (f_equal string_to_list H); intros fe.
    repeat rewrite  list_to_string_to_list in fe; trivial.
  Qed.

  Lemma string_reverse_helper_reverse_append s acc:
    string_reverse_helper s acc = list_to_string (List.rev_append (string_to_list s) (string_to_list acc)).
  Proof.
    revert acc.
    induction s; simpl; intros.
    - rewrite string_to_list_to_string; trivial.
    - rewrite IHs. simpl; auto.
  Qed.

  Lemma string_reverse_reverse s :
    string_reverse s = list_to_string (List.rev (string_to_list s)).
  Proof.
    rewrite List.rev_alt. apply string_reverse_helper_reverse_append.
  Qed.

  Lemma string_reverse_involutive x : string_reverse (string_reverse x) = x.
  Proof.
    repeat rewrite string_reverse_reverse.
    rewrite list_to_string_to_list, List.rev_involutive, string_to_list_to_string.
    trivial.
  Qed.

  Lemma string_reverse_inj x y :
    string_reverse x = string_reverse y ->
    x = y.
  Proof.
    intros re.
    generalize (f_equal string_reverse re); intros fe.
    repeat rewrite string_reverse_involutive in fe; trivial.
  Qed.

  Lemma lt_contr1 s1 s2 :
    ~StringOrder.lt s1 s2 -> ~StringOrder.lt s2 s1 -> StringOrder.eq s1 s2.
  Proof.
    unfold not; intros.
    generalize (StringOrder.trichotemy s1 s2); intros.
    inversion H1.
    elim H2; intros.
    congruence.
    assumption.
    congruence.
  Qed.

  Lemma lt_contr2 s1 s2 :
    StringOrder.lt s1 s2 -> ~StringOrder.eq s1 s2.
  Proof.
    compare s1 s2.
    intros. rewrite e in *; clear e.
    unfold not; intros.
    apply asymmetry with (x := s2) (y := s2); assumption.
    intros. assumption.
    apply ascii_dec.
  Qed.

  Lemma lt_contr3 s :
    StringOrder.lt s s -> False.
  Proof.
    generalize (lt_contr2 s s); intros.
    unfold not in *.
    apply (H H0).
    reflexivity.
  Qed.

End AsciiToString.

Section Like.
  (* This is intended to be like the SQL like operation *)
  (*  Definition string_like (s:pattern) *)

  Inductive like_clause :=
  | like_literal (literal:string) : like_clause
  | like_any_char : like_clause
  | like_any_string : like_clause.

  Fixpoint make_like_clause (s:string) (escape:option ascii) {struct s}: list like_clause
    := match s with
       | EmptyString => nil
       | String "_"%char tail => like_any_char :: make_like_clause tail escape
       | String "%"%char tail => like_any_string :: make_like_clause tail escape
       | other =>
         (fix make_like_literal_clause (ss:string)  (acc:string) {struct ss} : list like_clause
          := match ss with
             | EmptyString => like_literal (string_reverse acc) :: nil
             | String "_"%char tail => like_literal (string_reverse acc) :: like_any_char :: make_like_clause tail escape
             | String "%"%char tail => like_literal (string_reverse acc) :: like_any_string :: make_like_clause tail escape
             | String h tail =>
               if Some h == escape
               then
                 match tail with
                 | EmptyString =>
                   (* unclear what to do with an escape character at the end of the string.  We will interpret it as a literal character *)
                   like_literal (string_reverse (String h acc)) :: nil
                 | String "_"%char tail => make_like_literal_clause tail (String "_" acc)
                 | String "%"%char tail => make_like_literal_clause tail (String "%" acc)
                 | String nh ntail =>
                   if Some nh == escape
                   then make_like_literal_clause ntail (String nh acc)
                   else
                     (* unclear what to do with an escape character that is invalid.  We will interpret it as a literal character *)
                     make_like_literal_clause ntail (String nh (String h acc))
                 end
               else
                 make_like_literal_clause tail (String h acc)
             end
         ) other ""%string
       end.

  Example make_like_clause_example1 := make_like_clause "hello_there^^^%%" None.
  Example make_like_clause_example2 := make_like_clause "hello_there^^^%%" (Some "^"%char).

  (*
  Eval vm_compute in make_like_clause_example1.
  Eval vm_compute in make_like_clause_example2.
   *)

  Fixpoint  string_exists_suffix (f:string->bool) (s:string) : bool
    := f s ||
         match s with
         | EmptyString => false
         | String _ tail => string_exists_suffix f tail
         end.

  (* something like bayer-moore would be much more efficient.
     This implementation is known to have very poor performance *)
  Fixpoint like_clause_matches_string (pat:list like_clause) (s:string)
    := match pat with
       | nil => s ==b EmptyString
       | (like_literal literal)::rest =>
         andb (prefix literal s)
              (like_clause_matches_string rest (substring (String.length literal) (String.length s - String.length literal) s))
       | like_any_char::rest =>
         match s with
         | EmptyString => false
         | String _ tail => like_clause_matches_string rest tail
         end
       | like_any_string::rest =>
         string_exists_suffix (like_clause_matches_string rest) s
       end.

  (* This is intended to be like the SQL like operation *)
  Definition string_like (str pattern:string) (escape:option ascii) : bool
    := let pat_clause := make_like_clause pattern escape in
       like_clause_matches_string pat_clause str.

  Example string_like_example1 := string_like "hello there" "hello there" None.
  Example string_like_example2 := string_like "hello there" "hello %there" None.
  Example string_like_example3 := string_like "hello there" "he%th_re" None.
  Example string_like_example4 := string_like "hello there " "he%th_re" None.
  Example string_like_example5 := string_like "hello thethare" "he%th_re" None.
  Example string_like_example6 := string_like "hello thetheare" "he%th_re" None.

(*
  Eval vm_compute in string_like_example1.
  Eval vm_compute in string_like_example2.
  Eval vm_compute in string_like_example3.
  Eval vm_compute in string_like_example4.
  Eval vm_compute in string_like_example5.
  Eval vm_compute in string_like_example6.
 *)

End Like.