(** * Fresh Constants *)

Set Implicit Arguments.

Require Import Coq.Arith.Max.

Require Import decidable_In.
Require Import sublist.
Require Import language_syntax.

(** Remember that [constants] play the role of [parameters].
   In particular, we will show that fresh constants are as good as
   fresh parameters. *)

(** [new] chooses a fresh one which does not belong to lists. *)

Definition new (l:list name) : name := S (fold_right max 0 l).

Lemma new_no_zero : forall (l:list name), new l <> 0.
Proof.
  unfold new; intros; auto with arith.
Qed.

Lemma In_less : forall (n:name)(l:list name),
  n @ l ->
  n < new l.
Proof.
  unfold new; induction l; simpl; intro H; [elim H | ]; destruct H; subst; auto with arith.
  apply lt_le_trans with (m:= S (fold_right max 0 l)); eauto 2 with arith.
Qed.

Lemma new_fresh : forall l : list name, (new l) # l.
Proof.
  intros l H.
  elim (lt_irrefl (new l)).
  apply In_less; exact H.
Qed.

(** Freshness for a term *)

Lemma fresh_out_t : forall m (t: term m),
  (new (oc_t t)) # (oc_t t).
Proof.
  intros m t.
  exact (new_fresh (oc_t t)).
Qed.

(** Freshness for a formula *)

Lemma fresh_out_f : forall m (A:formula m),
  (new (oc_f A)) # (oc_f A).
Proof.
  intros m A.
  exact (new_fresh (oc_f A)).
Qed.

(** Choosing a fresh variable for a context *)

Definition fresh_out (Ga:context) : name := new (oc_c Ga).

(** Freshness for a context *)

Definition fresh (x:name)(Ga:context) : Prop :=
  x # (oc_c Ga).

Lemma fresh_out_spec : forall (Ga:context),
  fresh (fresh_out Ga) Ga.
Proof.
  unfold fresh; unfold fresh_out; intros Ga.
  exact (new_fresh (oc_c Ga)).
Qed.

Lemma fresh_fml_peel : forall a A Ga,
  fresh a (A::Ga) ->
  a # (oc_f A).
Proof.
  unfold fresh; simpl; intros; auto with datatypes.
Qed.

Lemma fresh_peel : forall a A Ga,
  fresh a (A::Ga) ->
  fresh a Ga.
Proof.
  unfold fresh; simpl; intros; auto with datatypes.
Qed.


(* Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
   Jean-Baptiste Tristan, and Edward Gan.

   This file is part of RockSalt.

   This file is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as
   published by the Free Software Foundation; either version 2 of
   the License, or (at your option) any later version.
*)

(** CheckDeterministic.v:  This file provides some routines to help try to
    prove that parsers are deterministic.  In particular, there's a function
    [disjoint_p p1 p2] which when it returns true, ensures that there is no
    string of tokens (i.e., bytes) that is accepted by both [p1] and [p2].
    This is achieved by computing the intersection of the two [regexps]
    corresponding to [p1] and [p2] and trying to show that that intersection
    is equivalent to [Zero].

    I coded a new version of regexps, here called [rexp] to avoid conflicts
    with the definition in [Parser.v], which includes intersection ([And_r]).
    To determine if an [rexp] is equivalent to [Zero], we (a) check to see
    if the [rexp] is nullable (if so, then it accepts [nil] so it's not
    equivalent to [Zero]), and otherwise, calculate the derivative of the
    [rexp] with respect to each possible input token, and then recursively
    see if the derivatives are zero.  If all of the derivatives are zero,
    then the original expression is equivalent to zero.
*)
Require Import Coqlib.
Require Import Parser.
Require Import Ascii.
Require Import String.
Require Import List.
Require Import Bits.
Require Import Decode.
Require Import Eqdep.
Unset Automatic Introduction.
Set Implicit Arguments.
Open Scope char_scope.
Require ExtrOcamlString.
Require ExtrOcamlNatBigInt.
Require ExtrOcamlNatInt.
Import X86_PARSER_ARG.
Import X86_PARSER.
Import X86_BASE_PARSER.

(** Our regular expressions with intersection ([And_r]).  We need
    the support for intersection to test whether two parsers overlap
    on strings.  *)
Inductive rexp : Type :=
| Any_r : rexp
| Char_r : char_p -> rexp
| Eps_r : rexp
| Cat_r : rexp -> rexp -> rexp
| Zero_r : rexp
| Alt_r : rexp -> rexp -> rexp
| Star_r : rexp -> rexp
| And_r : rexp -> rexp -> rexp.

(** Denotational semantics of regular expressions. *)
Inductive in_rexp : rexp -> list char_p -> Prop :=
| Any_ri : forall c, in_rexp Any_r (c::nil)
| Char_ri : forall c, in_rexp (Char_r c) (c::nil)
| Eps_ri : in_rexp Eps_r nil
| Cat_ri : forall r1 r2 cs1 cs2 cs,
  in_rexp r1 cs1 -> in_rexp r2 cs2 ->
  cs = cs1 ++ cs2 -> in_rexp (Cat_r r1 r2) cs
| Alt_left_ri : forall r1 r2 cs, in_rexp r1 cs -> in_rexp (Alt_r r1 r2) cs
| Alt_right_ri : forall r1 r2 cs, in_rexp r2 cs -> in_rexp (Alt_r r1 r2) cs
| Star_eps_ri : forall r, in_rexp (Star_r r) nil
| Star_cat_ri : forall r cs1 cs2 cs,
  cs1 <> nil -> in_rexp r cs1 -> in_rexp (Star_r r) cs2 ->
  cs = cs1 ++ cs2 ->
  in_rexp (Star_r r) cs
| And_ri : forall r1 r2 cs, in_rexp r1 cs -> in_rexp r2 cs -> in_rexp (And_r r1 r2) cs.
Hint Constructors in_rexp.

Ltac mysimp :=
  simpl in * ; intros ;
    repeat match goal with
             | [ |- context[char_eq ?x ?y] ] => destruct (char_eq x y) ; auto
             | [ |- _ /\ _ ] => split
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ |- context[ _ ++ nil ] ] => rewrite <- app_nil_end
             | [ H : exists x, _ |- _ ] => destruct H
             | [ H : _ \/ _ |- _] => destruct H
             | [ H : _ <-> _ |- _] => destruct H
             | [ |- _ <-> _ ] => split
             | [ H : _::_ = _::_ |- _] => injection H ; clear H
             | _ => idtac
           end ; auto.
Ltac s := repeat (mysimp ; subst).

Lemma cons_app A (x:A) (ys:list A) : x :: ys = (x::nil) ++ ys. auto. Qed.

(** I coded [rexp_eq] explicitly to return a [bool], because this seems
    to run faster than if we compute a proof of equality. *)
Fixpoint rexp_eq(r1 r2:rexp) : bool :=
  match r1, r2 with
    | Any_r, Any_r => true
    | Any_r, _ => false
    | Char_r c1, Char_r c2 => if char_eq c1 c2 then true else false
    | Char_r _, _ => false
    | Eps_r, Eps_r => true
    | Eps_r, _ => false
    | Cat_r r1 r2, Cat_r r3 r4 => rexp_eq r1 r3 && rexp_eq r2 r4
    | Cat_r _ _, _ => false
    | Zero_r, Zero_r => true
    | Zero_r, _ => false
    | Alt_r r1 r2, Alt_r r3 r4 => rexp_eq r1 r3 && rexp_eq r2 r4
    | Alt_r _ _, _ => false
    | Star_r r1, Star_r r2 => rexp_eq r1 r2
    | Star_r _, _ => false
    | And_r r1 r2, And_r r3 r4 => rexp_eq r1 r3 && rexp_eq r2 r4
    | And_r _ _, _ => false
  end.

(** Proof that [rexp_eq] really does compute equality. *)
Lemma rexp_eq_corr r1 r2 :
  if rexp_eq r1 r2 then r1 = r2 else r1 <> r2.
Proof.
  induction r1 ; destruct r2 ; simpl ; try congruence ; unfold andb in * ;
    repeat
  match goal with
    | [ |- context[if char_eq ?c ?c0 then _ else _] ] =>
      destruct (char_eq c c0) ; subst ; try congruence
    | [ H : (forall r2, if rexp_eq ?r1 r2 then _ else _) |-
            context[if rexp_eq ?r1 ?r2 then _ else _] ] =>
    generalize (H r2) ; clear H ; intro H ; destruct (rexp_eq r1 r2) ; subst
    | _ => try congruence ; auto
  end.
Qed.

Ltac in_inv :=
  match goal with
    | [ H : in_rexp Eps_r _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp Any_r _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp (Char_r _) _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp (Cat_r _ _) _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp (Alt_r _ _) _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp (And_r _ _) _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp Zero_r _ |- _ ] => inversion H
    | [ |- context [if rexp_eq ?r1 ?r2 then _ else _] ] =>
      generalize (rexp_eq_corr r1 r2) ; intro ;
      destruct (rexp_eq r1 r2) ; try congruence
    | [ H : context [if rexp_eq ?r1 ?r2 then _ else _] |- _ ] =>
      generalize (rexp_eq_corr r1 r2) ; intro ;
      destruct (rexp_eq r1 r2) ; try congruence
    | _ => s
  end.

(** Optimizing [cat] constructor. *)
Definition OptCat_r(r1 r2:rexp) : rexp :=
  match r1, r2 with
    | Zero_r, _ => Zero_r
    | Eps_r, r2 => r2
    | _, Zero_r => Zero_r
    | r1, Eps_r => r1
    | r1, r2 => Cat_r r1 r2
  end.

(** [OptCat_r] is equivalent to [Cat_r]. *)
Lemma opt_cat_r_corr : forall r1 r2 s,
  in_rexp (Cat_r r1 r2) s <-> in_rexp (OptCat_r r1 r2) s.
Proof.
  destruct r1 ; repeat in_inv ; eauto ; destruct r2 ; repeat in_inv ; eauto ;
    try (rewrite cons_app ; eauto ; fail) ;
    try (rewrite app_nil_end ; eauto ; fail).
Qed.
Hint Resolve opt_cat_r_corr.

(** Optimizing [alt] constructor. *)
Definition OptAlt_r(r1 r2:rexp) : rexp :=
  match r1, r2 with
    | Zero_r, r2 => r2
    | r1, Zero_r => r1
    | Char_r true, Char_r false => Any_r
    | Char_r false, Char_r true => Any_r
    | r1, r2 => if rexp_eq r1 r2 then r1 else Alt_r r1 r2
  end.

(** [Alt_r r r] is equivalent to [r] *)
Lemma eq_rexp_alt1 r s:
  in_rexp (Alt_r r r) s <-> in_rexp r s.
Proof.
  repeat in_inv.
Qed.
Hint Resolve eq_rexp_alt1.

(** [OptAlt_r] is equivalent to [Alt]. *)
Lemma opt_alt_r_corr : forall r1 r2 s,
  in_rexp (Alt_r r1 r2) s <-> in_rexp (OptAlt_r r1 r2) s.
Proof.
  destruct r1 ; simpl ; destruct r2 ; unfold andb ; simpl ; repeat in_inv ;
    repeat
    match goal with
      | [ H : _ = _ |- _] => injection H ; clear H ; intros ; subst ; eauto
      | [ |- in_rexp (if ?c then _ else _) _ ] => destruct c ; simpl ; eauto
      | [ H : in_rexp (if ?c then _ else _) _ |- _] => destruct c ; simpl in * ;
        repeat in_inv ; eauto
      | _ => eauto
    end ; destruct c ; eauto.
Qed.
Hint Resolve opt_alt_r_corr.

(** Returns [Eps_r] if [r] accepts the empty string, else returns [Zero_r]. *)
Fixpoint null_r (r:rexp) : rexp :=
  match r with
    | Any_r => Zero_r
    | Char_r _ => Zero_r
    | Eps_r => Eps_r
    | Zero_r => Zero_r
    | Alt_r r1 r2 => OptAlt_r (null_r r1) (null_r r2)
    | Cat_r r1 r2 => OptCat_r (null_r r1) (null_r r2)
    | Star_r r => Eps_r
    | And_r r1 r2 => match null_r r1, null_r r2 with
                       | Zero_r, _ => Zero_r
                       | _, Zero_r => Zero_r
                       | _, _ => Eps_r
                     end
  end.

(** [null_r] returns either [Eps_r] or [Zero_r]. *)
Lemma null_r_eps_zero : forall r, null_r r = Eps_r \/ null_r r = Zero_r.
Proof.
  induction r ; s ;
    repeat
  match goal with
    | [ H : ?r = Eps_r |- _ ] => rewrite H ; clear H ; simpl
    | [ H : ?r = Zero_r |- _ ] => rewrite H ; clear H ; simpl
    | _ => idtac
  end ; auto.
Qed.

(** If [s] is in denotation of [null_r r] then [s] is [nil]. *)
Lemma null_r_corr' : forall r s,
  in_rexp r s ->
  forall r', r = null_r r' -> s = nil.
Proof.
  induction 1 ; intros ; generalize (null_r_eps_zero r') ; intro NEZ ; destruct NEZ ;
    try congruence.
Qed.

Lemma null_r_corr1 : forall r s, in_rexp (null_r r) s -> s = nil.
Proof.
  intros ; eapply null_r_corr' ; eauto.
Qed.

Lemma nil_is_nil_app_nil : forall A (cs1 cs2:list A),
  nil = cs1 ++ cs2 -> cs1 = nil /\ cs2 = nil.
Proof.
  destruct cs1 ; destruct cs2 ; simpl ; intros ; try congruence. auto.
Qed.

(** If [nil] is in the denotation of [r], then it's also in [null_r r]. *)
Lemma null_r_corr2 : forall r s, in_rexp r s -> s = nil -> in_rexp (null_r r) s.
Proof.
  induction 1 ; repeat in_inv ; try congruence ;
    try (apply opt_alt_r_corr ; eauto).
  generalize (nil_is_nil_app_nil _ _ (sym_eq H2)). repeat in_inv.
  apply opt_cat_r_corr. rewrite app_nil_end. eauto.
  generalize (nil_is_nil_app_nil _ _ (sym_eq H3)). repeat in_inv.
  generalize (null_r_eps_zero r1) (null_r_eps_zero r2).
  generalize (IHin_rexp1 (eq_refl _)). generalize (IHin_rexp2 (eq_refl _)).
  repeat in_inv ; rewrite H3 in * ; rewrite H4 in * ; in_inv ; eauto.
Qed.
Hint Resolve null_r_corr2.

(** If [nil] is in the denotation of [null_r r], then it's also in the
    denotation of [r]. *)
Lemma null_r_corr3 r : in_rexp (null_r r) nil -> in_rexp r nil.
Proof.
  induction r ; repeat in_inv ;
  try (generalize (proj2 (opt_alt_r_corr _ _ _) H)) ;
  try (generalize (proj2 (opt_and_r_corr _ _ _) H)) ;
    repeat in_inv.
  generalize (proj2 (opt_cat_r_corr _ _ _) H). clear H. repeat in_inv. rewrite H5.
  generalize (nil_is_nil_app_nil _ _ H5). in_inv. rewrite app_nil_end. eauto.
  generalize (null_r_eps_zero r1) (null_r_eps_zero r2) ; intros A1 A2.
  destruct A1 as [A1 | A1]; rewrite A1 in * ;
    destruct A2 as [A2 | A2 ] ; rewrite A2 in * ; eauto.
Qed.

(** If [null_r r] is [Eps_r], then it accepts [nil]. *)
Lemma null_r_corr4 : forall r, null_r r = Eps_r -> in_rexp r nil.
Proof.
  induction r ; simpl ; intros ; try congruence ; eauto ; try (
  generalize (null_r_eps_zero r1) (null_r_eps_zero r2) ; intros H1 H2 ;
    destruct H1 as [H1 | H1 ]; rewrite H1 in * ; simpl in * ; try congruence ;
      destruct H2 as [H2 | H2]; rewrite H2 in * ; simpl in * ; try congruence) ; eauto.
Qed.
Hint Resolve null_r_corr4.

(** Optimizing [And_r r1 r2]. *)
Definition OptAnd_r(r1 r2:rexp) : rexp :=
  match r1, r2 with
    | _, Zero_r => Zero_r
    | Zero_r, _ => Zero_r
    | Eps_r, r2 => null_r r2
    | r1, Eps_r => null_r r1
    | Any_r, Char_r c => Char_r c
    | Char_r c, Any_r => Char_r c
    | Char_r c1, Char_r c2 => if char_eq c1 c2 then Char_r c1 else Zero_r
    | r1, r2 => if rexp_eq r1 r2 then r1 else And_r r1 r2
  end.

Ltac pv_opt :=
  repeat
  match goal with
    | [ |- in_rexp (OptCat_r _ _) _ ] => apply opt_cat_r_corr
    | [ |- in_rexp (OptAlt_r _ _) _ ] => apply opt_alt_r_corr
    | [ H : nil = ?cs1 ++ ?cs2 |- _] => generalize (nil_is_nil_app_nil _ _ H) ; s
    | [ H : in_rexp (OptCat_r _ _) _ |- _ ] =>
      generalize (proj2 (opt_cat_r_corr _ _ _) H) ; clear H ; repeat in_inv
    | [ H : in_rexp (OptAlt_r _ _) _ |- _ ] =>
      generalize (proj2 (opt_alt_r_corr _ _ _) H) ; clear H ; repeat in_inv
    | [ H : in_rexp (null_r ?r) _ |- _ ] =>
      let H1 := fresh "H" in
      let H2 := fresh "H" in
      let H3 := fresh "H" in
      generalize (null_r_corr1 _ H)  ; intro ; subst ;
      generalize (null_r_corr3 _ H) ;
      generalize (null_r_corr2 H (eq_refl _)) ;
      generalize (null_r_eps_zero r) ;
        intros H1 H2 H3 ; destruct H1 ; rewrite H1 in * ; s ; clear H
    | [ H : in_rexp ?r nil |- context [null_r ?r] ] =>
      let H1 := fresh "H" in
      let H2 := fresh "H" in
        generalize (null_r_corr2 H (eq_refl _)) ;
          generalize (null_r_eps_zero r) ;
            intros H1 H2 ; destruct H1 ; rewrite H1 in *
    | [ H : in_rexp (match null_r ?r with | Any_r => _ | Char_r _ => _ | Eps_r => _
                       | Cat_r _ _ => _ | Zero_r => _ | Alt_r _ _ => _ | Star_r _ => _
                         | And_r _ _ => _ end) _ |- _] =>
    let H := fresh "H" in
      generalize (null_r_eps_zero r) ; intros H ; destruct H ; rewrite H in *
    | [ |- in_rexp (And_r _ _) _ ] => constructor
    | [ H : Cat_r _ _ = Cat_r _ _ |- _] => injection H ; clear H ; s
    | [ H : Alt_r _ _ = Alt_r _ _ |- _] => injection H ; clear H ; s
    | [ H : And_r _ _ = And_r _ _ |- _] => injection H ; clear H ; s
    | [ H : Star_r _ = Star_r _ |- _] => injection H ; clear H ; s
    | _ => in_inv ; eauto
  end.

(** [OptAnd_r] is equivalent to [And_r]. *)
Lemma opt_and_r_corr : forall r1 r2 s,
  in_rexp (And_r r1 r2) s <-> in_rexp (OptAnd_r r1 r2) s.
Proof.
  destruct r1 ; simpl ; destruct r2 ; unfold andb ; simpl;
    repeat in_inv ; try congruence ; pv_opt.
Qed.

(** Convert a [parser] to an [rexp]. *)
Fixpoint parser2rexp t (p:parser t) : rexp :=
  match p with
    | Any_p => Any_r
    | Char_p c => Char_r c
    | Eps_p => Eps_r
    | Cat_p t1 t2 r1 r2 => OptCat_r (parser2rexp r1) (parser2rexp r2)
    | Zero_p t => Zero_r
    | Alt_p t r1 r2 => OptAlt_r (parser2rexp r1) (parser2rexp r2)
    | Star_p t r => Star_r (parser2rexp r)
    | Map_p t1 t2 f r => parser2rexp r
  end.

(** If [s] and [v] are in the denotation of [p], then [s] is in the denotation of
    [parser2rexp p]. *)
Lemma parse2rexp_corr1 t (p:parser t) s v :
  in_parser p s v -> in_rexp (parser2rexp p) s.
Proof.
  induction 1 ; subst ; repeat in_inv ;
    try (apply opt_alt_r_corr ||apply opt_cat_r_corr) ; eauto.
Qed.

(** If [s] is in the denotation of [parser2rexp p], then there exists some [v],
    such that [s] and [v] are in the denotation of [p]. *)
Lemma parse2rexp_corr2 t (p:parser t) s :
  in_rexp (parser2rexp p) s ->
    exists v, in_parser p s v.
Proof.
  induction p ; repeat in_inv ; try (econstructor ; econstructor ; eauto ; fail).
   generalize (proj2 (opt_cat_r_corr (parser2rexp p1) (parser2rexp p2) s) H).
   repeat in_inv. generalize (IHp1 _ H3). generalize (IHp2 _ H4). s.
   repeat econstructor ; eauto.
   generalize (proj2 (opt_alt_r_corr _ _ _) H). repeat in_inv.
   generalize (IHp1 _ H4) ; repeat in_inv. repeat econstructor ; eauto.
   generalize (IHp2 _ H4) ; repeat in_inv. econstructor. eapply Alt_right_pi. eauto.
   Focus 2. generalize (IHp _ H). s. econstructor. econstructor. eauto. eauto.
   generalize s H IHp. clear s H IHp. generalize (parser2rexp p).
   intros r s H. remember (Star_r r) as r'. generalize Heqr'. clear Heqr'.
   induction H ; intros ; try congruence ; injection Heqr' ; intros ; subst ; clear
     Heqr'. exists nil. constructor ; auto. generalize (IHin_rexp2 (eq_refl _) IHp).
   clear IHin_rexp1 IHin_rexp2. intros. destruct H2. generalize (IHp _ H0).
   intros. destruct H3. econstructor. eapply Star_cat_pi. eauto. eauto. auto.
   eauto. auto.
Qed.

(** Returns true if [r] accepts the empty string, false otherwise -- it's
    faster to just compute this directly than to call [null_r]. *)
Fixpoint ck_null (r:rexp) : bool :=
  match r with
    | Eps_r => true
    | Char_r _ => false
    | Any_r => false
    | Zero_r => false
    | Alt_r r1 r2 => ck_null r1 || ck_null r2
    | Cat_r r1 r2 => ck_null r1 && ck_null r2
    | And_r r1 r2 => ck_null r1 && ck_null r2
    | Star_r _ => true
  end.

(** [ck_null] is correct. *)
Lemma ck_null_corr r : if ck_null r then in_rexp r nil else ~ in_rexp r nil.
Proof.
  induction r ; simpl ; auto ; try (intro ; in_inv) ;
    repeat
      match goal with
        | [ H : if ck_null ?r then _ else _ |- _ ] => destruct (ck_null r) ; simpl
        | [ |- in_rexp (Cat_r _ _) nil ] =>
          let H := fresh "H" in
          assert (H: @nil char_p = nil ++ nil) ; [ auto | rewrite H ] ; eauto
        | [ |- ~ _ ] => intro ; in_inv
        | [ H : nil = ?cs1 ++ ?cs2 |- _] => generalize (nil_is_nil_app_nil cs1 cs2 H) ;
          clear H ; s
        | [ H : in_rexp ?r ?s, H1 : ~ in_rexp ?r ?s |- _ ] => contradiction H1
        | _ => eauto
      end.
Qed.

(** Calculate the derivative of an [rexp] with respect to a character. *)
Fixpoint deriv_r (r:rexp) (c:char_p) : rexp :=
  match r with
    | Any_r => Eps_r
    | Char_r c' => if char_eq c c' then Eps_r else Zero_r
    | Eps_r => Zero_r
    | Zero_r => Zero_r
    | Alt_r r1 r2 => OptAlt_r (deriv_r r1 c) (deriv_r r2 c)
    | Cat_r r1 r2 =>
      OptAlt_r (OptCat_r (deriv_r r1 c) r2)
               (if ck_null r1 then deriv_r r2 c else Zero_r)
    | Star_r r as r' => OptCat_r (deriv_r r c) r'
    | And_r r1 r2 => OptAnd_r (deriv_r r1 c) (deriv_r r2 c)
  end.

(** Derivative is correct part 1 *)
Lemma deriv_r_corr1 r s :
  in_rexp r s -> forall c cs, s = c::cs -> in_rexp (deriv_r r c) cs.
Proof.
  induction 1 ; try (repeat in_inv ; try congruence ;
    try (apply opt_alt_r_corr) ; try (apply opt_and_r_corr) ;
          try (apply opt_cat_r_corr) ; eauto).
  destruct cs1. simpl in *. subst. apply Alt_right_ri.
  generalize (ck_null_corr r1). destruct (ck_null r1). intros. eauto.
  intros. contradiction H1. s. apply Alt_left_ri. apply opt_cat_r_corr. eauto.
  destruct cs1. congruence. simpl in *. injection H3 ; intros ; subst ; clear H3.
  econstructor ; eauto.
Qed.

(** Derivative is correct part 2 *)
Lemma deriv_r_corr2 r c cs : in_rexp (deriv_r r c) cs -> in_rexp r (c::cs).
Proof.
  induction r ; repeat in_inv. destruct (char_eq c0 c). subst. in_inv. constructor.
  in_inv. generalize (proj2 (opt_alt_r_corr _ _ _) H). clear H ; intro.
  in_inv. generalize (proj2 (opt_cat_r_corr _ _ _) H3). clear H3 ; intro ;
  in_inv. econstructor ; eauto. generalize (ck_null_corr r1).  destruct (ck_null r1).
  intros. assert (c::cs = nil ++ c::cs) ; auto. rewrite H0. eauto. in_inv.
  generalize (proj2 (opt_alt_r_corr _ _ _) H). clear H. repeat in_inv.
  generalize (proj2 (opt_cat_r_corr _ _ _) H). clear H. repeat in_inv.
  eapply Star_cat_ri ; eauto. congruence. generalize opt_and_r_corr.
  repeat in_inv. generalize (proj2 (opt_and_r_corr _ _ _) H). clear H. repeat in_inv.
Qed.

(** A string [c::cs] is in the denotation of [r] iff [cs] is in the
    denotation of [deriv_r r c]. *)
Lemma deriv_r_corr r c cs : in_rexp r (c::cs) <-> in_rexp (deriv_r r c) cs.
Proof.
  intros ; split ; intros. eapply deriv_r_corr1; eauto. eapply deriv_r_corr2 ; eauto.
Qed.

(** Extend derivatives to strings -- i.e., lists of characters. *)
Fixpoint derivs_r (r:rexp) (cs:list char_p) : rexp :=
  match cs with
    | nil => r
    | c::cs' => derivs_r (deriv_r r c) cs'
  end.

(** A string [cs1 ++ cs2] is in the denotation of [r] iff the string [cs2] is
    in the denotation of [derivs_r r cs1]. *)
Lemma derivs_r_corr cs1 r cs2 : in_rexp r (cs1 ++ cs2) <-> in_rexp (derivs_r r cs1) cs2.
Proof.
  intros ; split ; generalize r cs2 ; clear r cs2 ; induction cs1 ; simpl ; intros ; auto.
  eapply IHcs1. apply deriv_r_corr ; auto.
  apply deriv_r_corr. apply IHcs1. auto.
Qed.

(** Specialization of [deriv] for the case where we are going to take the
    derivative with respect to all characters. This avoids doing a case
    split on [Any_r] into the characters and provides a big speedup. *)
Fixpoint DerivAny (r:rexp) : rexp :=
  match r with
    | Any_r => Eps_r
    | Char_r _ => Eps_r
    | Zero_r => Zero_r
    | Eps_r => Zero_r
    | Alt_r r1 r2 => OptAlt_r (DerivAny r1) (DerivAny r2)
    | And_r r1 r2 => OptAnd_r (DerivAny r1) (DerivAny r2)
    | Cat_r r1 r2 =>
      OptAlt_r (OptCat_r (DerivAny r1) r2)
               (if ck_null r1 then DerivAny r2 else Zero_r)
    | Star_r r as r' => OptCat_r (DerivAny r) r'
  end.

(** Calculate the derivative of one [rexp] with respect to another.  This is
    only meaningful when [r2] is a star-free [rexp] which is why we get an
    option out.  As we'll see, we get an over approximation of the set of
    strings accepted by the derivative of [r1] with respect to the strings
    in [r2].   This provides a fast test for checking whether an intersection
    is empty and is in fact sufficient for our needs. *)
Fixpoint Deriv (r1:rexp) (r2:rexp) : option rexp :=
  match r2 with
    | Any_r => Some (DerivAny r1)
    | Char_r c => Some (deriv_r r1 c)
    | Zero_r => Some (Zero_r)
    | Eps_r => Some r1
    | Alt_r ra rb =>
      match Deriv r1 ra with
        | Some Zero_r => Deriv r1 rb
        | Some d1 => match Deriv r1 rb with
                       | Some d2 => Some (OptAlt_r d1 d2)
                       | None => None
                     end
        | None => None
      end
    | Cat_r ra rb =>
      match Deriv r1 ra with
        | Some Zero_r as d => d
        | Some d1 => Deriv d1 rb
        | None => None
      end
    | And_r ra rb =>
      match Deriv r1 ra, Deriv r1 rb with
        | Some d1, Some d2 => Some (OptAnd_r d1 d2)
        | _, _ => None
      end
    | Star_r ra => None
  end.

Ltac Dsimp :=
  match goal with
    | [ H : Some ?x = Some ?y |- _ ] =>
      assert (x = y) ; [injection H ; auto | clear H ; subst]
    | [ H : in_rexp (deriv_r _ ?c) _ |- exists cs, _ /\ _ ] =>
      exists (c::nil) ; split ; [constructor | apply deriv_r_corr ; auto]
    | [ H : (match Deriv ?r1 ?r2 with | Some _ => _ | None => _ end = _) |- _ ] =>
      let d := fresh "d" in
        remember (Deriv r1 r2) as d ; destruct d
    | [ H : Some _ = Deriv _ _ |- _] => generalize (eq_sym H) ; clear H ; intro H
    | [ IH : forall _ _, Deriv _ ?r2 = Some _ -> _, H : Deriv _ ?r2 = Some _ |- _ ] =>
      specialize (IH _ _ H)
    | [ IH : forall _, in_rexp ?r _ -> _, H : in_rexp ?r _ |- _ ] =>
      specialize (IH _ H)
    | [ H : Some _ = None |- _ ] => congruence
    | [ H : None = Some _ |- _ ] => congruence
    | [ H : in_rexp (OptAnd_r _ _) _ |- _] =>
      generalize (proj2 (opt_and_r_corr _ _ _) H) ; clear H ; intro H
    | _ => idtac
  end.

(** If [c::cs'] is in the denotation of [r] then [cs'] is in the denotation
    of [DerivAny r]. *)
Lemma DerivAny_corr1 : forall r cs, in_rexp r cs ->
  forall c cs', cs = c::cs' -> in_rexp (DerivAny r) cs'.
Proof.
  induction 1 ; simpl ; repeat (in_inv ; pv_opt) ; try congruence.
  destruct cs1. eapply Alt_right_ri. generalize (ck_null_corr r1).
  destruct (ck_null r1). intros. pv_opt. intros. contradiction H1.
  eapply Alt_left_ri. pv_opt. destruct cs1. pv_opt. congruence. simpl in H3. injection H3.
  intros ; subst. pv_opt. apply opt_and_r_corr. pv_opt.
Qed.

(** If [cs1] is in the denotation of [r2] and [cs1++cs2] is in the denotation of [r1],
    then [cs2] is in the denotation of [Deriv r1 r2]. *)
Lemma Deriv_corr1 : forall r2 r1 r3, Deriv r1 r2 = Some r3 ->
  forall cs1 cs2,
    in_rexp r2 cs1 ->
    in_rexp r1 (cs1 ++ cs2) ->
    in_rexp r3 cs2.
Proof.
  induction r2 ; repeat (in_inv ; Dsimp ; pv_opt). eapply DerivAny_corr1 ; eauto.
  apply deriv_r_corr ; auto. rewrite <- app_assoc in H1. destruct r ; Dsimp ; eauto.
  specialize (IHr2_1 _ _ H4 H1). inversion IHr2_1. destruct r ; repeat Dsimp ; pv_opt.
  specialize (IHr2_1 _ _ H5 H1). pv_opt. destruct r ; repeat Dsimp ; pv_opt.
  apply opt_and_r_corr. eauto.
Qed.

(** If [Deriv r1 r2] is [Zero_r], then there is no string in the intersection
    of the denotations of [r1] and [r2]. *)
Lemma Deriv_Zero : forall r1 r2,
  Deriv r1 r2 = Some Zero_r ->
  ~ (exists cs, in_rexp (And_r r1 r2) cs).
Proof.
  intros. generalize (Deriv_corr1 H). intros. intro. destruct H1.
  inversion H1. subst ; clear H1. generalize (H0 x nil H6). rewrite <- app_nil_end.
  intros. specialize (H1 H4). inversion H1.
Qed.

(* Note the other direction does not hold, due to And_r:

  Lemma Deriv_corr1 : forall r2 r1 r3, Deriv r1 r2 = Some r3 ->
    forall cs2, in_rexp r3 cs2 -> exists cs1, in_rexp r2 cs1 /\ in_rexp r1 (cs1 ++ cs2).

  The problem is that what we return as the [Deriv] is an over-approximation of
  the set of strings in the derivative of [r1] with respect to the strings in [r2].
  Fortunately, we don't need this fact.
*)

(** Convert a nat representing a byte to a list of bits *)
Definition n2b(n:nat) : list bool :=
  let bs := Word.bits_of_Z 8 (Z_of_nat n) in
    (bs 7)::(bs 6)::(bs 5)::(bs 4)::(bs 3)::(bs 2)::(bs 1)::(bs 0)::nil.

Definition token_id_to_chars := n2b.
Definition num_tokens := 256%nat.
Opaque token_id_to_chars.
Opaque num_tokens.

(* Check whether [r] is equivalent to [Zero_r].  Note that to check whether
   [And_r r1 r2] is equivalent to [Zero_r], we take the derivative of [r1]
   with respect to [r2] and then check whether the resulting [rexp] is
   equivalent to [Zero_r].

   Note that [n] here is used for "fuel" so as long as you find some [n]
   that returns [true], you know that [r] is equivalent to [Zero_r].
*)
Fixpoint ckzero (n:nat) (r:rexp) : bool :=
  match n with
    | 0%nat => false
    | S n =>
      match r with
        | Zero_r => true
        | Eps_r => false
        | Any_r => false
        | Char_r _ => false
        | Cat_r r1 r2 => ckzero n r1 || ckzero n r2
        | Alt_r r1 r2 => ckzero n r1 && ckzero n r2
        | Star_r _ => false
        | And_r r1 r2 =>
          match Deriv r1 r2 with
            | Some r => ckzero n r
            | None =>
              negb (ck_null r1 && ck_null r2) &&
              ckzero n (OptAlt_r (OptAnd_r (deriv_r r1 true) (deriv_r r2 true))
                       (OptAnd_r (deriv_r r1 false) (deriv_r r2 false)))
          end
      end
  end.

(** Correctness for [ckzero]:  If [ckzero n r] returns [true] for some [n], then
    there is no string in the denotation of [r]. *)
Lemma ckzero_corr n r : ckzero n r = true -> ~(exists s, in_rexp r s).
Proof.
  induction n ; simpl ; intros ; try congruence ; destruct r ; try congruence ; intro ;
    mysimp ; repeat in_inv ; unfold andb, orb, negb in *.
  generalize (IHn r1). destruct (ckzero n r1). intros. apply H0 ; auto. eauto.
  intros. apply (IHn _ H). eauto. generalize (IHn r1). destruct (ckzero n r1).
  intros. apply H0 ; eauto. congruence. generalize (IHn r2). destruct (ckzero n r1) ;
  destruct (ckzero n r2) ; try congruence. intros. apply H0 ; eauto.
  generalize (@Deriv_corr1 r2 r1). intros. remember (Deriv r1 r2) as e.
  destruct e. generalize (H0 r (eq_refl _) x nil H5) (IHn _ H). intros.
  apply H2. exists nil. apply H1. rewrite <- app_nil_end. auto.
  generalize (ck_null_corr r1) (ck_null_corr r2) ;
  destruct (ck_null r1) ; destruct (ck_null r2) ; intros ; try congruence ;
    destruct x ; auto ; generalize (IHn _ H) ; clear H ; intro H ;
    apply H ; clear H ; exists x ; pv_opt ; destruct c ; clear H1 H2 ;
  try (apply Alt_left_ri ; apply opt_and_r_corr ; constructor ; eapply deriv_r_corr1 ; eauto ; fail) ;
    apply Alt_right_ri ; apply opt_and_r_corr ; constructor ; eapply deriv_r_corr1 ; eauto.
Qed.

(** Check whether [r1] and [r2] denote disjoint sets of strings -- we simply
    check whether their intersection is equivalent to [Zero_r]. *)
Definition ckdisj_r (n:nat) (r1 r2:rexp) := ckzero n (OptAnd_r r1 r2).

(** Correctness of [ckdisj_r]. *)
Lemma ckdisj_r_corr n r1 r2 : ckdisj_r n r1 r2 = true -> ~(exists s, in_rexp r1 s /\
  in_rexp r2 s).
Proof.
  unfold ckdisj_r ; intros. generalize (ckzero_corr n H).  intros. intro.
  apply H0. mysimp. exists x. apply opt_and_r_corr. auto.
Qed.

(** Lift [ckdisj_r] to operate on parsers. *)
Definition ckdisj_p (n:nat) t (p1:parser t) (p2:parser t) :=
  ckdisj_r n (parser2rexp p1) (parser2rexp p2).

(** Correctness of [ckdisj_p] -- here we see that if [p1] and [p2] are disjoint,
    then there is no string [s] and values [v1] and [v2], such that [s] and [v1]
    are in the denotation of [p1], and [s] and [v2] are in the denotation of [p2]. *)
Lemma ckdisj_p_corr n t (p1 p2:parser t) :
  ckdisj_p n p1 p2 = true -> ~(exists s, exists v1, exists v2, in_parser p1 s v1 /\
    in_parser p2 s v2).
Proof.
  unfold ckdisj_p. intros. intro. generalize (ckdisj_r_corr _ H). intros. mysimp.
  apply H1. exists x. split ; eapply parse2rexp_corr1 ; eauto.
Qed.

(** Multi [OptAlt_r]. *)
Definition alts_r := List.fold_right OptAlt_r Zero_r.

(** Count up from [i] to [m] and try to check if [r] is equivalent to [Zero_r]
    using [i] as the bound.  This tries to avoid checking to deeply when it's
    not necessary. *)
Fixpoint ckzeros i m r :=
  match i with
    | 0%nat => false
    | S i => ckzero (m - (S i)) r || ckzeros i m r
  end.

(** Correctness of [ckzeros]. *)
Lemma ckzeros_corr : forall i m r,
  ckzeros i m r = true -> ~ (exists s, in_rexp r s).
Proof.
  induction i ; simpl ; intros. congruence. intro.
  generalize (@ckzero_corr (m - S i) r). intro.
  destruct (ckzero (m - S i) r). apply H1 ; auto. simpl in H.
  apply (IHi _ _ H). auto.
Qed.

(** [check_all_r] checks that all [rexp]s in the list [rs] are mutually disjoint.
    I tried a divide and conquer strategy, where we do O(n lg n) tests but it
    turns out to be no faster than this rather brute force approach because the
    derivatives were growing.  Here, we do O(n^2) tests which is still better
    than doing all pair-wise comparisons. *)
Fixpoint check_all_r m (rs:list rexp) :=
  match rs with
    | nil => true
    | r::rs => check_all_r m rs && ckzeros m m (OptAnd_r r (alts_r rs))
  end.

(** Correctness of [check_all_r]:  If [check_all_r m rs] returns [true], then
    we know that if [s] is in the denotation of [alts_r rs], then there is some
    [r] in [rs], such that [s] is in the denotation of [r], and furthermore,
    [s] is not in the denotation of any of the rest of the [rexp]s. *)
Lemma check_all_r_corr m rs :
  check_all_r m rs = true ->
  forall s, in_rexp (alts_r rs) s ->
    exists rs1, exists r, exists rs2,
      rs = rs1 ++ r::rs2 /\
      in_rexp r s /\ ~ in_rexp (alts_r (rs1 ++ rs2)) s.
Proof.
  induction rs ; simpl ; intros. in_inv.
  generalize (proj2 (opt_alt_r_corr a (alts_r rs) s) H0). clear H0. intro.
  remember (check_all_r m rs) as e. destruct e ; simpl in * ; try congruence.
  specialize (IHrs (eq_refl _) s). generalize (ckzeros_corr m m H). intros.
  inversion H0. subst. exists nil. exists a. exists rs. simpl. split ; auto.
  split. auto. intro. apply H1. exists s. apply opt_and_r_corr. eauto. subst.
  specialize (IHrs H5). destruct IHrs. destruct H2. destruct H2. destruct H2.
  destruct H3. subst. exists (a::x). exists x0. exists x1. simpl. split.
  auto. split. auto. intro. apply H1. exists s.
  generalize (proj2 (opt_alt_r_corr _ _ _) H2). clear H2. intro.
  apply opt_and_r_corr.
  constructor. inversion H2. subst. auto. subst. contradiction H4 ; auto.
  apply H5.
Qed.

(** Lift [check_all_r] up to parsers. *)
Definition check_all_p m t (ps:list (parser t)) :=
  check_all_r m (List.map (@parser2rexp _) ps).

Fixpoint check_all_r' m (rs:list rexp) :=
  match rs with
    | nil => true
    | r::rs =>
      check_all_r' m rs &&
      ckzeros m m (OptAnd_r (OptCat_r (alts_r rs) (Star_r Any_r)) (OptCat_r r (Star_r Any_r)))
  end.

Definition check_all_p' m t (ps:list (parser t)) :=
  check_all_r' m (List.map (@parser2rexp _) ps).

Lemma all_instructions_check :
  check_all_p' 3 instruction_parser_list = true.
Proof.
  Time vm_compute. auto.
Qed.

Lemma star_any_all : forall s, in_rexp (Star_r Any_r) s.
Proof.
  induction s. econstructor. replace (a::s) with ((a::nil) ++ s) ; auto.
  eapply Star_cat_ri ; eauto. congruence.
Qed.

Lemma check_all_r'_corr m rs :
  check_all_r' m rs = true ->
  forall s, in_rexp (alts_r rs) s ->
    exists rs1, exists r, exists rs2,
      rs = rs1 ++ r :: rs2 /\
      in_rexp r s /\ ~ exists s2, in_rexp (alts_r (rs1 ++ rs2)) (s ++ s2).
Proof.
  induction rs ; simpl ; intros. in_inv.
  generalize (proj2 (opt_alt_r_corr a (alts_r rs) s) H0). clear H0. intro.
  remember (check_all_r' m rs) as e. destruct e ; simpl in * ; try congruence.
  specialize (IHrs (eq_refl _) s). generalize (ckzeros_corr m m H). intros.
  inversion H0 ; clear H0. subst. exists nil. exists a. exists rs. simpl. split ; auto.
  split ; auto. intro. apply H1. destruct H0. exists (s ++ x). apply opt_and_r_corr.
  econstructor. eapply opt_cat_r_corr. rewrite app_nil_end. econstructor.
  eauto. econstructor. auto. eapply opt_cat_r_corr. generalize (star_any_all x).
  intros. econstructor ; eauto.
  subst. specialize (IHrs H5). destruct IHrs. destruct H0. destruct H0. destruct H0.
  destruct H2. subst. exists (a::x). exists x0. exists x1. simpl. split ; auto.
  split ; auto. intro. destruct H0. generalize (proj2 (opt_alt_r_corr a _ (s++x2)) H0).
  clear H0. intro. inversion H0 ; clear H0 ; subst. clear H Heqe.
  contradiction H1. exists (s ++ x2). apply opt_and_r_corr. constructor.
  apply opt_cat_r_corr. econstructor. eapply H5. eapply (star_any_all x2). auto.
  apply opt_cat_r_corr. econstructor. eapply H8. eapply (star_any_all nil).
  rewrite app_ass. rewrite <- app_nil_end. auto. contradiction H3.
  exists x2. auto.
Qed.

(** Lemma for reasoning about [alts]. *)
Lemma in_alts t (ps:list (parser t)) s v:
  in_parser (alts ps) s v -> in_rexp (alts_r (List.map (@parser2rexp _) ps)) s.
Proof.
  induction ps ; simpl ; intros. unfold never in *. inversion H.
  apply opt_alt_r_corr. inversion H ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. eapply Alt_left_ri. eapply parse2rexp_corr1. eauto.
  eapply Alt_right_ri. eauto.
Qed.

(** A sort of injection lemma for [List.map] over lists. *)
Lemma map_split : forall A B (f:A -> B) (ys1:list B) (y:B) (ys2:list B) (xs:list A),
  List.map f xs = ys1 ++ y::ys2 ->
  exists xs1, exists x, exists xs2,
    xs = xs1 ++ x :: xs2 /\
    ys1 = List.map f xs1 /\
    y = f x /\
    ys2 = List.map f xs2.
Proof.
  induction ys1 ; simpl ; intros ; destruct xs ; simpl in * ; try congruence.
  exists nil. exists a. exists xs. injection H. intros. subst. simpl. auto.
  injection H. intros. subst. specialize (IHys1 y ys2 xs H0). s.
  exists (a0 :: x). exists x0. exists x1. simpl. auto.
Qed.

(** Denotation of [alts] is commutative. *)
Lemma in_alts_comm t (ps1:list (parser t)) (p:parser t) (ps2:list (parser t)) s v :
  in_parser (alts (ps1 ++ p :: ps2)) s v ->
  in_parser (Alt_p p (alts (ps1 ++ ps2))) s v.
Proof.
  induction ps1. simpl. auto. intros. simpl in *. inversion H ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end.  apply Alt_right_pi. apply Alt_left_pi. auto.
  specialize (IHps1 p ps2 s v H4). inversion IHps1 ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. apply Alt_left_pi.   auto. apply Alt_right_pi. apply Alt_right_pi. auto.
Qed.

(** [check_all_p] is correct -- if [check_all_p m ps] returns [true], then
   if [s] and [v] are in the denotation of [alts ps], then we know there is
   a unique [p] in [ps] such that [s] and [v] are in the denotation of [p],
   but that [s] is not in the denotation of any other parser in [ps]. *)
Lemma check_all_p_corr m t (ps:list (parser t)) :
  check_all_p m ps = true ->
  forall s v,
    in_parser (alts ps) s v ->
    (exists ps1, exists p, exists ps2,
      ps = ps1 ++ p :: ps2 /\
      in_parser p s v /\
      ~ exists v' : result_m t, in_parser (alts (ps1 ++ ps2)) s v').
Proof.
  unfold check_all_p. intros. generalize (check_all_r_corr m _ H). intros.
  specialize (H1 s (in_alts _ H0)). destruct H1. destruct H1. destruct H1.
  destruct H1. destruct H2. generalize (map_split (@parser2rexp t) x x0 x1 ps H1).
  intros. mysimp. subst. exists x2. exists x3. exists x4. split. auto.
  generalize (in_alts_comm x2 x3 x4 H0). intros.
  assert (~ exists v', in_parser (alts (x2 ++ x4)) s v'). intro.
  destruct H5. apply H3. generalize (in_alts (x2 ++ x4) H5). rewrite map_app. auto.
  split ; auto. inversion H4 ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. auto. contradiction H5. eauto.
Qed.

Lemma check_all_p'_corr m t (ps:list (parser t)) :
  check_all_p' m ps = true ->
  forall s v,
    in_parser (alts ps) s v ->
    (exists ps1, exists p, exists ps2,
      ps = ps1 ++ p :: ps2 /\
      in_parser p s v /\
      ~ exists s2, exists v' : result_m t, in_parser (alts (ps1 ++ ps2)) (s++s2) v').
Proof.
  unfold check_all_p. intros. generalize (check_all_r'_corr m _ H). intros.
  specialize (H1 s (in_alts _ H0)). destruct H1. destruct H1. destruct H1.
  destruct H1. destruct H2. generalize (map_split (@parser2rexp t) x x0 x1 ps H1).
  intros. mysimp. subst. exists x2. exists x3. exists x4. split. auto.
  generalize (in_alts_comm x2 x3 x4 H0). intros.
  assert (~ exists s2, exists v', in_parser (alts (x2 ++ x4)) (s ++ s2) v'). intro.
  destruct H5. destruct H5.
  apply H3. exists x. generalize (in_alts (x2 ++ x4) H5). rewrite map_app. auto.
  split ; auto. inversion H4 ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. auto. contradiction H5. exists nil. rewrite <- app_nil_end. eauto.
Qed.

(** Check that all of the instruction parsers are mutually disjoint -- if you
    pass in a number like 3 this should evaluate to true -- but it takes a
    really long time.  So I suggest extracting this function and running it
    in ML. *)
Definition check_all_instructions m := check_all_p m instruction_parser_list.

Transparent token_id_to_chars.
Transparent num_tokens.
(** FIX:  This is admitted now, just because it takes a long time to run,
    but it should be trivial. *)
Lemma all_instructions_disjoint : check_all_instructions 3 = true.
Proof.
(*Admitted.*)

  unfold check_all_instructions.
  vm_compute.
  auto.
Qed.

Opaque instruction_parser_list.

Ltac t := repeat
  match goal with
    | [ H : _ /\ _ |- _ ] => destruct H
    | [ H : exists _, _ |- _ ] => destruct H
    | [ |- forall _, _ ] => intros
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end.

(** If [s] and [v] are in the denotation of [alts (p::(ps1++ps2))] then
    [s] and [v] are in the denotation of [alts (ps1++p::ps2)]. *)
Lemma in_alts_comm' : forall t (ps1 ps2:list (parser t)) (p:parser t) s v,
  in_parser (alts (p :: (ps1 ++ ps2))) s v ->
  in_parser (alts (ps1 ++ p :: ps2)) s v.
Proof.
  induction ps1. simpl. auto. intros. simpl in *. inversion H  ; clear H ; t.
  eapply Alt_right_pi. eapply IHps1. eapply Alt_left_pi. auto.
  inversion H4  ; clear H4 ; t. eapply Alt_left_pi. auto.
  eapply Alt_right_pi. eapply IHps1. eapply Alt_right_pi. auto.
Qed.

(** If [s] and [v] are in the denotation of [alts (ps1 ++ p :: ps2)], and
    [s] and [v] are also in the denotation of [p] and not in the
    denotation of [alts (ps1 ++ ps2)], then if we split [ps1++p::ps2] into
    some other [ps1'++p'::ps2'] such that [s] and [v] are in [p'], then
    [ps1=ps1'] and [p=p'] and [ps2=ps2']. *)
Lemma splits_unique t (ps : list (parser t)) :
  forall s v,
    in_parser (alts ps) s v ->
    forall ps1 p ps2,
      ps = ps1 ++ p :: ps2 ->
      in_parser p s v /\ (~ exists v', in_parser (alts (ps1 ++ ps2)) s v') ->
      forall ps1' p' ps2' v',
        ps = ps1' ++ p' :: ps2' /\ in_parser p' s v' ->
        ps1 = ps1' /\ p = p' /\ ps2 = ps2'.
Proof.
  induction ps. simpl. intros. destruct ps1 ; simpl in * ; congruence. t.
  destruct ps1. injection H0 ; clear H0 ; intros ; subst.
  destruct ps1'. injection H2 ; clear H2 ; intros ; subst ; auto.
  simpl in *. injection H2 ; clear H2 ; intros ; subst. contradiction H4.
  exists v'. eapply in_alts_comm'. simpl. eapply Alt_left_pi ; eauto.
  simpl in *. injection H0 ; intros ; subst ; clear H0.
  destruct ps1' ; simpl in *. injection H2 ; intros ; clear H2 ; subst.
  contradiction H4. exists v'. eapply Alt_left_pi ; eauto.
  injection H2. clear H2 ; intros ; subst. inversion H ; t ; clear H.
  contradiction H4. exists v. eapply Alt_left_pi ; eauto.
  assert (~ exists v', in_parser (alts (ps1 ++ ps2)) s v').
  intro. apply H4. t. exists x. eapply Alt_right_pi. eauto.
  specialize (IHps _ _ H8 ps1 p ps2 (eq_refl _) (conj H1 H) ps1' p' ps2' v' (conj H0 H3)).
  t. subst. auto.
Qed.

(** If [s] and [v] are in the denotation of [alts ps], then there is
    some [ps1++p::ps2=ps] such that [s] and [v] are in the denotation of [p]. *)
Lemma in_alts_split : forall t (ps:list (parser t)) s v,
  in_parser (alts ps) s v ->
  exists ps1, exists p, exists ps2,
    ps = ps1 ++ p :: ps2 /\ in_parser p s v.
Proof.
  induction ps ; simpl. unfold never. intros. inversion H.
  intros. inversion H ; clear H ; t. exists nil. exists a. exists ps. auto.
  specialize (IHps s v H4). in_inv. exists (a::x). exists x0. exists x1. auto.
Qed.

(** If [p] is an element of [ps] and [s] and [v] are in the denotation of
    [p], then they are also in the denotation of [alts ps]. *)
Lemma elt_in_alts : forall t (p:parser t) (ps:list (parser t)) s v,
  In p ps ->
  in_parser p s v ->
  in_parser (alts ps) s v.
Proof.
  induction ps ; simpl ; intros. contradiction H. destruct H. subst.
  apply Alt_left_pi. auto. apply Alt_right_pi. auto.
Qed.

(** If [s] and [v] are in the denotation of [alts ps1] and [ps1] is
    a subset of [ps2], then [s] and [v] are also in [alts ps2]. *)
Lemma subset_in : forall t (ps1 ps2 : list (parser t)) s v,
  in_parser (alts ps1) s v ->
  (forall p, In p ps1 -> In p ps2) ->
  in_parser (alts ps2) s v.
Proof.
  induction ps1. simpl. intros. unfold never in *. inversion H. simpl.
  intros. inversion H ; clear H ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. assert (In a ps2).  apply H0. left ; auto. eapply elt_in_alts ; eauto. auto.
Qed.

Lemma in_splits A (x:A) (xs:list A) :
  In x xs -> exists xs1, exists xs2, xs = xs1 ++ x :: xs2.
Proof.
  induction xs ; simpl ; t. contradiction H. destruct H. subst.
  exists nil. exists xs. auto. specialize (IHxs H). t. subst.
  exists (a::x0). exists x1. auto.
Qed.

Lemma splits_in A (x:A) (x1s x2s:list A) :
  In x (x1s ++ x::x2s).
Proof.
  induction x1s ; simpl ; auto.
Qed.

(** If all of the [ps] are disjoint (according to [check_all_p]), then
    for each subset [p1s] of [ps], if [s] and [v] are in [alts ps1] then
    they are also in [alts ps] and if [s] and [v'] are in [alts ps] then
    [s] and [v'] are in [alts p1s].  *)
Lemma parse_split' :
  forall t m (ps:list (parser t)), check_all_p m ps = true ->
  forall p1s s v,
  (forall p, In p p1s -> In p ps) ->
  in_parser (alts p1s) s v ->
  in_parser (alts ps) s v /\
  (forall v', in_parser (alts ps) s v' ->
    in_parser (alts p1s) s v').
Proof.
  t. split. generalize (in_alts_split p1s H1). t. subst. eapply subset_in ; eauto.
  t. generalize (check_all_p_corr m _ H H2). clear m H. t.
  generalize (in_alts_split _ H1). t. assert (In x3 p1s). rewrite H5. apply splits_in.
  generalize (H0 _ H7). intros. generalize (@in_splits _ _ _ H8). t.
  generalize (@splits_unique _ _ _ _ H2 _ _ _ H (conj H3 H4) x5 x3 x6 v (conj H9 H6)).
  t. subst. generalize (in_alts_comm _ _ _ H2). intros. inversion H5 ; t.
  eapply in_alts_comm'. eapply Alt_left_pi. auto. contradiction H4. eauto.
Qed.

(** This lemma tells us that if we take a sublist [ps] of the parsers in the list of
    instruction parsers (e.g., used to build a DFA), and if [ps] accepts some string
    [s] and produces some value [v], then (a) running the heavyweight parser will also
    accept [s] and produce [v], and (b) if the heavyweight parser can produce a
    different value [v'] from [s], then [ps] can do that as well.  So if [ps] is
    deterministic, then running either [ps] or the heavyweight parser will result
    in at most one unique value [v].
*)
Lemma parse_split :
  forall ps,
    (forall p, In p ps -> In p instruction_parser_list) ->
    forall s v,
      in_parser (alts ps) s v ->
        in_parser (alts instruction_parser_list) s v /\
        (forall v', in_parser (alts instruction_parser_list) s v' -> in_parser (alts ps) s v').
Proof.
  intros. apply (parse_split' 3 instruction_parser_list all_instructions_disjoint _ H H0).
Qed.


(* In this file we explain how to do the "list examples" from the
   Chapter on Separation Logic for Sequential Programs in the
   Iris Lecture Notes *)

(* Contains definitions of the weakest precondition assertion, and its basic rules. *)
From iris.program_logic Require Export weakestpre.

(* Instantiation of Iris with the particular language. The notation file
   contains many shorthand notations for the programming language constructs, and
   the lang file contains the actual language syntax. *)
From iris.heap_lang Require Export notation lang.

(* Files related to the interactive proof mode. The first import includes the
   general tactics of the proof mode. The second provides some more specialized
   tactics particular to the instantiation of Iris to a particular programming
   language. *)
From iris.proofmode Require Export proofmode.
From iris.heap_lang Require Import proofmode.

(* The following line imports some Coq configuration we commonly use in Iris
   projects, mostly with the goal of catching common mistakes. *)
From iris.prelude Require Import options.

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

Section list_model.
  (* This section contains the definition of our model of lists, i.e.,
     definitions relating pointer data structures to our model, which is
     simply mathematical sequences (Coq lists). *)

(* In order to do the proof we need to assume certain things about the
   instantiation of Iris. The particular, even the heap is handled in an
   analogous way as other ghost state. This line states that we assume the
   Iris instantiation has sufficient structure to manipulate the heap, e.g.,
   it allows us to use the points-to predicate. *)
Context `{!heapGS Σ}.
Implicit Types l : loc.

(* The variable Σ has to do with what ghost state is available, and the type
     of Iris propositions (written Prop in the lecture notes) depends on this Σ.
     But since Σ is the same throughout the development we shall define
     shorthand notation which hides it. *)
Notation iProp := (iProp Σ).

(* Here is the basic is_list representation predicate:
    is_list hd xs holds if hd points to a linked list consisting of
   the elements in the mathematical sequence (Coq list) xs.
 *)
Fixpoint is_list (hd : val) (xs : list val) : iProp :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (x,hd') ∗ is_list hd' xs
end%I.

(* The following predicate
     is_listP P hd xs
   holds if hd points to a linked list consisting of the elements in xs and
   each of those elements satisfy P.
 *)
Fixpoint is_listP P (hd : val) (xs : list val) : iProp :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (x,hd') ∗ is_listP P hd' xs ∗ P x
end%I.

(* about_isList expresses how is_listP P hd xs can be seen as a combination of the
   basic is_list predicate and the property that P holds for all the elements in xs.
 *)
Lemma about_isList P hd xs :
  is_listP P hd xs ⊣⊢ is_list hd xs ∗ [∗ list] x ∈ xs, P x.
Proof.
  generalize dependent hd.
  induction xs as [| x xs' IHxs]; simpl; intros hd; iSplit.
  - eauto.
  - by iIntros "(? & _)".
  - iDestruct 1 as (l hd') "(? & ? & H & ?)". rewrite IHxs. iDestruct "H" as "(H_isListxs' & ?)".
    iFrame. iExists l, hd'. iFrame.
  - iDestruct 1 as "(H_isList & ? & H)". iDestruct "H_isList" as (l hd') "(? & ? & ?)".
    iExists l, hd'. rewrite IHxs. iFrame.
Qed.

(* The predicate
      is_list_nat hd xs
   holds if hd is a pointer to a linked list of numbers (integers).
*)
Fixpoint is_list_nat (hd : val) (xs : list Z) : iProp :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (#x,hd') ∗ is_list_nat hd' xs
  end%I.

(* The reverse function on Coq lists is defined in the Coq library. *)
Definition reverse (l : list val) := List.rev l.

Definition inj {A B : Type} (f : A -> B) : Prop :=
  forall (x y : A),
    f x = f y -> x = y.

Lemma map_injective {A B : Type} :
  forall xs ys (f : A -> B), inj f -> map f xs = map f ys
           -> xs = ys.
Proof.
  intros xs. induction xs as [|x xs IHxs]; intros ys f H_f H_map.
  - symmetry in H_map. by apply map_eq_nil in H_map.
  - destruct ys as [|y ys].
    + by apply map_eq_nil in H_map.
    + specialize (IHxs ys f). inversion H_map as [H_a].
      rewrite -> IHxs; try done.
      apply H_f in H_a. by rewrite H_a.
Qed.

End list_model.

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

Section list_code.
  (* This section contains the code of the list functions we specify *)

  (* Function inc hd assumes all values in the linked list pointed to by hd
     are numbers and increments them by 1, in-place *)
  Definition inc : val :=
  rec: "inc" "hd" :=
    match: "hd" with
      NONE => #()
    | SOME "l" =>
       let: "tmp1" := Fst !"l" in
       let: "tmp2" := Snd !"l" in
       "l" <- (("tmp1" + #1), "tmp2");;
       "inc" "tmp2"
    end.

  (* Function app l l' appends linked list l' to end of linked list l *)
  Definition app : val :=
  rec: "app" "l" "l'" :=
    match: "l" with
      NONE => "l'"
    | SOME "hd" =>
      let: "tmp1" := !"hd" in
      let: "tmp2" := "app" (Snd "tmp1") "l'" in
      "hd" <- ((Fst "tmp1"), "tmp2");;
           "l"
    end.

  (* Function rev l acc reverses all the pointers in linked list l and stiches
     the accumulator argument acc at the end *)
  Definition rev : val :=
  rec: "rev" "l" "acc" :=
    match: "l" with
      NONE => "acc"
    | SOME "p" =>
       let: "h" := Fst !"p" in
       let: "t" := Snd !"p" in
       "p" <- ("h", "acc");;
       "rev" "t" "l"
    end.

  (* Function len l returns the lenght of linked list l *)
  Definition len : val :=
  rec: "len" "l" :=
    match: "l" with
      NONE => #0
    | SOME "p" =>
      ("len" (Snd !"p") + #1)
    end.

  (* Function foldr f a l is the usual fold right function for linked list l, with
     base value a and combination function f *)
  Definition foldr : val :=
  rec: "foldr" "f" "a" "l" :=
    match: "l" with
      NONE => "a"
    | SOME "p" =>
      let: "hd" := Fst !"p" in
      let: "t" := Snd !"p" in
      "f" ("hd", ("foldr" "f" "a" "t"))
    end.

  (* sum_list l returns the sum of the list of numbers in linked list l,
     implemented by call to foldr *)
  Definition sum_list : val :=
  rec: "sum_list" "l" :=
    let: "f'" := (λ: "p", let: "x" := Fst "p" in
                         let: "y" := Snd "p" in
                         "x" + "y")
    in
    (foldr  "f'" #0 "l").

  Definition cons : val := (λ: "x" "xs",
                          let: "p" := ("x", "xs") in
                          SOME (Alloc("p"))).

  Definition empty_list : val := NONEV.

  (* filter prop l is the usual filter function on linked lists, prop is supposed
     to be a function from values to booleans. Implemented using foldr. *)
  Definition filter : val :=
  rec: "filter" "prop" "l" :=
    let: "f" :=  (λ: "p",
                  let: "x" := Fst "p" in
                  let: "xs" := Snd "p" in
                  if: ("prop" "x")
                  then (cons "x" "xs")
                  else "xs")
    in (foldr "f" empty_list "l").

  (* map_list f l is the usual map function on linked lists with f the function
     to be mapped over the list l. Implemented using foldr. *)
  Definition map_list : val :=
  rec: "map_list" "f" "l" :=
    let: "f'" :=  (λ: "p",
                   let: "x" := Fst "p" in
                   let: "xs" := Snd "p" in
                   (cons ("f" "x") "xs"))
    in
    (foldr "f'" empty_list "l").

  (* incr l is another variant of the increment function on linked lists, implemented using map. *)
  Definition incr : val :=
    rec: "incr" "l" :=
     map_list (λ: "n", "n" + #1)%I "l".

End list_code.

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

Section list_spec.
  (* This section contains the specifications and proofs for the list functions.
     The specifications and proofs are explained in the Iris Lecture Notes
   *)

  Context `{!heapGS Σ}.

Lemma inc_spec hd xs :
  {{{ is_list_nat hd xs }}}
    inc hd
  {{{ w, RET w; ⌜w = #()⌝ ∗ is_list_nat hd (List.map Z.succ xs) }}}.
Proof.
  iIntros (ϕ) "Hxs H".
  iLöb as "IH" forall (hd xs ϕ). wp_rec. destruct xs as [|x xs]; iSimplifyEq.
   - wp_match. iApply "H". done.
   - iDestruct "Hxs" as (l hd') "(% & Hx & Hxs)". iSimplifyEq.
     wp_match. do 2 (wp_load; wp_proj; wp_let). wp_op.
     wp_store. iApply ("IH" with "Hxs").
     iNext. iIntros (w) "H'". iApply "H". iDestruct "H'" as "[Hw Hislist]".
     iFrame. iExists l, hd'. iFrame. done.
Qed.

Lemma app_spec xs ys (l l' : val) :
  {{{ is_list l xs ∗ is_list l' ys }}}
    app l l'
  {{{ v, RET v; is_list v (xs ++ ys) }}}.
Proof.
  iIntros (ϕ) "[Hxs Hys] H".
  iLöb as "IH" forall (l xs l' ys ϕ).
  destruct xs as [| x xs']; iSimplifyEq.
   - wp_rec. wp_let. wp_match. iApply "H". done.
   - iDestruct "Hxs" as (l0 hd0) "(% & Hx & Hxs)". iSimplifyEq.
     wp_rec. wp_let. wp_match. wp_load. wp_let. wp_proj. wp_bind (app _ _)%E.
     iApply ("IH" with "Hxs Hys").
     iNext. iIntros (v) "?". wp_let. wp_proj. wp_store. iSimplifyEq. iApply "H".
     iExists l0, _. iFrame. done.
Qed.

Lemma rev_spec vs us (l acc : val) :
  {{{ is_list l vs ∗ is_list acc us }}}
    rev l acc
  {{{ w, RET w; is_list w (reverse vs ++ us) }}}.
Proof.
  iIntros (ϕ) "[H1 H2] HL".
  iInduction vs as [| v vs'] "IH" forall (acc l us).
   - iSimplifyEq. wp_rec. wp_let. wp_match. iApply "HL". done.
   - simpl. iDestruct "H1" as (l' t) "(%H & H3 & H1)". wp_rec. wp_let.
     rewrite -> H at 1. wp_match. do 2 (wp_load; wp_proj; wp_let).
     wp_store. iSpecialize ("IH" $! l t ([v] ++ us)).
     iApply ("IH" with "[H1] [H3 H2]").
     + done.
     + simpl. iExists l', acc. iFrame. done.
     + iNext. rewrite -> app_assoc. done.
Qed.

Lemma len_spec (l : val) xs :
  {{{ is_list l xs }}}
    len l
  {{{ v, RET v; ⌜v = #(length xs)⌝ }}}.
Proof.
  iIntros (ϕ) "Hl H".
  iInduction xs as [| x xs'] "IH" forall (l ϕ); iSimplifyEq.
   - wp_rec. wp_match. iApply "H". done.
   - iDestruct "Hl" as (p hd') "(% & Hp & Hhd')". wp_rec. iSimplifyEq.
     wp_match. wp_load. wp_proj. wp_bind (len hd')%I. iApply ("IH" with "[Hhd'] [Hp H]"); try done.
     iNext. iIntros. iSimplifyEq. wp_op. iApply "H". iPureIntro. do 2 f_equal. lia.
Qed.

(* The following specifications for foldr are non-trivial because the code is higher-order
   and hence the specifications involved nested triples.
   The specifications are explained in the Iris Lecture Notes. *)

Lemma foldr_spec_PI P I  (f a hd : val) (xs : list val) :
  {{{ (∀ (x a' : val) (ys : list val),
          {{{ P x ∗ I ys a'}}}
            f (x, a')
          {{{r, RET r; I (x::ys) r }}})
        ∗ is_list hd xs
        ∗ ([∗ list] x ∈ xs, P x)
        ∗ I [] a
  }}}
    foldr f a hd
  {{{
       r, RET r; is_list hd xs
                 ∗ I xs r
  }}}.
Proof.
  iIntros (ϕ) "(#H_f & H_isList & H_Px & H_Iempty) H_inv".
  iInduction xs as [|x xs'] "IH" forall (ϕ a hd); wp_rec; do 2 wp_let; iSimplifyEq.
  - wp_match. iApply "H_inv". eauto.
  - iDestruct "H_isList" as (l hd') "[% [H_l H_isList]]".
    iSimplifyEq.
    wp_match. do 2 (wp_load; wp_proj; wp_let).
    wp_bind (((foldr f) a) hd').
    iDestruct "H_Px" as "(H_Px & H_Pxs')".
    iApply ("IH" with "H_isList H_Pxs' H_Iempty [H_l H_Px H_inv]").
    iNext. iIntros (r) "(H_isListxs' & H_Ixs')".
    iApply ("H_f" with "[$H_Ixs' $H_Px] [H_inv H_isListxs' H_l]").
    iNext. iIntros (r') "H_inv'". iApply "H_inv". iFrame.
    iExists l, hd'. by iFrame.
Qed.

Lemma foldr_spec_PPI P I (f a hd : val) (xs : list val) :
  {{{ (∀ (x a' : val) (ys : list val),
          {{{ P x ∗ I ys a'}}}
            f (x, a')
          {{{r, RET r; I (x::ys) r }}})
        ∗ is_listP P hd xs
        ∗ I [] a
  }}}
    foldr f a hd
  {{{
       r, RET r; is_listP (fun x => True) hd xs
                 ∗ I xs r
  }}}.
Proof.
  iIntros (ϕ) "(#H_f & H_isList & H_Iempty) H_inv".
  rewrite about_isList. iDestruct "H_isList" as "(H_isList & H_Pxs)".
  iApply (foldr_spec_PI with "[-H_inv]").
  - iFrame. by iFrame "H_f".
  - iNext. iIntros (r) "(H_isList & H_Ixs)".
    iApply "H_inv". iFrame. rewrite about_isList. iFrame. by rewrite big_sepL_forall.
Qed.

Lemma sum_spec (hd: val) (xs: list Z) :
  {{{ is_list hd (map (fun (n : Z) => #n) xs)}}}
    sum_list hd
  {{{ v, RET v; ⌜v = # (fold_right Z.add 0 xs)⌝ }}}.
Proof.
  iIntros (ϕ) "H_is_list H_later".
  wp_rec. wp_pures.
  iApply (foldr_spec_PI
            (fun x => (∃ (n : Z), ⌜x = #n⌝)%I)
            (fun xs' acc => ∃ ys,
                 ⌜acc = #(fold_right Z.add 0 ys)⌝
               ∗ ⌜xs' = map (fun (n : Z) => #n) ys⌝
               ∗ ([∗ list] x ∈ xs',∃ (n' : Z), ⌜x = #n'⌝))%I
            with "[$H_is_list] [H_later]").
  - iSplitR.
    + iIntros (x a' ys). iModIntro. iIntros (ϕ') "(H1 & H2) H3".
      do 5 (wp_pure _).
      iDestruct "H2" as (zs) "(% & % & H_list)".
      iDestruct "H1" as (n2) "%". iSimplifyEq. wp_pures. iModIntro.
      iApply "H3". iExists (n2::zs). repeat (iSplit; try done).
      by iExists _.
    + iSplit.
      * induction xs as [|x xs IHxs]; iSimplifyEq; first done.
        iSplit; [iExists _; done | apply IHxs].
      * iExists []. eauto.
  - iNext. iIntros (r) "(H1 & H2)".
    iApply "H_later". iDestruct "H2" as (ys) "(% & % & H_list)".
    iSimplifyEq. rewrite (map_injective xs ys (λ n : Z, #n)); try done.
    unfold inj. intros x y H_xy. by inversion H_xy.
Qed.

Lemma filter_spec (hd p : val) (xs : list val) (P : val -> bool) :
  {{{ is_list hd xs
      ∗ (∀ x : val ,
           {{{ True }}}
           p x
           {{{r, RET r; ⌜r = #(P x)⌝ }}})
  }}}
  filter p hd
  {{{ v, RET v; is_list hd xs
                ∗ is_list v (List.filter P xs)
  }}}.
Proof.
  iIntros (ϕ) "[H_isList #H_p] H_ϕ". wp_rec. wp_pures.
  iApply (foldr_spec_PI (fun x => True)%I
                        (fun xs' acc => is_list acc (List.filter P xs'))%I
                  with "[$H_isList] [H_ϕ]").
  - iSplitL.
    + iIntros (x a' ?) "!# %ϕ'". iIntros "[_ H_isList] H_ϕ'".
      repeat (wp_pure _). wp_bind (p x). iApply "H_p"; first done.
      iNext. iIntros (r) "H". iSimplifyEq. destruct (P x); wp_if.
      * wp_rec. wp_pures. wp_alloc l. wp_pures. iApply "H_ϕ'".
        iExists l, a'. by iFrame.
      * by iApply "H_ϕ'".
    + iSplit; last done.
      rewrite big_sepL_forall. eauto.
  - iNext. iApply "H_ϕ".
Qed.

Lemma map_spec P Q (f hd : val) (xs : list val) :
  {{{
       is_list hd xs
        ∗ (∀ (x : val), {{{ P x }}}
                          f x
                        {{{r, RET r; Q x r}}})
        ∗ [∗ list] x ∈ xs, P x
  }}}
    map_list f hd
  {{{
       r, RET r; ∃ (ys : list val),  is_list r ys
                                     ∗ ([∗ list] p ∈ zip xs ys, Q (fst p) (snd p))
                                     ∗ ⌜List.length ys = List.length xs⌝
  }}}.
Proof.
  iIntros (ϕ) "[H_is_list [#H1 H_P_xs]] H_ϕ".
  wp_rec. wp_pures.
  iApply (foldr_spec_PI
            P
            (fun xs acc => ∃ ys,  (is_list acc ys)
                                 ∗ ([∗ list] p ∈ zip xs ys, Q (fst p) (snd p))
                                 ∗ ⌜length xs = length ys⌝)%I
            with "[H_is_list H1 H_P_xs] [H_ϕ]").
  - iSplitR "H_is_list H_P_xs".
    + iIntros (x a' ys). iModIntro. iIntros (ϕ') "(H_Px & H_Q) H_ϕ'". wp_pures.
      wp_bind (f x). iApply ("H1" with "[H_Px][H_Q H_ϕ']"); try done.
      iNext. iIntros (r) "H_Qr". wp_rec. wp_alloc l. wp_pures. iApply "H_ϕ'".
      iDestruct "H_Q" as (ys') "(H_is_list_ys' & H_Qys' & %)". iExists (r::ys').
      iSplitR "H_Qr H_Qys'".
      * unfold is_list. iExists l, a'. fold is_list. by iFrame.
      * iSimplifyEq. iFrame. eauto.
    + iFrame. iExists []. iSplit; by simpl.
  - iNext. iIntros (r) "H". iApply "H_ϕ". iDestruct "H" as "(_ & H_Q)".
    iDestruct "H_Q" as (ys) "(H_isList & H_Q & %)". iExists ys. by iFrame.
Qed.

Lemma about_length {A : Type} (xs : list A) (n : nat) :
  length xs = S n -> exists x xs', xs = x::xs'.
Proof.
  intro H. induction xs as [| x xs' ].
  - inversion H.
  - by exists x, xs'.
Qed.

Lemma inc_with_map hd (xs : list Z) :
  {{{ is_list hd (List.map (fun (n : Z) => #n) xs) }}}
    incr hd
  {{{ v, RET v; is_list v (List.map (fun (n : Z) => #n) (List.map Z.succ xs)) }}}.
Proof.
  iIntros (ϕ) "H_isList H_ϕ". wp_rec. wp_pures.
  wp_apply (map_spec
             (fun x => (∃ (n : Z), ⌜x = #n⌝)%I)
             (fun x r =>  (∃ (n' : Z),
                             ⌜r = #(Z.succ n')⌝
                                ∗ ⌜x = #n'⌝)%I)
           with "[$H_isList] [H_ϕ]").
  - iSplit.
    + iIntros (x) "!#". iIntros (ϕ') "H1 H2". wp_lam. iDestruct "H1" as (n) "H_x".
      iSimplifyEq. wp_binop. iApply "H2". by iExists n.
    + rewrite big_sepL_fmap. rewrite big_sepL_forall. eauto.
  - iNext. iIntros (r) "H". iApply "H_ϕ". iDestruct "H" as (ys) "(H_isList & H_post & H_length)".
    iAssert (⌜ys = (List.map (λ n : Z, #n) (List.map Z.succ xs))⌝)%I with "[-H_isList]" as %->.
    { iInduction ys as [| y ys'] "IH" forall (xs); iDestruct "H_length" as %H.
       - simpl. destruct xs; first by simpl. inversion H.
       - rewrite fmap_length in H. symmetry in H. simpl in H.
         destruct (about_length _ _ H) as (x & xs' & ->). simpl.
         iDestruct "H_post" as "(H_head & H_tail)".
         iDestruct "H_head" as (n') "(% & %)". iSimplifyEq.
         iDestruct ("IH" with "H_tail []") as %->.
         {  by rewrite fmap_length. }
         done.
    }
    iFrame.
Qed.

End list_spec.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.

Lemma app_compat_perm_latter(A:Type) : forall l a1 a2:list A, Permutation a1 a2 -> Permutation (l++a1) (l++a2).
Proof.
intros l a1 a2 Ha.
induction l.
- exact Ha.
- apply perm_skip,IHl.
Qed.

Instance app_compat_perm(A:Type) : Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A).
Proof.
unfold Proper,respectful.
intros a1 a2 Ha b1 b2 Hb.
induction Ha.
- exact Hb.
- apply perm_skip.
  exact IHHa.
- apply perm_trans with ((x::y::l)++b1).
  + apply perm_swap.
  + apply perm_skip,perm_skip,app_compat_perm_latter,Hb.
- apply perm_trans with (l'++b2); [exact IHHa1|].
  apply perm_trans with (l'++b1); [|exact IHHa2].
  apply app_compat_perm_latter,Permutation_sym,Hb.
Qed.

Lemma app_normalize_1:
  forall(A:Type) (l1 l2 l3:list A),
    (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
intros A l1 l2 l3.
rewrite app_assoc.
reflexivity.
Qed.

Lemma app_normalize_2:
  forall(A:Type) (a1:A) (l2 l3:list A),
    (a1 :: l2) ++ l3 = a1 :: (l2 ++ l3).
Proof.
intros; reflexivity.
Qed.

Lemma app_normalize_3:
  forall(A:Type) (l1:list A), (nil++l1) = l1.
Proof.
intros; reflexivity.
Qed.

Ltac app_normalize := repeat (
  rewrite app_normalize_1 ||
  rewrite app_normalize_2 ||
  rewrite app_normalize_3).

Lemma perm_takeit_1:
  forall(A:Type) (target:list A) (l1 l2:list A),
    Permutation (l1 ++ (target ++ l2)) (target ++ (l1 ++ l2)).
Proof.
intros A target l1 l2.
rewrite (app_assoc l1 target l2),
  (Permutation_app_comm l1 target),
  <-(app_assoc target l1 l2).
reflexivity.
Qed.

Lemma perm_takeit_2:
  forall(A:Type) (target:list A) (a1:A) (l2:list A),
    Permutation (a1 :: (target ++ l2)) (target ++ (a1 :: l2)).
Proof.
intros A target a1 l2.
apply (perm_takeit_1 _ _ (a1::nil)).
Qed.

Lemma perm_takeit_3:
  forall(A:Type) (target:list A) (l1:list A),
    Permutation (l1 ++ target) (target ++ l1).
Proof.
intros A target l1.
apply Permutation_app_comm.
Qed.

Lemma perm_takeit_4:
  forall(A:Type) (target:list A) (a1:A),
    Permutation (a1 :: target) (target ++ (a1::nil)).
Proof.
intros A target a1.
apply (perm_takeit_3 _ _ (a1::nil)).
Qed.

Lemma perm_takeit_5:
  forall(A:Type) (target:A) (l1 l2:list A),
    Permutation (l1 ++ (target :: l2)) (target :: (l1 ++ l2)).
Proof.
intros A target l1 l2.
apply (perm_takeit_1 _ (target::nil)).
Qed.

Lemma perm_takeit_6:
  forall(A:Type) (target:A) (a1:A) (l2:list A),
    Permutation (a1 :: (target :: l2)) (target :: (a1 :: l2)).
Proof.
intros A target a1 l2.
apply (perm_takeit_2 _ (target::nil)).
Qed.

Lemma perm_takeit_7:
  forall(A:Type) (target:A) (l1:list A),
    Permutation (l1 ++ (target::nil)) (target :: l1).
Proof.
intros A target l1.
apply (perm_takeit_3 _ (target::nil)).
Qed.

Lemma perm_takeit_8:
  forall(A:Type) (target:A) (a1:A),
    Permutation (a1 :: (target::nil)) (target :: (a1::nil)).
Proof.
intros A target a1.
apply (perm_takeit_4 _ (target::nil)).
Qed.

Ltac perm_simplify := app_normalize; repeat (
  rewrite app_nil_r ||
  match goal with
  | [ |- Permutation ?L1 ?L1 ] => reflexivity
  | [ |- Permutation (?A1++_) (?A1++_) ] => apply Permutation_app_head
  | [ |- Permutation (?A1::_) (?A1::_) ] => apply perm_skip
  | [ |- Permutation (?L1++_) _ ] => (
      rewrite (perm_takeit_1 _ L1) ||
      rewrite (perm_takeit_2 _ L1) ||
      rewrite (perm_takeit_3 _ L1) ||
      rewrite (perm_takeit_4 _ L1) )
  | [ |- Permutation (?A1::_) _ ] => (
      rewrite (perm_takeit_5 _ A1) ||
      rewrite (perm_takeit_6 _ A1) ||
      rewrite (perm_takeit_7 _ A1) ||
      rewrite (perm_takeit_8 _ A1) )
  end).

Ltac list_permutation :=
  match goal with
  | [ |- Permutation _ _ ] => perm_simplify; auto; fail "list_permutation failed"
  | [ |- _ ] => fail "list_permutation can't solve this system"
  end.

Hint Resolve Permutation_sym.


Require Export ProjectiveGeometry.Dev.p_equiv_col.

(*****************************************************************************)
(** Collinear with all **)

Section s_pEquivColWA_1.

Context `{PSLEU : ProjectiveStructureLEU}.
Context `{EP : EqDecidability Point}.
Context `{OP : OrderedType Point}.

(*** Definition all_pairs ***)
Fixpoint all_pairs (l : list Point) : list (Point * Point) :=
match l with
| nil => nil
| a :: reste => (map_monotonic (fun x:Point => (a,x)) reste) ++ all_pairs reste
end.

(*** Definition collinear_with_all ***)
Fixpoint collinear_with_all a l :=
match l with
| nil => true
| (b,c)::reste => if collinear a b c then collinear_with_all a reste else false
end.

Functional Scheme c_all_ind := Induction for collinear_with_all Sort Prop.

(*** Definition eq2 ***)
Definition eq2 X Y :=
(fst X)[==](fst Y) /\ (snd X)[==](snd Y)
\/(fst X)[==](snd Y) /\ (snd X)[==](fst Y).

End s_pEquivColWA_1.

Ltac destruct_all := match goal with [|- forall w: Point*Point, ?M] =>
  let w:= fresh in intros w; let x:=fresh "x" in let y:=fresh "y" in destruct w as [x y]  end.

Section s_pEquivColWA_2.

Context `{PSLEU : ProjectiveStructureLEU}.
Context `{EP : EqDecidability Point}.
Context `{OP : OrderedType Point}.

Lemma eq2_dec : forall X Y, {eq2 X Y}+{~eq2 X Y}.
Proof.
repeat destruct_all.
destruct (eq_dec_u x x0); destruct (eq_dec_u y y0); destruct (eq_dec_u x y0); destruct (eq_dec_u y x0); unfold eq2; simpl; try solve [intuition].
Qed.

Lemma inclA_concat : forall l m,  inclA eq2 l (l++m).
Proof.
induction l.
simpl; unfold inclA; intros.
inversion H.
intros; simpl.
unfold inclA; intros.
destruct (eq2_dec x a).
apply InA_cons_hd; assumption.
inversion H.
subst.
apply False_ind; solve [intuition].
apply InA_cons_tl.
apply IHl.
assumption.
Qed.

Lemma inclA_concat2 : forall   l m,  inclA eq2 m (l++m).
Proof.
induction l.
simpl; unfold inclA; solve [trivial].
intros; simpl.
unfold inclA; intros.
apply InA_cons_tl.
apply IHl.
assumption.
Qed.

Lemma all_pairs_lemma : forall a l, inclA eq2 (all_pairs l) (all_pairs (a::l)).
Proof.
induction l.
unfold inclA; simpl; solve [trivial].
simpl.
apply inclA_concat2 with (l:= (((a, a0)
   :: map_monotonic (fun x : Point => (a, x)) l))).
Qed.

Lemma collinear_app : forall a l m, collinear_with_all a l = true -> collinear_with_all a m = true ->
collinear_with_all a (l++m) = true.
Proof.
induction l.
simpl.
solve [trivial].
simpl; intros.
destruct a0.
destruct (collinear a p p0).
apply IHl; assumption.
inversion H.
Qed.

Lemma col_inA_all : forall a b c m, collinear a b c = false -> InA eq2 (b,c) m -> collinear_with_all a m=true -> False.
Proof.
intros a b c m; elim m using c_all_ind.
intros; subst.
inversion H0.
intros; subst.
destruct (eq2_dec (b,c) (b0,c0)).
eapply H.
eassumption.
destruct e as [(f, g) | (f, g)]; simpl in f,g.
rewrite <- f in e1.
rewrite <- g in e1.
rewrite e1 in H0.
inversion H0.
rewrite <- f in e1.
rewrite <- g in e1.
rewrite <- col_shift in e1; rewrite col_exchange in e1.
rewrite e1 in H0.
inversion H0.
assumption.
assert (T:InA eq2 (b,c) reste).
inversion H1.
apply False_ind; solve [intuition].
assumption.
apply H; assumption.
intros; subst.
inversion H1.
Qed.

Lemma collinear_inclA : forall a l m, inclA eq2 l m -> collinear_with_all a m = true -> collinear_with_all a l = true.
Proof.
intros a l; elim l using c_all_ind.
intros; subst.
solve [trivial].
intros m y r Hl b c Hy Hcol IH z; elim z using c_all_ind.
intros; subst.
assert (T: InA eq2 (b,c) ((b,c)::r)).
apply InA_cons_hd.
unfold eq2; solve [intuition].
generalize (H (b,c) T); intros Hinv; inversion Hinv.
intros; subst.
eapply (IH ((b0,c0)::reste)).
unfold inclA; intros.
apply H0.
apply InA_cons_tl.
assumption.
simpl.
destruct (collinear a b0 c0).
assumption.
inversion e1.
intros; subst.
inversion H0.
intros; subst.
assert (InA eq2 (b,c) m).
apply H.
apply InA_cons_hd.
unfold eq2; solve [intuition].
apply False_ind.
eapply col_inA_all; eassumption.
Qed.

Lemma collinear_equal :
forall a b l, a[==]b -> collinear_with_all a l = collinear_with_all b l.
Proof.
intros a b l Hab.
elim l using c_all_ind.
solve [trivial].
intros; subst; simpl.
rewrite Hab in e1.
rewrite e1.
assumption.
intros; subst; simpl.
rewrite Hab in e1.
rewrite e1.
solve [trivial].
Qed.

Global Instance eq2_equiv : Equivalence eq2.
Proof.
split.
intros s; destruct s; unfold eq2; simpl; left ; split; reflexivity.
intros x y H; destruct x; destruct y; unfold eq2;  destruct H; simpl in *.
left ; split; symmetry; solve [intuition].
right; split; symmetry; solve [intuition].
intros x y z Hxy Hyz; unfold eq2 in *;
  destruct x; destruct y; destruct z ;
  destruct Hxy as [(Hxy1,Hxy2) | (Hxy1,Hxy2)];
  destruct Hyz as [(Hyz1,Hyz2) | (Hyz1,Hyz2)]; simpl in *.
left; split.
rewrite Hxy1; rewrite Hyz1; reflexivity.
rewrite Hxy2; rewrite Hyz2; reflexivity.
right; split.
rewrite Hxy1; rewrite Hyz1; reflexivity.
rewrite Hxy2; rewrite Hyz2; reflexivity.
right; split.
rewrite Hxy1; rewrite Hyz2; reflexivity.
rewrite Hxy2; rewrite Hyz1; reflexivity.
left; split.
rewrite Hxy1; rewrite Hyz2; reflexivity.
rewrite Hxy2; rewrite Hyz1; reflexivity.
Qed.

Global Instance eq2_InA : Proper (eq2 ==> (@equivlistA (Point*Point) eq2) ==> flip impl) (InA eq2).
Proof.
repeat red.
intros x y Hxy.
intros l m; revert l; elim m.
intros; inversion H0.
intros; subst.
rewrite H0.
rewrite Hxy.
assumption.
Qed.

Global Instance collinear_with_all_morph  : Proper (eq ==> @equivlistA (Point*Point) eq2 ==> (@Logic.eq bool)) collinear_with_all.
Proof.
repeat red.
intros p q Hpq x y Hxy.
case_eq (collinear_with_all p x).
case_eq (collinear_with_all q y).
solve [trivial].
intros HA HB.
assert (T : collinear_with_all q x = true).
rewrite <- (collinear_equal p q x Hpq).
assumption.
assert (U: inclA eq2 y x).
unfold inclA; intros t; destruct (Hxy t); solve [intuition].
assert (V:=collinear_inclA q _ _ U T).
rewrite V in *.
solve [intuition].
case_eq (collinear_with_all q y).
intros HA HB.
assert (T: collinear_with_all p y = true).
rewrite <- (collinear_equal q p y).
assumption.
symmetry; solve [intuition].
assert (U:inclA eq2 x y).
unfold inclA; intros t; destruct (Hxy t); solve [intuition].
assert (V:=collinear_inclA p x y U T).
rewrite V in *.
solve [intuition].
solve [trivial].
Qed.

Lemma InA_eq2_eq_all_pairs_aux : forall a C l, InA eq2 (a, C) (map_monotonic (fun x : Point => (a, x)) l) -> InA eq C l.
Proof.
induction l.
simpl; intros Hv; inversion Hv.
simpl.
intros HInA.
inversion HInA; subst.
destruct H0 as [H0 | H0].
simpl in H0.
destruct H0 as [H1 H2]; simpl in H1,H2.
rewrite H2.
apply InA_cons_hd; reflexivity.
simpl in H0.
destruct H0.
rewrite <- H.
rewrite H0.
apply InA_cons_hd; reflexivity.
apply InA_cons_tl.
apply IHl.
assumption.
Qed.

Lemma InA_eq2_eq_all_pairs_aux' : forall a C l, InA eq2 (C, a) (map_monotonic (fun x : Point => (a, x)) l) -> InA eq C l.
Proof.
induction l.
simpl; intros Hv; inversion Hv.
simpl.
intros HInA.
inversion HInA; subst.
destruct H0 as [H0 | H0].
destruct H0 as [H1 H2]; simpl in H1,H2.
rewrite H1.
apply InA_cons_hd; assumption.
simpl in H0.
destruct H0.
rewrite <- H.
apply InA_cons_hd; reflexivity.
apply InA_cons_tl.
apply IHl.
assumption.
Qed.

Lemma InA_eq2_eq_all_pairs_aux2 : forall B C a l,
InA eq2 (B, C) (map_monotonic (fun x : Point => (a, x)) l)
-> ~ B[==]a -> ~C[==]a -> False.
Proof.
induction l.
simpl; intros Hv; inversion Hv.
simpl; intros Hv.
inversion Hv; subst.
destruct H0 as [H0 | H0].
destruct H0 as [H1 H2]; simpl in H1,H2.
intros; solve [intuition].
simpl in H0.
intros; solve [intuition].
apply IHl; assumption.
Qed.

Lemma InA_eq2_eq_all_pairs : forall B C l, InA eq2 (B,C) (all_pairs l) -> InA eq B l /\ InA eq C l.
Proof.
induction l; simpl.
intros Hx; inversion Hx.
intros.
apply InA_app_iff in H.
destruct H as [HA |HB].
destruct (eq_dec_u B a).
rewrite e in *.
destruct (eq_dec_u C a).
rewrite e0 in *.
split; apply InA_cons_hd; reflexivity.
split.
apply InA_cons_hd; reflexivity.
apply InA_cons_tl.
assert (f:eq2 (B,C) (a,C)).
unfold eq2; left; simpl; split; [assumption | reflexivity].
eapply InA_eq2_eq_all_pairs_aux; eassumption.
destruct (eq_dec_u C a).
split.
apply InA_cons_tl.
assert (f:eq2 (B,C) (B,a)).
unfold eq2; left; simpl; split; [reflexivity | assumption].
unfold map_monotonic in HA.
rewrite f in HA.
eapply InA_eq2_eq_all_pairs_aux'; eassumption.
rewrite e.
apply InA_cons_hd; reflexivity.
apply False_ind; eapply InA_eq2_eq_all_pairs_aux2; eassumption.
destruct (IHl HB).
split; apply InA_cons_tl; assumption.
Qed.

Lemma InA_eq2_map : forall a y l, InA eq y l -> InA eq2 (a, y) (map_monotonic (fun x : Point => (a, x)) l).
Proof.
induction l.
intros Hv; inversion Hv.
simpl; intros Hv.
inversion Hv; subst.
solve [intuition].
solve [intuition].
Qed.

Lemma InA_eq2_map2 : forall a y l, InA eq y l -> InA eq2 (y, a) (map_monotonic (fun x : Point => (a, x)) l).
Proof.
induction l.
intros Hv; inversion Hv.
simpl; intros Hv.
inversion Hv;subst.
unfold eq2;left;solve [intuition].
solve [intuition].
Qed.

Lemma InA_eq_eq2_all_pairs : forall x y l, InA eq x l -> InA eq y l -> ~(x[==]y) -> InA eq2 (x,y) (all_pairs l)
\/ InA eq2 (y,x) (all_pairs l).
Proof.
induction l.
intros Hy; inversion Hy.
intros;simpl.
destruct (eq_dec_u x a).
left.
assert (f:eq2 (x,y) (a,y)).
unfold eq2; simpl; left; split; solve [reflexivity | assumption].
rewrite f.
apply InA_app_iff.
left.
inversion H0;subst.
contradiction.
apply InA_eq2_map; assumption.
inversion H;subst.
apply False_ind; apply n; reflexivity.
inversion H0;subst.
right.
apply InA_app_iff.
left.
apply InA_eq2_map; assumption.
destruct (IHl H3 H4 H1).
left.
apply InA_app_iff.
right.
assumption.
right.
apply InA_app_iff.
right.
assumption.
Qed.

Lemma col_with_all_col : forall a l, collinear_with_all a l = true -> forall x y, InA eq2 (x,y) l -> collinear a x y = true.
Proof.
induction l.
simpl; intros.
inversion H0.
destruct a0.
simpl.
case_eq(collinear a p p0).
intros.
inversion H1; subst.
unfold eq2 in H3; simpl in H3 ; destruct H3 as [(H21, H22) | (H21,H22)]; simpl in *.
rewrite H21.
rewrite H22.
assumption.
rewrite H21.
rewrite H22.
rewrite col_shift.
rewrite col_exchange.
rewrite <- col_shift.
assumption.

apply IHl.
assumption.
assumption.
intros Hv; inversion Hv.
intros Hrew.
rewrite Hrew in H0.
inversion H0.
Qed.

Lemma contains_1_aux : forall A l,
collinear_with_all A l = false <-> exists B C, InA eq2 (B,C) l/\ collinear A B C= false.
Proof.
induction l.
intros; simpl; split.
intros; discriminate.
intros Hex; destruct Hex as [B [ C (HBC, Hcol)]].
inversion HBC.
simpl.
case_eq a.
intros.
case_eq (collinear A p p0).
intros.
split.
intros.
apply IHl in H1.
destruct H1 as [B [C (HIn, Hcol)]].
exists B.
exists C.
split.
apply InA_cons_tl; assumption.
assumption.
intros.
destruct H1 as [B [C (HBC,Hcol)]].
case_eq (eq2_dec (B,C) (p,p0)).
intros.
destruct e as [(e1, e2) | (e1,e2)]; simpl in *.
rewrite e1 in Hcol.
rewrite e2 in Hcol.
rewrite H0 in Hcol.
inversion Hcol.
rewrite e1 in Hcol.
rewrite e2 in Hcol.
rewrite col_shift in Hcol.
rewrite col_exchange in Hcol.
rewrite <- col_shift in Hcol.
rewrite H0 in Hcol.
inversion Hcol.

intros.
inversion HBC; subst.
apply False_ind; apply n; assumption.
apply IHl.
exists B.
exists C.
split.
assumption.
assumption.
intros.
split.
intros.
exists p.
exists p0.
split.
apply InA_cons_hd; reflexivity.
assumption.
solve [intuition].
Qed.

Lemma collinear_with_all_map : forall a l, collinear_with_all a (map_monotonic (fun x:Point => (a,x)) l)= true.
Proof.
induction l.
simpl; solve [trivial].
simpl.
unfold collinear.
destruct (eq_dec_u a a).
assumption.
apply False_ind; apply n; reflexivity.
Qed.

Lemma col_with_all_app :
  forall a l m, collinear_with_all a (l++m) = false -> collinear_with_all a l = true -> collinear_with_all a m = false.
Proof.
induction l.
simpl; solve [trivial].
intros; simpl.
apply IHl.
simpl in H.
destruct a0.
case_eq (collinear a p p0);
intros Hrew; rewrite Hrew in H.
assumption.
simpl in H0.
destruct (collinear a p p0).
inversion Hrew.
inversion H0.
simpl in H0.
destruct a0.
case_eq (collinear a p p0); intros Hrew; rewrite Hrew in H0.
assumption.
inversion H0.
Qed.

Lemma col_with_all_map : forall a a0 l, (forall A B C : Point,
    InA eq A (a :: a0 :: l) ->
    InA eq B (a :: a0 :: l) ->
    InA eq C (a :: a0 :: l) -> collinear A B C = true) -> collinear_with_all a (map_monotonic (fun x: Point => (a0,x)) l)=true.
Proof.
induction l.
intros; simpl.
solve [trivial].
intros.
simpl.
assert (T:collinear a a0 a1=true).
apply H.
apply InA_cons_hd; reflexivity.
apply InA_cons_tl; apply InA_cons_hd; reflexivity.
apply InA_cons_tl; apply InA_cons_tl; apply InA_cons_hd; reflexivity.
rewrite T.
apply IHl.
intros; apply H.
inversion H0; subst.
apply InA_cons_hd; reflexivity.
inversion H4; subst.
apply InA_cons_tl; apply InA_cons_hd; reflexivity.
apply InA_cons_tl; apply InA_cons_tl; apply InA_cons_tl; assumption.

inversion H1; subst.
apply InA_cons_hd; reflexivity.
inversion H4; subst.
apply InA_cons_tl; apply InA_cons_hd; reflexivity.
apply InA_cons_tl; apply InA_cons_tl; apply InA_cons_tl; assumption.

inversion H2; subst.
apply InA_cons_hd; reflexivity.
inversion H4; subst.
apply InA_cons_tl; apply InA_cons_hd; reflexivity.
apply InA_cons_tl; apply InA_cons_tl; apply InA_cons_tl; assumption.
Qed.

Lemma forall_InA_collinear_with_all :
forall a l, ( forall A B C : Point,
    InA eq A (a :: l) ->
    InA eq B (a :: l) -> InA eq C (a :: l) -> collinear A B C = true) ->
collinear_with_all a (all_pairs l) = false -> False.
Proof.
induction l.
simpl; intros HA HB.
inversion HB.
simpl;intros.
apply IHl.
intros; apply H.
inversion H1; subst.
apply InA_cons_hd.
reflexivity.
apply InA_cons_tl; apply InA_cons_tl; assumption.
inversion H2; subst.
apply InA_cons_hd.
reflexivity.
apply InA_cons_tl; apply InA_cons_tl; assumption.
inversion H3; subst.
apply InA_cons_hd.
reflexivity.
apply InA_cons_tl; apply InA_cons_tl; assumption.
eapply col_with_all_app.
eassumption.
apply col_with_all_map.
intros; apply H; assumption.
Qed.

Lemma col_aux : forall a B C l, collinear_with_all a l = true -> InA eq2 (B,C) l\/InA eq2 (C,B) l -> collinear a B C = true.
Proof.
induction l.
simpl; intros HA HB.
destruct HB as [HB | HB]; inversion HB.
simpl; destruct a0.
case_eq (collinear a p p0).
intros.
destruct H1 as [H1 | H1].
inversion H1; subst.
simpl in H3; destruct H3 as [(H3a, H3b)| (H3a, H3b)]; simpl in H3a, H3b.
rewrite H3a, H3b.
assumption.
rewrite H3a, H3b.
rewrite col_shift.
rewrite col_exchange.
rewrite <- col_shift.
assumption.
apply IHl.
assumption.
left.
assumption.
inversion H1; subst.
simpl in H3; destruct H3 as [(H3a,H3b)|(H3a,H3b)]; simpl in H3a, H3b.
rewrite H3a, H3b.
rewrite col_shift; rewrite col_exchange; rewrite <- col_shift.
assumption.
rewrite H3a, H3b.
assumption.
apply IHl.
assumption.
right.
assumption.
intros HA HB; inversion HB.
Qed.

Lemma matroid3_aux0 : forall l, forall a a0,
collinear_with_all a (all_pairs (a0 :: l)) = true ->
collinear_with_all a (all_pairs l) = true.
Proof.
intros.
simpl in *.
assert (T:inclA eq2 (all_pairs l) (map_monotonic (fun x : Point => (a0, x)) l ++ all_pairs l)).
apply inclA_concat2.
eapply collinear_inclA.
eassumption.
assumption.
Qed.

Lemma col_caract : forall a l,
collinear_with_all a l = true <-> forall x y, InA eq2 (x,y) l -> collinear a x y = true.
Proof.
induction l.
split.
intros H x y H'; inversion H'.
intros; simpl; solve [trivial].
split.
intros.
simpl in H.
destruct a0.
case_eq (collinear a p p0).
intros Hrew; rewrite Hrew in *.
inversion H0; subst.
destruct H2 as [(H2a,H2b) | (H2a,H2b)]; simpl in H2a,H2b.
rewrite H2a, H2b.
assumption.
rewrite H2a, H2b.
rewrite col_shift.
rewrite col_exchange.
rewrite <- col_shift.
assumption.
apply IHl; assumption.
intros Hrew; rewrite Hrew in *.
inversion H.
intros.
simpl.
destruct a0.
case_eq (collinear a p p0).
intros.
apply IHl.
intros.
apply H.
apply InA_cons_tl.
assumption.
intros.
assert (Hc:collinear a p p0=true).
apply H; apply InA_cons_hd; unfold eq2; left; simpl; split; reflexivity.
rewrite Hc in *.
inversion H0.
Qed.

Lemma matroid3_aux0_bis : forall l, forall a a0,
collinear_with_all a (all_pairs (a0 :: l)) = true ->
collinear_with_all a0 (all_pairs l) = true.
Proof.
intros.
destruct (eq_dec_u a a0).
rewrite e in *.
eapply collinear_inclA with (all_pairs (a0 :: l)).
apply all_pairs_lemma.
assumption.

generalize (col_caract a (all_pairs (a0::l))); intros (HA,HB).
generalize (HA H); intros Hyp; clear H HA HB.
apply col_caract.
intros.
eapply col_trans_bis with a.
eassumption.
apply Hyp.
generalize (InA_eq2_eq_all_pairs x y l H); intros HInA.
simpl;apply InA_app_iff.
left.
apply InA_eq2_map; solve [intuition].
apply Hyp.
generalize (InA_eq2_eq_all_pairs x y l H); intros HInA.
simpl;apply InA_app_iff.
left.
apply InA_eq2_map; solve [intuition].
Qed.

End s_pEquivColWA_2.


(** * Pwpath - Pointwise Path

    点付きの道についての定義、定理を記述する。 *)

Require Import Basis .
Require Import Path .

(** 戦術を使う。 *)
Declare ML Module "ltac_plugin" .
Set Default Proof Mode "Classic" .

(** 記法を使う。 *)
Import Basis.Notation .
Import Basis.Notation.Path .
Import Path.Notation .

(** 道から、点ごとの道を得る。

    逆は [funext] であり、証明も反証もできない。 *)
Definition pwpaths_paths
  {A : Type} {B : A -> Type}
  {f g : forall a, B a} (p : paths f g)
  : pwpaths f g
  := ap10_dep p .

(** 点ごとの恒等道。 *)
Definition idpath_pw
  (A : Type) (B : A -> Type)
  (f : forall a, B a)
  : pwpaths f f
  := fun a => idpath (f a) .

Arguments idpath_pw {_ _ _} , [_ _] _ .

(** 点ごとの道の逆。 *)
Definition inverse_pw
  {A : Type} {B : A -> Type}
  {f g : forall a, B a}
  (p : pwpaths f g)
  : pwpaths g f
  := fun a => inverse (p a) .

(** 点ごとの道の合成。 *)
Definition concat_pw
  {A : Type} {B : A -> Type}
  {f g h : forall a, B a}
  (p : pwpaths f g) (q : pwpaths g h)
  : pwpaths f h
  := fun a => concat (p a) (q a) .

(** 点ごとの道の両辺に、左から関数を合成する。 *)
Definition wiskerL_pw_fn
  {A B C : Type}
  (f : B -> C)
  {g h : A -> B} (p : g == h)
  : f o g == f o h .
Proof.
 refine (fun x => _) .
 change (f (g x) = f (h x)) .
 refine (ap f _) .
 exact (p x) .
Defined.

(** 点ごとの道の両辺に、右から関数を合成する。 *)
Definition wiskerR_pw_fn
  {A B C : Type}
  {f g : B -> C} (p : pwpaths f g)
  (h : A -> B)
  : f o h == g o h .
Proof.
 refine (fun x => _) .
 change (f (h x) = g (h x)) .
 exact (p (h x)) .
Defined.

Definition wiskerL_pw_fn_p
  {A B C : Type}
  (f : B -> C)
  {g h : A -> B} {p q : g == h} (r : p == q)
  : wiskerL_pw_fn f p == wiskerL_pw_fn f q .
Proof.
 refine (fun x => _) .
 change (ap f (p x) = ap f (q x)) .
 refine (ap (ap f) _) .
 exact (r x) .
Defined.

Definition wiskerR_pw_fn_p
  {A B C : Type}
  {f g : B -> C} {p q : pwpaths f g} (r : p == q)
  (h : A -> B)
  : wiskerR_pw_fn p h == wiskerR_pw_fn q h .
Proof.
 refine (fun x => _) .
 change (p (h x) = q (h x)) .
 exact (r (h x)) .
Defined.

(** [wiskerL_pw_fn] の分配則。 *)
Definition wiskerL_pw_fn_pp
  {A B C : Type}
  (f : B -> C)
  {g h i : A -> B} (p : g == h) (q : h == i)
  : pwpaths
    (wiskerL_pw_fn f (concat_pw p q))
    (concat_pw (wiskerL_pw_fn f p) (wiskerL_pw_fn f q)) .
Proof.
 refine (fun x => _) .
 change (ap f (concat_pw p q x) = wiskerL_pw_fn f p x @ wiskerL_pw_fn f q x) .
 change (ap f (p x @ q x) = ap f (p x) @ ap f (q x)) .
 exact (ap_pp f (p x) (q x)) .
Defined.

(** [wiskerR_pw_fn] の分配則。 *)
Definition wiskerR_pw_fn_pp
  {A B C : Type}
  {f g h : B -> C} (p : f == g) (q : g == h)
  (i : A -> B)
  : pwpaths
    (wiskerR_pw_fn (concat_pw p q) i)
    (concat_pw (wiskerR_pw_fn p i) (wiskerR_pw_fn q i)) .
Proof.
 refine (fun x => _) .
 change (concat_pw p q (i x) = wiskerR_pw_fn p i x @ wiskerR_pw_fn q i x) .
 change (p (i x) @ q (i x) = p (i x) @ q (i x)) .
 exact 1 .
Defined.

(** [wiskerL_pw_fn] の分配則その２。 *)
Definition wiskerL_pw_fn_ff
  {A B C D : Type}
  (f : C -> D) (g : B -> C)
  {h i : A -> B} (p : h == i)
  : pwpaths
    (wiskerL_pw_fn (f o g) p)
    (wiskerL_pw_fn f (wiskerL_pw_fn g p)) .
Proof.
 refine (fun x => _) .
 change (ap (f o g) (p x) = ap f (ap g (p x))) .
 exact (ap_ff f g (p x)) .
Defined.

(** [wiskerR_pw_fn] の分配則その２。 *)
Definition wiskerR_pw_fn_ff
  {A B C D : Type}
  {f g : C -> D} (p : f == g)
  (h : B -> C) (i : A -> B)
  : pwpaths
    (wiskerR_pw_fn p (h o i))
    (wiskerR_pw_fn (wiskerR_pw_fn p h) i) .
Proof.
 refine (fun x => _) .
 change (p ((h o i) x) = p (h (i x))) .
 exact 1 .
Defined.

(** 二つの、関手を恒等関手に移す自然変換があるのならば、
    それらをどのような順番で適用しても等しい。 *)
Definition concat_pw_wLpp
  {A : Type} {f g : A -> A}
  (p : f == idmap) (q : g == idmap)
  : concat_pw (wiskerL_pw_fn f q) p == concat_pw (wiskerR_pw_fn p g) q .
Proof.
 refine (fun x => _) .
 change (wiskerL_pw_fn f q x @ p x = wiskerR_pw_fn p g x @ q x) .
 change (ap f (q x) @ p x = p (g x) @ q x) .
 refine (
   paths_elim _ (q x)
     (P := fun x' qx' => ap f qx' @ p x' = p (g x) @ qx')
   ) .
 change (1 @ p (g x) = p (g x) @ 1) .
 refine (
   concat (y := p (g x)) _ _
   ) .
 -
  exact (concat_1p (p (g x))) .
 -
  exact (concat_p1 (p (g x)))^ .
Defined.

(** [wiskerL_pw_fn] と [wiskerR_pw_fn] は交換する。 *)
Definition wiskerLR_pw_fn_comm
  {A B C D : Type}
  (f : C -> D)
  {g h : B -> C} (p : g == h)
  (i : A -> B)
  : pwpaths
    (wiskerR_pw_fn (wiskerL_pw_fn f p) i)
    (wiskerL_pw_fn f (wiskerR_pw_fn p i)) .
Proof.
 refine (fun x => _) .
 change (wiskerL_pw_fn f p (i x) = ap f (wiskerR_pw_fn p i x)) .
 change (ap f (p (i x)) = ap f (p (i x))) .
 exact 1 .
Defined.

(** 点ごとの道の点ごとの道の両辺に、左から点ごとの道を合成する。 *)
Definition wiskerL_pw_pw
  {A B : Type} {f g h : A -> B}
  (p : f == g)
  {q r : g == h} (s : q == r)
  : concat_pw p q == concat_pw p r .
Proof.
 refine (fun x => _) .
 change (p x @ q x = p x @ r x) .
 refine (wiskerL (p x) _) .
 exact (s x) .
Defined.

(** 点ごとの道の点ごとの道の両辺に、右から点ごとの道を合成する。 *)
Definition wiskerR_pw_pw
  {A B : Type} {f g h : A -> B}
  {p q : f == g} (r : p == q)
  (s : g == h)
  : concat_pw p s == concat_pw q s .
Proof.
 refine (fun x => _) .
 change (p x @ s x = q x @ s x) .
 refine (wiskerR _ (s x)) .
 exact (r x) .
Defined.

(** 点ごとの道の点ごとの道を、縦に合成する。 *)
Definition concat_pw_pw
  {A B : Type} {f g h : A -> B}
  {p q : f == g} (r : p == q)
  {s t : g == h} (u : s == t)
  : concat_pw p s == concat_pw q t .
Proof.
 refine (fun x => _) .
 change (p x @ s x = q x @ t x) .
 refine (concat2 _ _) .
 -
  exact (r x) .
 -
  exact (u x) .
Defined.

(** ** Notations

    記法を定義する。 *)

Module Notation .

  (** 記法が使われる文脈を設定する。 *)
  Delimit Scope pwpath_scope with pwpath .

  (** 文脈を開く。 *)
  Open Scope pwpath_scope .

  (** 文脈を型と結びつける。 *)
  Bind Scope pwpath_scope with pwpaths .

  (** [paths] の [idpath] に準じたもの。 *)
  Notation "1" := idpath_pw
    : pwpath_scope
    .

  (** [paths] の　[concat] に準じたもの。 *)
  Notation "p @ q" := (concat_pw p q)
    (at level 20)
    : pwpath_scope
    .

  (** [paths] の [inverse] に準じたもの。 *)
  Notation "p ^" := (inverse_pw p)
    (at level 3, format "p '^'")
    : pwpath_scope
    .

  (** [wiskerL_pw_fn] の記法。 *)
  Notation "f @> p" := (wiskerL_pw_fn f p)
    (at level 41, right associativity)
    : pwpath_scope
    .

  (** [wiskerR_pw_fn] の記法。 *)
  Notation "p <@ i" := (wiskerR_pw_fn p i)
    (at level 42, left associativity)
    : pwpath_scope
    .

  (** [concat_pw_pw] の記法。 *)
  Notation "r @@ u" := (concat_pw_pw r u)
    (at level 30)
    : pwpath_scope
    .

  (** 等式を鎖状につなげるための記法。

      <<
          (* x0 *)
        _
          @[ x1 ]
        _
          @[ x2 ]
        _
          (* x3 *)
      >>

      *)

  Module Chain .

    (** [p @ q] の、中間の型を明示した記法。 *)
    Notation "p @[ f ] q" := (concat_pw (g := f) p q)
      (at level 50, only parsing, left associativity)
      : pwpath_scope
      .

  End Chain .

End Notation .

(** 参考文献:

    * https://github.com/HoTT/HoTT/blob/1940297dd121d54d033274d84c5d023fdc56bfb4/theories/Basics/PathGroupoids.v

    *)


(** * Tarski Semantics *)

Require Export Undecidability.FOL.FOL.

(** ** Variables and Substitutions *)

Fixpoint vars_t (t : term) : list var :=
  match t with
  | V v => [v]
  | P p => []
  | t_f b t => vars_t t
  | t_e => []
  end.

Fixpoint consts_t (t : term) : list var :=
  match t with
  | V v => []
  | P p => [p]
  | t_f b t => consts_t t
  | t_e => []
  end.

Fixpoint subst_t x y (t : term) : term :=
  match t with
  | V v => if Dec (v = x) then y else V v
  | P p => P p
  | t_e => t_e
  | t_f b t => t_f b (subst_t x y t)
  end.

Fixpoint consts {b} (phi : form b) : list var :=
  match phi with
  | Pr t1 t2  => consts_t t1 ++ consts_t t2
  | Fal
  | Q => []
  | Impl phi psi => consts phi ++ consts psi
  | All v phi => v :: consts phi
  end.

Fixpoint subst {b} x t phi :=
  match phi with
  | Pr t1 t2 => Pr (subst_t x t t1) (subst_t x t t2)
  | Q => Q
  | Fal => Fal
  | Impl phi1 phi2 => Impl (subst x t phi1) (subst x t phi2)
  | All v phi => All v (if Dec (x = v) then phi else subst x t phi)
  end.

Definition consts_l {b} A := flat_map (@consts b) A.
Definition fresh (y : var) A := ~ y el A.

Fixpoint mkfresh (l : list nat) :=
  match l with
  | [] => 0
  | x :: l => S x + mkfresh l
  end.

Lemma mkfresh_spec l a : a el l -> a < mkfresh l.
Proof.
  induction l.
  - firstorder.
  - cbn; intros [ | ]; firstorder omega.
Qed.

Lemma make_fresh A : {z | fresh z A}.
Proof.
  exists (mkfresh A). intros ? % mkfresh_spec. omega.
Defined.

Lemma app_sub X (A A' B B' : list X) :
  A <<= A' -> B <<= B' -> A ++ B <<= A' ++ B'.
Proof.
  intros H1 H2 x [H|H] % in_app_iff.
  all: apply in_app_iff; auto.
Qed.

(** ** Interpretations *)

Class interp (domain : Type) (rho : nat -> domain) :=
  {
    i_f : bool -> domain -> domain ;
    i_e : domain ;
    i_P : domain -> domain -> Prop ;
    i_Q : Prop
  }.

Section Semantics.

  Notation const := nat.
  Variable domain : Type.

  Definition env := var -> domain.

  Variable (eta : env).
  Context {I : interp eta}.

  Fixpoint eval (rho : env) (t : term) : domain :=
    match t with
    | V s => rho s
    | P p => eta p
    | t_f b t => i_f b (eval rho t)
    | t_e => i_e
    end.

  Definition update {X} (rho : var -> X) (v : var) (d : X) :=
    (fun v' => if (Dec (v = v')) then d else rho v').

  Notation "rho [[ v := d ]]" := (update rho v d) (at level 20).

  Fixpoint sat {b} (rho : env) (phi : form b) : Prop :=
    match phi with
    | Pr t1 t2 =>  i_P (eval rho t1) (eval rho t2)
    | Q => i_Q
    | Fal => False
    | Impl phi psi => sat rho phi -> sat rho psi
    | All v phi => forall d : domain, sat (rho [[ v := d ]]) phi
    end.
  Notation "rho ⊫ A" := (forall psi, psi el A -> sat rho psi) (at level 20).
  Notation "rho ⊨ phi" := (sat rho phi) (at level 20).

  Context {b : logic}.

  Lemma impl_sat A rho phi :
    sat rho (A ==> phi) <-> ((forall psi, psi el A -> sat rho psi) -> sat rho phi).
  Proof.
    induction A; cbn; firstorder congruence.
  Qed.

  Lemma impl_sat' A rho phi :
    sat rho (A ==> phi) -> ((forall psi, psi el A -> sat rho psi) -> sat rho phi).
  Proof.
    eapply impl_sat.
  Qed.

End Semantics.

Ltac decs :=
  unfold update; repeat destruct _;
  subst; cbn; try congruence; try reflexivity; auto.

Notation "rho [[ v := d ]]" := (update rho v d) (at level 20).

Arguments sat {_ _} _ {_} _ _, {_} _ _ {_} _ _.
Arguments interp {_} _, _ _.

Notation "p ⊫ A" := (forall psi, psi el A -> sat _ p psi) (at level 20).
Notation "p ⊨ phi" := (sat _ p phi) (at level 20).

Implicit Type b : logic.

Definition valid b phi := forall D eta (I : interp D eta) rho, rho ⊨ phi.
Definition valid_L b A := forall D eta (I : interp D eta) rho, rho ⊫ A.
Definition satis b phi := exists D eta (I : interp D eta) rho, rho ⊨ phi.
Definition fullsatis b A := exists D eta (I : interp D eta) rho, rho ⊫ A.

(** Trivial Model *)

Section TM.

  Instance TM : interp unit (fun _ => tt) :=
    {| i_f := fun _ _ => tt; i_e := tt; i_P := fun _ _ => True; i_Q := True |}.

  Fact TM_sat (rho : var -> unit) (phi : form frag) :
    sat TM rho phi.
  Proof.
    revert rho. induction phi using form_frag_ind; cbn; auto.
  Qed.

End TM.