Require Import List.
Import ListNotations.
Require Import Coq.Program.Wf.
Require Import Coq.omega.Omega.

Require Import Coq.NArith.BinNat.

From Verbatim Require Import ltac.
From Verbatim Require Import regex.

Module Type TABLE (R : regex.T).

  Import R.Ty.
  Module Import DS := R.Defs.
  Module Import reFS := DS.reFS.

  Parameter Table : Type.
  Parameter emptyTable : Table.
  (*The first regex is for indexing, the second is the content of the cell*)
  Parameter set_Table : Table -> regex -> Sigma -> regex -> Table.
  Parameter get_Table : Table -> regex -> Sigma -> option (regex).

  Parameter correct_Table : forall T e a r, get_Table (set_Table T e a r) e a = Some (r).
  Parameter moot_setTable : forall T e0 e a b r,
      a <> b
      \/ e <> e0
      -> get_Table (set_Table T e b r) e0 a = get_Table T e0 a.
  Parameter correct_emptyTable : forall e a, get_Table emptyTable e a = None.

  Parameter add_state : Table -> regex -> Table.
  Parameter get_states : Table -> t.
  Parameter empty_states : get_states emptyTable = empty.
  Parameter correct_states : forall T r, In r (get_states (add_state T r)).
  Parameter moot_add_state : forall T e a r,
      get_Table T e a = get_Table (add_state T r) e a.
  (* might need a hypothesis about not being in states *)

  Parameter get_eq : Table -> regex -> option regex.

  Parameter get_eq_correct : forall T e e',
      get_eq T e = Some e' -> In e' (get_states T) /\ regex_eq e e' = true.

End TABLE.

Module DefsFn (R : regex.T) (TabTy : TABLE R).

  Import TabTy.
  Import R.Defs.
  Import R.Ty.

  Module Export FillTable.

    Import R.Defs.Helpers.

    (* Assume all union inputs are already canonical:
       1. All iterared unions are recursively right associated
       2. All iterated unions are in lexicographic order
       3. The EmptySet is not present in any union
       4. All regexes in all iterated unions are unique
     *)
    Fixpoint mkIterUnion' (e : regex) : list regex :=
      match e with
      | Union e1 e2 =>
        e1 :: (mkIterUnion' e2)
      | _ => [e]
      end.

    (**
    (* automation *)
    Program Fixpoint merge (es1 es2 : list regex)
            { measure ((length es1) + (length es2)) } : list regex :=
      match es1, es2 with
      | [], _ => es2
      | _, [] => es1
      | h1 :: t1, h2 :: t2 =>
        match re_compare h1 h2 with
        | Eq => merge (h1 :: t1) t2
        | Lt => h1 :: (merge t1 (h2 :: t2))
        | Gt => h2 :: (merge (h1 :: t1) t2)
        end
      end.
    Next Obligation.
      simpl. omega.
    Defined.
    Next Obligation.
      simpl. omega.
    Defined.

    (* issues unfolding things *)
    Lemma merge_cons : forall t1 t2 h1 h2,
        match re_compare h1 h2 with
        | Eq => merge (h1 :: t1) (h2 :: t2) = merge (h1 :: t1) t2
        | Lt => merge (h1 :: t1) (h2 :: t2) = h1 :: (merge t1 (h2 :: t2))
        | Gt => merge (h1 :: t1) (h2 :: t2) =  h2 :: (merge (h1 :: t1) t2)
        end.
    Proof.
      intros. dm.
      - unfold merge. unfold merge_func. rewrite fix_sub_eq.
        + simpl. rewrite E. auto.
        + intros. destruct x. induction x.
          * auto.
          *
    Abort.
     *)

    (* acc proof method, issues type checking *)
    Lemma merge_acc1 :
      forall es1 es2 t1 t2 (h1 h2 : regex),
        Acc lt (length es1 + length es2)
        -> (es1, es2) = (h1 :: t1, h2 :: t2)
        -> Acc lt ((length (h1 :: t1)) + (length t2)).
    Proof.
      intros. inv H0. inv H. apply H0. simpl. omega.
    Defined.

    Lemma merge_acc2 :
      forall es1 es2 t1 t2 (h1 h2 : regex),
        Acc lt (length es1 + length es2)
        -> (es1, es2) = (h1 :: t1, h2 :: t2)
        -> Acc lt ((length t1) + (length (h2 :: t2))).
    Proof.
      intros. inv H0. inv H. auto.
    Defined.

    Lemma merge_acc3 :
      forall es1 es2 t1 t2 (h1 h2 : regex),
        Acc lt (length es1 + length es2)
        -> (es1, es2) = (h1 :: t1, h2 :: t2)
        -> Acc lt ((length (h1 :: t1)) + (length t2)).
    Proof.
      apply merge_acc1.
    Defined.

    Fixpoint merge' (es1 es2 : list regex)
            (Ha : Acc lt ((length es1) + (length es2)))
            {struct Ha} : list regex :=
      match (es1, es2) as tpl return (es1, es2) = tpl -> _ with
      | ([], _) => fun _ => es2
      | (_, []) => fun _ => es1
      | (h1 :: t1, h2 :: t2) =>
        fun Heq =>
        match re_compare h1 h2 with
        | Eq => merge' (h1 :: t1) t2 (merge_acc1 _ _ _ _ _ _ Ha Heq)
        | Lt => h1 :: (merge' t1 (h2 :: t2) (merge_acc2 _ _ _ _ _ _ Ha Heq))
        | Gt => h2 :: (merge' (h1 :: t1) t2 (merge_acc3 _ _ _ _ _ _ Ha Heq))
        end
      end eq_refl.

    (* Beginning of Sam's contributions *)

    (* lemma for unfolding merge' *)
    Lemma merge'_eq_body :
      forall (es1 es2 : list regex)
             (Ha : Acc lt (length es1 + length es2)),
        merge' es1 es2 Ha =
        match (es1, es2) as tpl return (es1, es2) = tpl -> _ with
        | ([], _) => fun _ => es2
        | (_, []) => fun _ => es1
        | (h1 :: t1, h2 :: t2) =>
          fun Heq =>
            match re_compare h1 h2 with
            | Eq => merge' (h1 :: t1) t2 (merge_acc1 _ _ _ _ _ _ Ha Heq)
            | Lt => h1 :: (merge' t1 (h2 :: t2) (merge_acc2 _ _ _ _ _ _ Ha Heq))
            | Gt => h2 :: (merge' (h1 :: t1) t2 (merge_acc3 _ _ _ _ _ _ Ha Heq))
            end
        end eq_refl.
    Proof.
      intros; destruct Ha; auto.
    Qed.

    (* The original lemma you wanted to prove,
       although it's complicated a bit by proof terms *)
    Lemma merge'_cons :
      forall t1 t2 h1 h2 Ha,
        match re_compare h1 h2 with
        | Eq => merge' (h1 :: t1) (h2 :: t2) Ha =
                merge' (h1 :: t1) t2 (merge_acc1 _ _ _ _ _ _ Ha eq_refl)
        | Lt => merge' (h1 :: t1) (h2 :: t2) Ha =
                h1 :: merge' t1 (h2 :: t2) (merge_acc2 _ _ _ _ _ _ Ha eq_refl)
        | Gt => merge' (h1 :: t1) (h2 :: t2) Ha =
                h2 :: merge' (h1 :: t1) t2 (merge_acc3 _ _ _ _ _ _ Ha eq_refl)
        end.
    Proof.
      intros t1 t2 h1 h2 Ha; rewrite merge'_eq_body; dm.
    Qed.

    (* You can also define a top-level function that calls
       merge' with the right initial Acc term *)
    Definition merge'' (es1 es2 : list regex) : list regex :=
      merge' es1 es2 (lt_wf _).

    (* If you naively start to prove things about it,
       though, you run into trouble *)
    Lemma merge''_cons :
      forall t1 t2 h1 h2,
        match re_compare h1 h2 with
        | Eq => merge'' (h1 :: t1) (h2 :: t2) = merge'' (h1 :: t1) t2
        | Lt => merge'' (h1 :: t1) (h2 :: t2) = h1 :: merge'' t1 (h2 :: t2)
        | Gt => merge'' (h1 :: t1) (h2 :: t2) = h2 :: merge'' (h1 :: t1) t2
        end.
    Proof.
      intros t1 t2 h1 h2.
      unfold merge''.
      dm.
      - (* uh-oh, the proof terms are different *)
    Abort.

    (* We need to prove that the function's input/output
       behavior doesn't depend on the Acc term
       (seems obvious, but I don't think the general fact
       is provable within Coq) *)
    Lemma merge'_ignores_acc' :
      forall len es1 es2 (Ha Ha' : Acc lt (length es1 + length es2)),
        len = length es1 + length es2
        -> merge' es1 es2 Ha = merge' es1 es2 Ha'.
    Proof.
      intros len.
      induction len as [len IH] using lt_wf_ind; intros es1 es2 Ha Ha' Heq; subst.
      repeat rewrite merge'_eq_body.
      destruct es1 as [| h1 t1]; auto.
      destruct es2 as [| h2 t2]; auto.
      destruct (re_compare h1 h2) eqn:Heq.
      - apply IH with (m := length (h1 :: t1) + length t2); auto.
        simpl; omega.
      - erewrite IH with (m := length t1 + length (h2 :: t2)); eauto.
      - erewrite IH with (m := length (h1 :: t1) + length t2); eauto.
        simpl; omega.
    Qed.

    Lemma merge'_ignores_acc :
      forall es1 es2 (Ha Ha' : Acc lt (length es1 + length es2)),
        merge' es1 es2 Ha = merge' es1 es2 Ha'.
    Proof.
      intros; eapply merge'_ignores_acc'; eauto.
    Qed.

    (* Now we can prove the lemma you wanted about the
       top-level function (this proof could be automated,
       but I set it up so you can step through if you're
       curious) *)
    Lemma merge''_cons :
      forall t1 t2 h1 h2,
        match re_compare h1 h2 with
        | Eq => merge'' (h1 :: t1) (h2 :: t2) = merge'' (h1 :: t1) t2
        | Lt => merge'' (h1 :: t1) (h2 :: t2) = h1 :: merge'' t1 (h2 :: t2)
        | Gt => merge'' (h1 :: t1) (h2 :: t2) = h2 :: merge'' (h1 :: t1) t2
        end.
    Proof.
      intros t1 t2 h1 h2.
      unfold merge''.
      pose proof (merge'_cons t1 t2 h1 h2) as Hmc.
      dm.
      - rewrite Hmc.
        erewrite merge'_ignores_acc. eauto.
      - rewrite Hmc.
        erewrite merge'_ignores_acc; eauto.
      - rewrite Hmc.
        erewrite merge'_ignores_acc; eauto.
    Qed.

    (* End of Sam's contributions *)

    (* Cleanly pack those contributions *)
    Definition merge := merge''.

    Lemma merge_cons :
      forall t1 t2 h1 h2,
        match re_compare h1 h2 with
        | Eq => merge (h1 :: t1) (h2 :: t2) = merge (h1 :: t1) t2
        | Lt => merge (h1 :: t1) (h2 :: t2) = h1 :: merge t1 (h2 :: t2)
        | Gt => merge (h1 :: t1) (h2 :: t2) = h2 :: merge (h1 :: t1) t2
        end.
    Proof.
      apply merge''_cons.
    Qed.

    Lemma MNil : forall z,
        not (exp_match z EmptySet).
    Proof.
      intros. intros C. inv C.
    Qed.

    Lemma merge_nil1 : forall es,
        merge [] es = es.
    Proof. auto. Qed.

    Lemma merge_nil2 : forall es,
        merge es [] = es.
    Proof. destruct es; auto. Qed.

    Lemma merge_In : forall es es' e,
        In e (merge es es') <-> (In e es \/ In e es').
    Proof.
      intros. split; intros.
      {
        generalize dependent es'. generalize dependent e.
        induction es; intros.
        - rewrite merge_nil1 in H. auto.
        - induction es'; sis; auto.
          assert(L := merge_cons es es' a a0). destruct (re_compare a a0).
          + rewrite L in H. apply IHes' in H. destruct H; auto.
          + rewrite L in H. simpl in H. destruct H; auto.
            apply IHes in H. destruct H; auto.
          + rewrite L in H. simpl in H. destruct H; auto.
            apply IHes' in H. destruct H; auto.
      }
      {
        generalize dependent es'. generalize dependent e.
        induction es; intros.
        - rewrite merge_nil1. destruct H; auto. contradiction.
        - induction es'; sis.
          + destruct H; auto. contradiction.
          + assert(L := merge_cons es es' a a0). destruct (re_compare a a0) eqn:E.
            * rewrite L. apply IHes'. destruct H; auto. destruct H; auto.
              left. left. apply re_compare_eq in E. rewrite E. auto.
            * rewrite L. simpl. destruct H; auto. destruct H; auto.
            * rewrite L. simpl. destruct H; auto. destruct H; auto.
      }
    Qed.

    (* Assume all App inputs and subterms are recursively right associated *)
    Fixpoint mkIterApp' (e : regex) : list regex :=
      match e with
      | App e1 e2 => e1 :: (mkIterApp' e2)
      | _ => [e]
      end.

    (* Instead of checking for similarity,
       force all regexes to be in the right hand form of the relation.
       Also use associativity/commutativity to force lexical ordering on Unioned exps
       Then check for equality.
     *)
    Fixpoint canon (e : regex) : regex :=
      match e with
      | Union e1 e2 =>
        match canon e1, canon e2 with
        (* The next two patters ensure that unions don't contain EmptySet *)
        | EmptySet, ec2 => ec2
        | ec1, EmptySet => ec1
        | ec1, ec2 =>
          (* sort and make right recursive *)
          (* Note : merge also removes duplicates *)
          IterUnion (merge (mkIterUnion' ec1) (mkIterUnion' ec2))
        end
      | App e1 e2 =>
        match canon e1, canon e2 with
        (* The next two patterns ensure that all iterated apps
           containing an EmptySet reduce to the EmptySet *)
        | EmptySet, _ => EmptySet
        | _, EmptySet => EmptySet
        (* The next two patters ensure that apps don't contain EmptyStr *)
        | EmptyStr, ec2 => ec2
        | ec1, EmptyStr => ec1
        | ec1, ec2 =>
          IterApp ( (mkIterApp' ec1) ++ (mkIterApp' ec2) )
        end
      | Star EmptySet => EmptyStr
      | Star EmptyStr => EmptyStr
      (*
      | Star r =>
        match canon r with
        | Star _ => r
        | r' => Star r'
        end*)
      | _ => e
      end.

    Lemma invertIterApp : forall e z,
        exp_match z (IterApp (mkIterApp' e)) <-> exp_match z e.
    Proof.
      induction e; try(sis; reflexivity).
      sis. dm; try(destruct e2; discriminate).
      rewrite <- E in *. clear E.
      split; intros.
      - inv H. apply IHe2 in H4. constructor; auto.
      - inv H. constructor; auto. apply IHe2. auto.
    Qed.

    Lemma consIterApp : forall es e z,
        exp_match z (IterApp (e :: es))
        <-> exp_match z (App e (IterApp es)).
    Proof.
      intros. simpl. destruct es.
      {
        split; intros.
        - sis. assert(z = z ++ []). symmetry. apply app_nil_r.
          rewrite H0. clear H0.
          constructor; auto; constructor.
        - inv H. inv H4. rewrite app_nil_r. auto.
      }
      {
        split; intros; auto.
      }
    Qed.

    Lemma bar : forall es es' z,
        exp_match z (IterApp (es ++ es'))
        <-> exp_match z (App (IterApp es) (IterApp es')).
    Proof.
      induction es; intros.
      {
        split; intros; sis; assert(z = [] ++ z); auto.
        - rewrite H0. constructor; auto; constructor.
        - inv H. inv H4. sis. auto.
      }
      {
        split; intros.
        - rewrite <- app_comm_cons in H. apply consIterApp in H. inv H.
          apply IHes in H4. inv H4. rewrite app_assoc. constructor; auto.
          apply consIterApp. constructor; auto.
        - remember (a :: es) as es0. inversion H. rewrite Heqes0 in *. clear H1 H2 H0 re1 re2.
          apply consIterApp in H3. inv H3.
          rewrite <- app_comm_cons. rewrite consIterApp. rewrite <- app_assoc.
          constructor; auto. apply IHes. constructor; auto.
      }
    Qed.

    Lemma foo : forall es z e',
        exp_match z (IterApp (es ++ [e']))
        <-> exp_match z (App (IterApp es) e').
    Proof. intros. apply bar. Qed.

    Lemma invertIterUnion : forall e z,
        exp_match z (IterUnion (mkIterUnion' e)) <-> exp_match z e.
    Proof.
      induction e; try(sis; reflexivity).
      sis. dm; try(destruct e2; discriminate).
      rewrite <- E in *. clear E.
      split; intros.
      - inv H.
        + apply MUnionL. auto.
        + apply IHe2 in H1. apply MUnionR. auto.
      - inv H.
        + constructor; auto.
        + apply MUnionR. apply IHe2. auto.
    Qed.

    Lemma consIterUnion : forall es e z,
        exp_match z (IterUnion (e :: es))
        <-> exp_match z (Union e (IterUnion es)).
    Proof.
      intros; simpl; destruct es.
      - simpl. split; intros.
        + constructor. auto.
        + inv H; auto. inv H1.
      - split; auto.
    Qed.

    Lemma IterUnion_In_match : forall es z,
      exp_match z (IterUnion es)
      <-> (exists e, In e es /\ exp_match z e).
    Proof.
      induction es; intros.
      {
        split; intros.
        - simpl in H. inv H.
        - destruct H. destruct H. contradiction.
      }
      {
        split; intros.
        - apply consIterUnion in H. inv H.
          + exists a. split; auto. simpl. left. auto.
          + apply IHes in H1. destruct H1. destruct H. exists x. split.
            * simpl. right. auto.
            * auto.
        - apply consIterUnion. destruct H. destruct H. destruct (regex_eq a x) eqn:E.
          + apply regex_eq_correct in E. subst. constructor. auto.
          + destruct H.
            * apply false_not_true in E. destruct E. apply regex_eq_correct. auto.
            * apply MUnionR. apply IHes. eexists; eauto.
      }
    Qed.

    Lemma eq_set_eq_U : forall es es',
        (forall e, In e es <-> In e es')
        -> re_equiv (IterUnion es) (IterUnion es').
    Proof.
      unfold re_equiv. intros. split; intros.
      - rewrite IterUnion_In_match in *. destruct H0. destruct H0.
        apply H in H0. eexists; eauto.
      - rewrite IterUnion_In_match in *. destruct H0. destruct H0.
        apply H in H0. eexists; eauto.
    Qed.

    Lemma remove_head : forall es es' z a,
      exp_match z (IterUnion (merge (a :: es) es'))
      <-> exp_match z (IterUnion (a :: (merge es es'))).
    Proof.
      intros. assert(L := eq_set_eq_U). unfold re_equiv in *. apply L. clear L.
      intros. split; intros.
      - sis. rewrite merge_In in *. sis. rewrite <- or_assoc. auto.
      - sis. rewrite merge_In in *. sis. rewrite or_assoc. auto.
    Qed.

    Lemma barU : forall es es' z,
        exp_match z (IterUnion (merge es es'))
        <-> exp_match z (IterUnion (es ++ es')).
    Proof.
      induction es; intros.
      {
        assert([] ++ es' = es').
        { auto. }
        split; intros.
        - rewrite H in *; destruct es'; auto.
        - rewrite H in *; destruct es'; auto.
      }
      {
        split; intros.
        - rewrite <- app_comm_cons. rewrite consIterUnion. apply remove_head in H.
          rewrite consIterUnion in H. inv H.
          + constructor; auto.
          + apply MUnionR. apply IHes. auto.
        - rewrite <- app_comm_cons in *. rewrite consIterUnion in *. apply remove_head.
          rewrite consIterUnion. inv H.
          + constructor. auto.
          + apply MUnionR. apply IHes. auto.
      }
    Qed.

    Lemma barU' : forall es es' z,
        exp_match z (IterUnion (es ++ es'))
        <-> exp_match z (Union (IterUnion es) (IterUnion es')).
    Proof.
      induction es; intros.
      {
        split; intros; sis.
        - apply MUnionR. auto.
        - inv H; auto. inv H2.
      }
      {
        split; intros.
        - rewrite <- app_comm_cons in H. apply consIterUnion in H. inv H.
          + apply MUnionL. apply consIterUnion. apply MUnionL. auto.
          + apply IHes in H1. inv H1.
            * apply MUnionL. apply consIterUnion. apply MUnionR. auto.
            * apply MUnionR. auto.
        - rewrite <- app_comm_cons. apply consIterUnion. remember (a :: es) as es0.
          inv H.
          + apply consIterUnion in H2. inv H2.
            * apply MUnionL. auto.
            * apply MUnionR. apply IHes. apply MUnionL. auto.
          + apply MUnionR. apply IHes. apply MUnionR. auto.
      }
    Qed.

    Lemma fooU : forall es z e',
        exp_match z (IterUnion (es ++ [e']))
        <-> exp_match z (Union (IterUnion es) e').
    Proof. intros. apply barU'. Qed.

    Lemma canon_App_F : forall z e1 e2,
        exp_match z (canon (App e1 e2))
        -> (forall z : String, exp_match z (canon e1) <-> exp_match z e1)
        -> (forall z : String, exp_match z (canon e2) <-> exp_match z e2)
        -> exp_match z (App e1 e2).
    Proof.
      intros z e1 e2 H IHe1 IHe2.
      simpl in H.
        repeat dm; try(inv H; reflexivity);
          assert(z = [] ++ z); assert(z = z ++ []);
            try(auto; reflexivity); try(rewrite app_nil_r; auto);
              try(rewrite H0; constructor; [apply IHe1; constructor|];
                  apply IHe2; auto; reflexivity);
              try(rewrite H1; constructor; [apply IHe1; auto|];
                  apply IHe2; constructor; reflexivity); clear H0 H1;
                try(inv H; constructor; [apply IHe1; auto|]; apply IHe2; auto; reflexivity);
                try(destruct r2; discriminate);
                try(destruct r4; discriminate);
                try(destruct r0_2; discriminate);
                try(rewrite <- E1 in H; inv H; rewrite foo in H4; inv H4;
                    rewrite invertIterApp in H0; rewrite app_assoc; constructor;
                    [apply IHe1; constructor; auto | apply IHe2; auto]).
        + rewrite <- E1 in H. inv H. constructor; [apply IHe1; auto|].
          inv H4. apply IHe2. constructor; auto. rewrite invertIterApp in H5. auto.
        + rewrite <- E1 in H. inv H. rewrite bar in H4. inv H4. dm.
          * rewrite invertIterApp in H0. rewrite app_assoc. constructor.
            -- apply IHe1. constructor; auto.
            -- destruct r4; try(discriminate).
          * rewrite <- E2 in H5. inv H5. rewrite invertIterApp in *. rewrite app_assoc.
            constructor; [apply IHe1|apply IHe2]; constructor; auto.
        + rewrite <- E1 in H. inv H. inv H4. rewrite invertIterApp in *.
          constructor; [apply IHe1; auto|]. apply IHe2. constructor; auto.
        + rewrite <- E1 in H. inv H. inv H4. rewrite invertIterApp in *.
          constructor; [apply IHe1; auto|]. apply IHe2. constructor; auto.
    Qed.

    Lemma eq_Star : forall e1 e2,
        re_equiv e1 e2
        -> re_equiv (Star e1) (Star e2).
    Proof.
      intros. unfold re_equiv in *. intros. split; intros.
      - apply star_concat in H0. destruct H0 as (xss & H1 & H0).
        rewrite H1. clear H1. apply concat_star. intros.
        apply H. apply H0. auto.
      - apply star_concat in H0. destruct H0 as (xss & H1 & H0).
        rewrite H1. clear H1. apply concat_star. intros.
        apply H. apply H0. auto.
    Qed.

    Lemma canon_Star : forall z e,
        (forall z : String, exp_match z (canon e) <-> exp_match z e)
        -> (exp_match z (canon (Star e))
        <-> exp_match z (Star (canon e))).
    Proof.
      intros. split; intros; sis.
      - dm.
        + inv H0. constructor.
        + inv H0. constructor.
        + assert (L := eq_Star (App r1 r2) (canon (App r1 r2))).
          unfold re_equiv in *. symmetry in H. eapply L in H. apply H. auto.
        + assert (L := eq_Star (Union r1 r2) (canon (Union r1 r2))).
          unfold re_equiv in *. symmetry in H. eapply L in H. apply H. auto.
        + assert (L := eq_Star (Star r) (canon (Star r))).
          unfold re_equiv in *. symmetry in H. eapply L in H. apply H. auto.
      - dm.
        + sis. inv H0; try constructor. inv H2.
        + apply star_concat in H0. destruct H0 as (xss & H1 & H0).
          assert(forall xs, In xs xss -> xs = []).
          { intros. apply H0 in H2. rewrite H in H2. inv H2. auto. }
          assert(z = []).
          { clear H H0. induction xss.
            - sis. auto.
            - sis.
              assert (a = []).
              { apply H2. auto. }
              subst. sis. apply IHxss; auto.
          }
          rewrite H3. constructor.
        + assert (L := eq_Star (App r1 r2) (canon (App r1 r2))). unfold re_equiv in *.
          symmetry in H. eapply L in H. apply H. auto.
        + assert (L := eq_Star (Union r1 r2) (canon (Union r1 r2))). unfold re_equiv in *.
          symmetry in H. eapply L in H. apply H. auto.
        + assert (L := eq_Star (Star r) (canon (Star r))). unfold re_equiv in *.
          symmetry in H. eapply L in H. apply H. auto.
    Qed.

    Lemma canon_equiv : forall e,
        re_equiv (canon e) e.
    Proof.
      induction e; unfold re_equiv in *; split; intros; try(sis; auto; discriminate).
      - apply canon_App_F; auto.
      - simpl.
        repeat dm; try(inv H; reflexivity);
          assert(z = [] ++ z); assert(z = z ++ []);
            try(auto; reflexivity); try(rewrite app_nil_r; auto);
              try(rewrite H0 in H; inv H; rewrite <- IHe1 in *; inv H5; reflexivity);
              try(rewrite H1 in H; inv H; rewrite <- IHe2 in *; inv H6; reflexivity);
              try(inv H; rewrite <- IHe1 in *; rewrite <- IHe2 in *;
                  constructor; auto; reflexivity);
              try(inv H; rewrite <- IHe1 in *; rewrite <- IHe2 in *;
                  inv H5; inv H6; simpl; constructor; auto; reflexivity);
              try(destruct r2; discriminate);
              try(rewrite <- E1; inv H; rewrite <- IHe1 in *; rewrite <- IHe2 in *;
                  inv H5; inv H6; repeat constructor; auto; rewrite invertIterApp; auto);
              try(inv H; rewrite <- IHe1 in *; rewrite <- IHe2 in *;
                  inv H5; inv H6; repeat rewrite app_nil_r; repeat constructor; auto; reflexivity);
              try(rewrite <- E1; inv H; rewrite <- IHe1 in *; rewrite <- IHe2 in *;
                  inv H5; rewrite <- app_assoc; constructor; auto;
                  rewrite bar; constructor; [rewrite invertIterApp|]; auto);
              try(destruct r4; discriminate);
              try(destruct r0_2; discriminate).
        + simpl. dm; try(destruct r4; discriminate).
          inv H6. constructor; auto. rewrite <-  E2. apply invertIterApp. auto.

      - simpl in H.
        repeat dm; repeat dm; try(inv H; reflexivity);
          try(apply MUnionR; rewrite <- IHe2; auto; reflexivity);
          try(apply MUnionL; rewrite <- IHe1; auto; reflexivity);
          try(inv H; [apply MUnionL; rewrite <- IHe1; auto
                     |apply MUnionR; rewrite <- IHe2; auto]; reflexivity);
          try(inv H; [apply MUnionR; rewrite <- IHe2; auto
                     |apply MUnionL; rewrite <- IHe1; auto]; reflexivity);
          try(rewrite barU in H; simpl in H; dm; try(destruct r2; discriminate);
              rewrite <- E1 in H; inv H; [apply MUnionL; rewrite <- IHe1; auto|];
              apply MUnionR; rewrite <- IHe2; inv H1; [apply MUnionL; auto|];
              apply MUnionR; rewrite invertIterUnion in *; auto);
          try(rewrite barU in H; simpl in H; inv H;
              [apply MUnionL; rewrite <- IHe1; auto
              |apply MUnionR; rewrite <- IHe2; auto]; reflexivity).
        + rewrite barU in H; simpl in H; inv H;
              [apply MUnionL; rewrite <- IHe1; auto
              |apply MUnionR; rewrite <- IHe2; auto].
          dm; try(destruct r4; discriminate).
          rewrite <- E1 in *. inv H1; [apply MUnionL; auto|rewrite invertIterUnion in H0].
          apply MUnionR; auto.
        + rewrite barU in H. rewrite fooU in H. inv H;
              [apply MUnionL; rewrite <- IHe1; auto
              |apply MUnionR; rewrite <- IHe2; auto].
          dm; [destruct r2; discriminate|]. rewrite <- E1 in H2.
          inv H2. apply MUnionL. auto.
          apply MUnionR. rewrite invertIterUnion in H1. auto.
        + rewrite barU in H. rewrite fooU in H. inv H;
              [apply MUnionL; rewrite <- IHe1; auto
              |apply MUnionR; rewrite <- IHe2; auto].
          dm; [destruct r2; discriminate|]. rewrite <- E1 in H2.
          inv H2. apply MUnionL. auto.
          apply MUnionR. rewrite invertIterUnion in H1. auto.
        + rewrite barU in H. rewrite fooU in H. inv H;
              [apply MUnionL; rewrite <- IHe1; auto
              |apply MUnionR; rewrite <- IHe2; auto].
          dm; [destruct r2; discriminate|]. rewrite <- E1 in H2.
          inv H2. apply MUnionL. auto.
          apply MUnionR. rewrite invertIterUnion in H1. auto.
        + rewrite barU in H. rewrite barU' in H.
          inv H; dm; try(destruct r2; destruct r4; discriminate).
          * apply MUnionL. rewrite <- IHe1. rewrite <- E1 in H2. inv H2.
            apply MUnionL; auto. rewrite invertIterUnion in *. apply MUnionR. auto.
          * apply MUnionR. rewrite <- IHe2. rewrite <- E1 in H1. inv H1.
            apply MUnionL; auto. rewrite invertIterUnion in *. apply MUnionR. auto.
        + rewrite barU in H. rewrite barU' in H.
          inv H; [dm|]; try(destruct r2; discriminate).
          * apply MUnionL. rewrite <- IHe1. rewrite <- E1 in H2. inv H2.
            apply MUnionL. auto. apply MUnionR. rewrite invertIterUnion in *. auto.
          * apply MUnionR. rewrite <- IHe2. auto.
        + rewrite barU in H. rewrite barU' in H. inv H.
          * rewrite IHe1 in *. apply MUnionL. auto.
          * dm; try(destruct r0_2; discriminate). rewrite <- E1 in *.
            apply MUnionR. apply IHe2. inv H1.
            -- apply MUnionL. auto.
            -- apply MUnionR. rewrite invertIterUnion in *. auto.
      - simpl.
        repeat dm; try(inv H; reflexivity);
          try(rewrite barU; simpl);
          try(inv H; [rewrite <- IHe1 in *; inv H2 | rewrite <- IHe2 in *; auto]; reflexivity);
          try(inv H; [rewrite <- IHe1 in *; auto | rewrite <- IHe2 in *; inv H1]; reflexivity);
          try(inv H; [rewrite <- IHe1 in *; auto | rewrite <- IHe2 in *; auto]; reflexivity);
          try(inv H; [rewrite <- IHe1 in *; apply MUnionL; auto
                     | rewrite <- IHe2 in *; apply MUnionR; auto]; reflexivity);
          try(inv H; [rewrite <- IHe1 in *; apply MUnionR; auto
                     | rewrite <- IHe2 in *; apply MUnionL; auto]; reflexivity);
          dm; try(destruct r4; discriminate); try(destruct r2; discriminate);
            try(destruct r0_2; discriminate); try(rewrite <- E1; clear E1);
              try(inv H; [rewrite <- IHe1 in * | rewrite <- IHe2 in *]);
              try(apply MUnionL; auto; reflexivity);
              try(inv H1);
              try(apply MUnionL; auto; reflexivity);
              try(apply MUnionR; apply MUnionL; auto; reflexivity);
              try(apply MUnionR; apply MUnionR; rewrite invertIterUnion; auto; reflexivity);
              try(inv H2; [apply MUnionL; auto; reflexivity|];
                  apply MUnionR; apply barU'; apply MUnionL; apply invertIterUnion; auto);
              try(apply MUnionR; apply barU'; apply MUnionR; simpl; constructor); auto.
        + apply MUnionR. apply barU'. apply MUnionR. simpl.
          dm; try(discriminate). apply MUnionL. auto.
        + apply MUnionR. apply barU'. apply MUnionR. simpl.
          dm; try(destruct r4; discriminate). apply MUnionR. rewrite <- E1.
          apply invertIterUnion. auto.
      - rewrite canon_Star in H; auto. apply star_concat in H.
        destruct H as (xss & H). destruct H.
        rewrite H in *. apply concat_star. intros. apply IHe. apply H0. auto.
      - apply canon_Star; auto. apply star_concat in H. destruct H as (xss & H). destruct H.
        rewrite H in *. apply concat_star. intros. apply IHe. apply H0. auto.
    Qed.

    Fixpoint fill_Table_all'' (T : Table) (e : regex) (bs : list Sigma) (fuel : nat) : Table :=
      match fuel with
      | 0 => T
      | S n =>
        let
          (* We need a helper function to apply fill_Table_all to each derivative of e *)
          fix fill_Table_ds (bs : list Sigma) (bs' : list Sigma) :=
          match bs' with
          | [] => T
          | c :: cs =>
            let
              (* fill the table with respect to the tail *)
              T1 := fill_Table_ds bs cs in
            let
              (* now we'll do it with respect to c *)
              d := canon (derivative c e) in
            match get_eq T d with
            | None =>
              let
                (* we didn't find a similar regex, we need to add d *)
                T2 := add_state T1 d in
              let
                (* we also need to transition from regex e to regex d on symbol c *)
                T3 := set_Table T2 e c d in
              (* finally we need to fill up the table with respect to d *)
              fill_Table_all'' T3 d bs n
            | Some e' =>
              (* In this case, we found a regex that has already been added to the table *)
              (* Anytime we add a regex, we immediately call fill_Table_all for it *)
              (* Therefore, we don't need to call fill_Table_all again *)
              (* Instead, we transition from e to e' when we see c *)
              set_Table T1 e c e'
            end
          end
        in
        fill_Table_ds bs bs
      end.

    Fixpoint fill_Table_all' (T : Table) (e : regex) (bs : list Sigma) (fuel : nat) : Table :=
      match fuel with
      | 0 => T
      | S n =>
        let
          (* We need a helper function to apply fill_Table_all to each derivative of e *)
          fix fill_Table_ds (bs' : list Sigma) :=
          match bs' with
          | [] => T
          | c :: cs =>
            let
              (* fill the table with respect to the tail *)
              T1 := fill_Table_ds cs in
            let
              (* now we'll do it with respect to c *)
              d := canon (derivative c e) in
            match get_eq T d with
            | None =>
              let
                (* we didn't find a similar regex, we need to add d *)
                T2 := add_state T1 d in
              let
                (* we also need to transition from regex e to regex d on symbol c *)
                T3 := set_Table T2 e c d in
              (* finally we need to fill up the table with respect to d *)
              fill_Table_all' T3 d bs n
            | Some e' =>
              (* In this case, we found a regex that has already been added to the table *)
              (* Anytime we add a regex, we immediately call fill_Table_all for it *)
              (* Therefore, we don't need to call fill_Table_all again *)
              (* Instead, we transition from e to e' when we see c *)
              set_Table T1 e c e'
            end
          end
        in
        fill_Table_ds bs
      end.

    Definition fill_Table_all (T : Table) (e : regex) (bs : list Sigma) (fuel : nat) : Table :=
      fill_Table_all' T (canon e) bs fuel.

    Lemma acc_rec_call' : forall fuel,
        Acc (ltof positive Pos.to_nat) fuel
        -> fuel <> xH
        -> Acc (ltof positive Pos.to_nat) (Pos.pred fuel).
    Proof.
      intros. apply Acc_inv with (x := fuel); auto.
      assert((1 < fuel)%positive).
      { clear H. destruct fuel; try constructor; try contradiction. }
      clear H0 H. apply Pos2Nat.inj_lt.
      apply Pos2Nat.inj_pred in H1. apply Pos2Nat.inj_lt. rewrite H1.
      apply Nat.lt_pred_l. pose proof Pos2Nat.is_pos fuel. omega.
    Defined.

    Lemma acc_rec_call_xI : forall fuel p,
        Acc (ltof positive Pos.to_nat) fuel
        -> fuel = (p~1)%positive
        -> Acc (ltof positive Pos.to_nat) (Pos.pred fuel).
    Proof.
      intros. apply acc_rec_call'; auto. intros C. rewrite C in H0. discriminate.
    Defined.

    Lemma acc_rec_call_xO : forall fuel p,
        Acc (ltof positive Pos.to_nat) fuel
        -> fuel = (p~0)%positive
        -> Acc (ltof positive Pos.to_nat) (Pos.pred fuel).
    Proof.
      intros. apply acc_rec_call'; auto. intros C. rewrite C in H0. discriminate.
    Defined.

    Lemma acc_rec_call_xH : forall fuel,
        Acc (ltof positive Pos.to_nat) fuel
        -> fuel = xH
        -> Acc (ltof positive Pos.to_nat) (Pos.pred fuel).
    Proof.
      intros. rewrite H0 in *. sis. auto.
    Defined.

    Lemma Poslt_wf : forall p, Acc (ltof positive Pos.to_nat) p.
    Proof.
      pose proof well_founded_ltof positive Pos.to_nat. unfold well_founded in H. auto.
    Qed.

    Fixpoint traverse_pos' (fuel : positive)
             (Ha : Acc (ltof positive Pos.to_nat) fuel)
             {struct Ha} : positive :=
      match fuel as fuel'
            return fuel = fuel' -> _
      with
      | xH => fun Heq => xH
      | xI p => fun Heq => traverse_pos' (Pos.pred fuel) (acc_rec_call_xI fuel p Ha Heq)
      | xO p => fun Heq => traverse_pos' (Pos.pred fuel) (acc_rec_call_xO fuel p Ha Heq)
      end eq_refl.

    Definition traverse_pos (fuel : positive) : positive :=
      traverse_pos' fuel (Poslt_wf _).

    Fixpoint fill_Table_all'_bin (T : Table) (e : regex) (bs : list Sigma) (fuel : positive)
             (Ha : Acc (ltof positive Pos.to_nat) fuel) {struct Ha} : Table :=
      match fuel as fuel'
            return fuel = fuel' -> _
      with
      | xH => fun _ => T
      | xI p =>
        fun Heq =>
          let
            (* We need a helper function to apply fill_Table_all to each derivative of e *)
            fix fill_Table_ds_bin (bs' : list Sigma) :=
            match bs' with
            | [] => T
            | c :: cs =>
              let
                (* fill the table with respect to the tail *)
                T1 := fill_Table_ds_bin cs in
              let
                (* now we'll do it with respect to c *)
                d := canon (derivative c e) in
              match get_eq T d with
              | None =>
                let
                  (* we didn't find a similar regex, we need to add d *)
                  T2 := add_state T1 d in
                let
                  (* we also need to transition from regex e to regex d on symbol c *)
                  T3 := set_Table T2 e c d in
                (* finally we need to fill up the table with respect to d *)
                fill_Table_all'_bin T3 d bs (Pos.pred fuel) (acc_rec_call_xI fuel p Ha Heq)
              | Some e' =>
                (* In this case, we found a regex that has already been added to the table *)
                (* Anytime we add a regex, we immediately call fill_Table_all for it *)
                (* Therefore, we don't need to call fill_Table_all again *)
                (* Instead, we transition from e to e' when we see c *)
                set_Table T1 e c e'
              end
            end
          in
          fill_Table_ds_bin bs
      | xO p =>
        fun Heq =>
          let
            (* We need a helper function to apply fill_Table_all to each derivative of e *)
            fix fill_Table_ds_bin (bs' : list Sigma) :=
            match bs' with
            | [] => T
            | c :: cs =>
              let
                (* fill the table with respect to the tail *)
                T1 := fill_Table_ds_bin cs in
              let
                (* now we'll do it with respect to c *)
                d := canon (derivative c e) in
              match get_eq T d with
              | None =>
                let
                  (* we didn't find a similar regex, we need to add d *)
                  T2 := add_state T1 d in
                let
                  (* we also need to transition from regex e to regex d on symbol c *)
                  T3 := set_Table T2 e c d in
                (* finally we need to fill up the table with respect to d *)
                fill_Table_all'_bin T3 d bs (Pos.pred fuel) (acc_rec_call_xO fuel p Ha Heq)
              | Some e' =>
                (* In this case, we found a regex that has already been added to the table *)
                (* Anytime we add a regex, we immediately call fill_Table_all for it *)
                (* Therefore, we don't need to call fill_Table_all again *)
                (* Instead, we transition from e to e' when we see c *)
                set_Table T1 e c e'
              end
            end
          in
          fill_Table_ds_bin bs
      end eq_refl.

    Definition fill_Table_all_bin (T : Table) (e : regex) (bs : list Sigma)
               (fuel : positive) : Table :=
      fill_Table_all'_bin T (canon e) bs fuel (Poslt_wf _).

  End FillTable.

  Module Export Spec.

    Definition derived (T : Table) : Prop :=
      forall e a r, get_Table T e a = Some r -> re_equiv r (derivative a e).

  End Spec.

  Module Export Correct.

    Theorem emptyTable_derived : derived emptyTable.
    Proof.
      unfold derived. intros. rewrite correct_emptyTable in H. discriminate.
    Qed.

    Lemma unfold_filler' : forall bs T e n,
        fill_Table_all' T e bs (S n)
        =
        let
          fix fill_Table_ds (bs' : list Sigma) : Table :=
          match bs' with
          | [] => T
          | c :: cs =>
            let T1 := fill_Table_ds cs in
            let d := canon (derivative c e) in
            match get_eq T d with
            | Some e' => set_Table T1 e c e'
            | None =>
              let T2 := add_state T1 d in
              let T3 := set_Table T2 e c d in fill_Table_all' T3 d bs n
            end
          end in
        fill_Table_ds bs.
    Proof.
      auto.
    Qed.

    Lemma unfold_filler_ds : forall T T' e x xs n,
        let
          fix fill_Table_ds (bs' : list Sigma) : Table :=
          match bs' with
          | [] => T
          | c :: cs =>
            let T1 := fill_Table_ds cs in
            let d := canon (derivative c e) in
            match get_eq T d with
            | Some e' => set_Table T1 e c e'
            | None =>
              let T2 := add_state T1 d in
              let T3 := set_Table T2 e c d in fill_Table_all' T3 d (x :: xs) n
            end
          end in
        T' = fill_Table_ds (x :: xs)
        ->
        (exists e' T0, get_eq T (canon (derivative x e)) = Some e'
                  /\ T0 = (fill_Table_ds xs)
                  /\ T' = set_Table T0 e x e')
        \/
        (exists T0, get_eq T (canon (derivative x e)) = None
               /\
               T0 = (fill_Table_ds xs)
               /\
               T' = fill_Table_all'
                      (set_Table (add_state T0 (canon (derivative x e))) e x
                                 (canon (derivative x e)))
                      (canon (derivative x e)) (x :: xs) n).
    Proof.
      intros. simpl in *. destruct (get_eq T (canon (derivative x e))) eqn:E.
      - left. eexists; eauto.
      - right. eexists; eauto.
    Qed.

    Theorem derived_closure_set : forall T b e r,
        derived T
        -> re_equiv r (derivative b e)
        -> derived (set_Table T e b r).
    Proof.
      intros.
      unfold derived. intros.
      destruct (regex_eq e e0) eqn:E; destruct (Sigma_dec a b).
      - apply regex_eq_correct in E. subst.
        rewrite correct_Table in H1. injection H1; intros; subst.
        auto.
      - rewrite moot_setTable in H1; auto.
      - rewrite moot_setTable in H1; auto.
        assert(regex_eq e e0 <> true).
        { intros C. rewrite C in *. discriminate. }
        right. intros C. destruct H2. apply regex_eq_correct. auto.
      - rewrite moot_setTable in H1; auto.
    Qed.

    Theorem derived_closure_add : forall T T' e,
        derived T
        -> T' = add_state T e
        -> derived T'.
    Proof.
      unfold derived in *. intros.
      rewrite H0 in H1. rewrite <- moot_add_state with (r:=e) in H1.
      apply H in H1. auto.
    Qed.

    Lemma derived_closure_ds' : forall bs T T' e n xs,
        (forall (cs : list Sigma) (e : regex) (T T' : Table),
            derived T -> T' = fill_Table_all' T e cs n -> derived T')
        -> derived T
        ->
        let
          fix fill_Table_ds (bs' : list Sigma) : Table :=
          match bs' with
          | [] => T
          | c :: cs =>
            let T1 := fill_Table_ds cs in
            let d := canon (derivative c e) in
            match get_eq T d with
            | Some e' => set_Table T1 e c e'
            | None =>
              let T2 := add_state T1 d in
              let T3 := set_Table T2 e c d in fill_Table_all' T3 d xs n
            end
          end in
        T' = fill_Table_ds bs
        -> derived T'.
    Proof.
      intros.
      generalize dependent T.
      generalize dependent T'.
      generalize dependent e.
      generalize dependent xs.
      induction bs as [|b bs]; intros.
      - subst; auto.
      - simpl in H1. repeat dm.
        + assert(derived (fill_Table_ds bs)).
          {
            apply IHbs with (T:=T) (e:=e) (xs:=xs); auto.
          }
          apply get_eq_correct in E. destruct E.
          rewrite H1.
          apply derived_closure_set; auto.
          rewrite <- regex_eq_correct in H4. rewrite <- H4.
          apply canon_equiv.
        + assert(derived (fill_Table_ds bs)).
          {
            apply IHbs with (T:=T) (e:=e) (xs:=xs); auto.
          }
          assert(derived (add_state (fill_Table_ds bs) (canon (derivative b e)))).
          {
            eapply derived_closure_add; eauto.
          }
          clear H2.
          assert(derived (set_Table
                            (add_state (fill_Table_ds bs) (canon (derivative b e)))
                            e b (canon (derivative b e)))).
          {
            eapply derived_closure_set; eauto.
            apply canon_equiv.
          }
          eapply H; eauto.
    Qed.

    Lemma derived_closure_ds : forall bs T e n xs,
        (forall (cs : list Sigma) (e : regex) (T T' : Table),
            derived T -> T' = fill_Table_all' T e cs n -> derived T')
        -> derived T
        ->
        let
          fix fill_Table_ds (bs' : list Sigma) : Table :=
          match bs' with
          | [] => T
          | c :: cs =>
            let T1 := fill_Table_ds cs in
            let d := canon (derivative c e) in
            match get_eq T d with
            | Some e' => set_Table T1 e c e'
            | None =>
              let T2 := add_state T1 d in
              let T3 := set_Table T2 e c d in fill_Table_all' T3 d xs n
            end
          end in
        derived (fill_Table_ds bs).
    Proof.
      intros. apply derived_closure_ds' with (bs:=bs) (T:=T) (e:=e) (n:=n) (xs:=xs); auto.
    Qed.

    Theorem derived_closure_all' : forall n bs e T T',
        derived T
        -> T' = fill_Table_all' T e bs n
        -> derived T'.
    Proof.
      induction n; intros; try(simpl in H0; subst; auto; reflexivity).
      destruct bs as [|b bs].
      - simpl in H0. subst. auto.
      - rewrite unfold_filler' in H0. apply unfold_filler_ds in H0. destruct H0.
        + destruct H0 as (e' & T0 & H0 & H1 & H2).
          assert(derived T0).
          {
            apply derived_closure_ds with (bs:=bs) (xs:= (b :: bs)) (e:=e) (n:=n) in H.
            subst. auto. apply IHn.
          }
          clear H1.
          subst. eapply derived_closure_set; eauto.
          apply get_eq_correct in H0. destruct H0.
          apply regex_eq_correct in H1. rewrite <- H1.
          apply canon_equiv.
        + destruct H0 as (T0 & H0 & H1 & H2).
          assert(derived T0).
          {
            apply derived_closure_ds with (bs:=bs) (xs:= (b :: bs)) (e:=e) (n:=n) in H.
            subst. auto. apply IHn.
          }
          clear H1.
          assert(derived (add_state T0 (canon (derivative b e)))).
          {
            eapply derived_closure_add; eauto.
          }
          assert(derived (set_Table (add_state T0 (canon (derivative b e)))
                                    e b (canon (derivative b e)))).
          {
            eapply derived_closure_set; eauto.
            apply canon_equiv.
          }
          eapply IHn; eauto.
    Qed.

    Theorem derived_closure_all : forall n bs e T T',
        derived T
        -> T' = fill_Table_all T e bs n
        -> derived T'.
    Proof.
      intros. unfold fill_Table_all in *. eapply derived_closure_all'; eauto.
    Qed.

    Theorem derived_get_some : forall T e a e',
        derived T
        -> get_Table T e a = Some e'
        -> re_equiv e' (derivative a e).
    Proof.
      intros. unfold derived in *. apply H in H0. auto.
    Qed.

  End Correct.

  Module Export binary.

    Lemma filler_eq_body : forall T e bs fuel Ha,
      fill_Table_all'_bin T e bs fuel Ha
      = match fuel as fuel' return (fuel = fuel' -> Table) with
        | (p~1)%positive =>
          fun Heq : fuel = (p~1)%positive =>
            let
              fix fill_Table_ds (bs' : list Sigma) : Table :=
              match bs' with
              | [] => T
              | c :: cs =>
                let T1 := fill_Table_ds cs in
                let d := canon (derivative c e) in
                match get_eq T d with
                | Some e' => set_Table T1 e c e'
                | None =>
                  let T2 := add_state T1 d in
                  let T3 := set_Table T2 e c d in
                  fill_Table_all'_bin T3 d bs (Pos.pred fuel) (acc_rec_call_xI fuel p Ha Heq)
                end
              end in
            fill_Table_ds bs
        | (p~0)%positive =>
          fun Heq : fuel = (p~0)%positive =>
            let
              fix fill_Table_ds (bs' : list Sigma) : Table :=
              match bs' with
              | [] => T
              | c :: cs =>
                let T1 := fill_Table_ds cs in
                let d := canon (derivative c e) in
                match get_eq T d with
                | Some e' => set_Table T1 e c e'
                | None =>
                  let T2 := add_state T1 d in
                  let T3 := set_Table T2 e c d in
                  fill_Table_all'_bin T3 d bs (Pos.pred fuel) (acc_rec_call_xO fuel p Ha Heq)
                end
              end in
            fill_Table_ds bs
        | 1%positive => fun _ : fuel = 1%positive => T
        end eq_refl.
    Proof.
      intros. unfold fill_Table_all'_bin. destruct Ha. auto.
    Qed.

    Theorem fill_bin'_equiv' : forall (x : positive) (Ha_x : Acc (ltof positive (Pos.to_nat)) x)
                                 (p : positive) (Ha : Acc (ltof positive (Pos.to_nat)) p)
                                 (bs : list Sigma) (T : Table) (e : regex),
        x = p
        -> fill_Table_all'_bin T e bs p Ha = fill_Table_all' T e bs (pred (Pos.to_nat p)).
    Proof.
      intros x Ha_x. induction Ha_x. intros. subst. destruct p eqn:E.
      - destruct (Init.Nat.pred (Pos.to_nat p0~1)) eqn:E1.
        {
          rewrite <- Pos2Nat.inj_pred in E1. 2:{ constructor. }
          pose proof Pos2Nat.is_pos (Pos.pred p0~1). rewrite E1 in H1. omega.
        }
        rewrite unfold_filler'.
        rewrite filler_eq_body. simpl.
        (* Sorry to anyone about to read this massive assert
           -- we just need the inner bs to be more general than the outer bs,
         so we replace it with orig :) *)
        assert(
            exists orig,
              (fix fill_Table_ds (bs' : list Sigma) : Table :=
                 match bs' with
                 | [] => T
                 | c :: cs =>
                   match get_eq T (canon (derivative c e)) with
                   | Some e' => set_Table (fill_Table_ds cs) e c e'
                   | None =>
                     fill_Table_all'_bin
                       (set_Table (add_state (fill_Table_ds cs) (canon (derivative c e))) e c
                                  (canon (derivative c e))) (canon (derivative c e)) bs p0~0
                       (acc_rec_call_xI p0~1 p0 Ha eq_refl)
                   end
                 end)
              =  (fix fill_Table_ds (bs' : list Sigma) : Table :=
                    match bs' with
                    | [] => T
                    | c :: cs =>
                      match get_eq T (canon (derivative c e)) with
                      | Some e' => set_Table (fill_Table_ds cs) e c e'
                      | None =>
                        fill_Table_all'_bin
                          (set_Table (add_state (fill_Table_ds cs) (canon (derivative c e))) e c
                                     (canon (derivative c e))) (canon (derivative c e)) orig p0~0
                          (acc_rec_call_xI p0~1 p0 Ha eq_refl)
                      end
                    end)
              /\ (fix fill_Table_ds (bs' : list Sigma) : Table :=
                     match bs' with
                     | [] => T
                     | c :: cs =>
                       match get_eq T (canon (derivative c e)) with
                       | Some e' => set_Table (fill_Table_ds cs) e c e'
                       | None =>
                         fill_Table_all'
                           (set_Table (add_state (fill_Table_ds cs) (canon (derivative c e))) e c
                                      (canon (derivative c e))) (canon (derivative c e)) bs n
                       end
                     end)
                = (fix fill_Table_ds (bs' : list Sigma) : Table :=
                       match bs' with
                       | [] => T
                       | c :: cs =>
                         match get_eq T (canon (derivative c e)) with
                         | Some e' => set_Table (fill_Table_ds cs) e c e'
                         | None =>
                           fill_Table_all'
                             (set_Table (add_state (fill_Table_ds cs) (canon (derivative c e))) e c
                                        (canon (derivative c e))) (canon (derivative c e)) orig n
                         end
                       end)).
        { eauto. }
        destruct H1 as (orig & H1 & H2).
        rewrite H1. rewrite H2. clear H1 H2.
        induction bs; auto.
        dm.
        + apply f_equal with (f := fun T =>  set_Table T e a r). apply IHbs.
        + rewrite IHbs. clear IHbs E0. rewrite H0 with (y := xO p0); auto. clear H0.
          2: { constructor. }
          assert(n = pred (Pos.to_nat p0~0)).
          {
            rewrite <- Pos2Nat.inj_pred in E1.
            2: { constructor. }
            simpl in E1. rewrite E1. omega.
          }
          rewrite H0. auto.
      - destruct (Init.Nat.pred (Pos.to_nat p0~0)) eqn:E1.
        {
          rewrite <- Pos2Nat.inj_pred in E1. 2:{ constructor. }
          pose proof Pos2Nat.is_pos (Pos.pred p0~0). rewrite E1 in H1. omega.
        }
        rewrite unfold_filler'.
        rewrite filler_eq_body. simpl.
        assert(
            exists orig,
              (fix fill_Table_ds (bs' : list Sigma) : Table :=
                 match bs' with
                 | [] => T
                 | c :: cs =>
                   match get_eq T (canon (derivative c e)) with
                   | Some e' => set_Table (fill_Table_ds cs) e c e'
                   | None =>
                     fill_Table_all'_bin
                       (set_Table (add_state (fill_Table_ds cs) (canon (derivative c e))) e c
                                  (canon (derivative c e))) (canon (derivative c e)) bs
                       (Pos.pred_double p0) (acc_rec_call_xO p0~0 p0 Ha eq_refl)
                   end
                 end)
              = (fix fill_Table_ds (bs' : list Sigma) : Table :=
                   match bs' with
                   | [] => T
                   | c :: cs =>
                     match get_eq T (canon (derivative c e)) with
                     | Some e' => set_Table (fill_Table_ds cs) e c e'
                     | None =>
                       fill_Table_all'_bin
                         (set_Table (add_state (fill_Table_ds cs) (canon (derivative c e))) e c
                                    (canon (derivative c e))) (canon (derivative c e)) orig
                         (Pos.pred_double p0) (acc_rec_call_xO p0~0 p0 Ha eq_refl)
                     end
                   end)
              /\ (fix fill_Table_ds (bs' : list Sigma) : Table :=
                   match bs' with
                   | [] => T
                   | c :: cs =>
                     match get_eq T (canon (derivative c e)) with
                     | Some e' => set_Table (fill_Table_ds cs) e c e'
                     | None =>
                       fill_Table_all'
                         (set_Table (add_state (fill_Table_ds cs) (canon (derivative c e))) e c
                                    (canon (derivative c e))) (canon (derivative c e)) bs n
                     end
                   end)
                = (fix fill_Table_ds (bs' : list Sigma) : Table :=
                     match bs' with
                     | [] => T
                     | c :: cs =>
                       match get_eq T (canon (derivative c e)) with
                       | Some e' => set_Table (fill_Table_ds cs) e c e'
                       | None =>
                         fill_Table_all'
                           (set_Table (add_state (fill_Table_ds cs) (canon (derivative c e))) e c
                                      (canon (derivative c e))) (canon (derivative c e)) orig n
                       end
                     end)).
        { eauto. }
        destruct H1 as (orig & H1 & H2).
        rewrite H1. rewrite H2. clear H1 H2.
        induction bs; auto.
        dm.
        + apply f_equal with (f := fun T =>  set_Table T e a r). apply IHbs.
        + rewrite IHbs. clear IHbs E0. rewrite H0 with (y := (Pos.pred_double p0)); auto. clear H0.
          2: {
            unfold ltof.
            assert(Pos.pred_double p0 = Pos.pred (xO p0)).
            { auto. }
            rewrite H1. rewrite Nat.succ_lt_mono. repeat rewrite <- Pos2Nat.inj_succ.
            rewrite Pos.succ_pred; auto. intros; discriminate.
          }
          assert(n = (Init.Nat.pred (Pos.to_nat (Pos.pred_double p0)))).
          {
            rewrite <- Pos2Nat.inj_pred in E1.
            2: { constructor. }
            simpl in E1. rewrite E1. omega.
          }
          rewrite H0. auto.
      - simpl. rewrite filler_eq_body. auto.
    Qed.

    Theorem fill_bin'_equiv : forall (p : positive) (Ha : Acc (ltof positive (Pos.to_nat)) p)
                                 (bs : list Sigma) (T : Table) (e : regex),
        fill_Table_all'_bin T e bs p Ha = fill_Table_all' T e bs (pred (Pos.to_nat p)).
    Proof.
      intros. eapply fill_bin'_equiv'; eauto.
    Qed.

    Theorem fill_bin_equiv : forall (p : positive) (bs : list Sigma) (T : Table) (e : regex),
        fill_Table_all_bin T e bs p = fill_Table_all T e bs (pred (Pos.to_nat p)).
    Proof.
      intros. unfold fill_Table_all. unfold fill_Table_all_bin. apply fill_bin'_equiv.
    Qed.

    Theorem derived_closure_all_bin : forall p bs e T T',
        derived T
        -> T' = fill_Table_all_bin T e bs p
        -> derived T'.
    Proof.
      intros. rewrite fill_bin_equiv in H0. eapply derived_closure_all; eauto.
    Qed.

  End binary.

End DefsFn.

Module Type DefsT (R : regex.T) (TabTy : TABLE R).
  Include DefsFn R TabTy.
End DefsT.

Module Type T.
  Declare Module R : regex.T.
  Declare Module TabTy : TABLE R.
  Declare Module Defs : DefsT R TabTy.
  Export R.
  Export R.Ty.
  Export R.Defs.
  Export TabTy.
  Export Defs.
End T.


Require Export Coq.Init.Datatypes.
Require Export Coq.Lists.List.
Require Export Arith.EqNat.
Require Export Program.Equality.
Require Export Coq.Logic.ProofIrrelevance.
Require Export tactics.

Module E.
  Require Coq.Sets.Ensembles.
  Include Ensembles.
End E.

Definition set := E.Ensemble.
Definition empty_set {A : Type} := E.Empty_set A.
Definition set_In {A : Type} (a : A) (s : set A) := E.In A s a.
Definition add {A : Type} (a : A) (s : set A) := E.Add A s a.
Definition union {A : Type} := E.Union A.
Definition union_introl {A : Type} := E.Union_introl A.
Definition union_intror {A : Type} := E.Union_intror A.
Definition subset {A : Type} := E.Included A.
Fixpoint set_from_list {A : Type} (l : list A) :=
  match l with
  | nil => empty_set
  | h :: l' => add h (set_from_list l')
  end.
Fixpoint index_of {A : Type} (f : A -> bool) (l : list A) : option nat :=
  match l with
  | nil => None
  | a :: l' => if f a then Some 0 else option_map S (index_of f l')
  end.
Fixpoint first_n {A : Type} (l : list A) (n : nat) :=
  match n, l with
  | S n', h :: l' => h :: (first_n l' n')
  | _, _ => nil
  end.
Fixpoint remove_last {A : Type} (l : list A) :=
  match l with
  | nil => nil
  | _ :: nil => nil
  | h :: l' => h :: (remove_last l')
  end.

Fixpoint last_error {A : Type} (l : list A) :=
  match l with
  | nil => None
  | h :: nil => Some h
  | _ :: l' => last_error l'
  end.

Fixpoint zip_with_ind_h {A : Type} (l : list A) (n : nat) :=
  match l with
  | nil => nil
  | h :: l' => (n, h) :: zip_with_ind_h l' (S n)
  end.
Definition zip_with_ind {A : Type} (l : list A) := zip_with_ind_h l 0.

Set Implicit Arguments.
Inductive Forallt (A : Type) (P : A -> Type) : list A -> Type :=
  Forallt_nil : Forallt P nil
| Forallt_cons : forall (x : A) (l : list A), P x -> Forallt P l -> Forallt P (x :: l).
Unset Implicit Arguments.

Notation "a 'U' b" := (union a b) (at level 65, right associativity).

Lemma not_iff : forall {A B}, A <-> B -> ~ A <-> ~ B.
Proof. split; intro; intro; firstorder. Qed.
Hint Resolve not_iff.

Lemma exists_some_iff_not_none : forall {A} (o : option A),
    (exists a, o = Some a) <-> o <> None.
Proof.
  split; intro.
  - destruct H. intro. congruence.
  - destruct o.
    + eexists. reflexivity.
    + destruct H. reflexivity.
Qed.
Hint Resolve exists_some_iff_not_none.

Lemma not_involutive : forall P : Prop,
    P -> ~ ~ P.
Proof.
  intros. intro. contradiction.
Qed.
Hint Resolve not_involutive.

Lemma not_exists_some_iff_none : forall {A} (o : option A),
    ~ (exists a, o = Some a) <-> o = None.
Proof.
  split; intro; [| apply not_involutive in H]; erewrite not_iff in H; [..|symmetry];
    try apply exists_some_iff_not_none; try assumption.
  destruct o; try reflexivity. destruct H. congruence.
Qed.
Hint Resolve not_exists_some_iff_none.

Theorem Forall_list_impl : forall (A : Type) (P Q : A -> Prop) (l : list A),
    Forall P l -> Forall (fun a => P a -> Q a) l -> Forall Q l.
Proof.
  intros A P Q l fp fimp. induction l. apply Forall_nil.
  inversion fp. inversion fimp.
  apply Forall_cons.
  - apply H5; trivial.
  - apply IHl; trivial.
Qed.
Hint Resolve Forall_list_impl.

Theorem Forall_map_swap : forall (A : Type) (P : A -> Prop) (f : A -> A) (l : list A),
    Forall P (map f l) <-> Forall (fun a => P (f a)) l.
Proof.
  intros A P f l.
  induction l.
  - simpl. split; intros; apply Forall_nil.
  - simpl. split; intros; inversion H; apply Forall_cons; trivial; apply IHl; trivial.
Qed.
Hint Resolve Forall_map_swap.

Theorem Forall_In : forall (A : Type) (P : A -> Prop) (l : list A) (a : A),
    Forall P l -> In a l -> P a.
Proof. induction l; intros; inversion H0; inversion H; subst; eauto. Qed.

Theorem Forall_repeat : forall (A : Type) (P : A -> Prop) (n : nat) (a : A),
    P a -> Forall P (repeat a n).
Proof.
  intros. induction n.
  - apply Forall_nil.
  - apply Forall_cons; assumption.
Qed.
Hint Resolve Forall_repeat.

Theorem find_pair_in_zip : forall (A B : Type) (f : A -> bool) (la : list A) (lb lb' : list B) p p',
    find (fun p => f (fst p)) (combine la lb) = Some p ->
    find (fun p => f (fst p)) (combine la lb') = Some p' ->
    In (snd p, snd p') (combine lb lb').
Proof.
  induction la.
  - intros. inversion H.
  - intros. destruct lb; destruct lb'.
    + inversion H.
    + inversion H.
    + inversion H0.
    + simpl in H. simpl in H0. destruct (f a).
      * inversion H. inversion H0. simpl. left. reflexivity.
      * simpl. right; eauto.
Qed.
Hint Resolve find_pair_in_zip.

Lemma extract_combine : forall {A B : Type} (f : A -> bool) (la : list A) (lb : list B),
    length la = length lb -> find (fun p => f (fst p)) (combine la lb) = None -> find f la = None.
Proof.
  induction la.
  - reflexivity.
  - intros. destruct lb.
    + inversion H.
    + simpl in H0. simpl. destruct (f a).
      * inversion H0.
      * apply IHla with lb; eauto.
Qed.
Hint Resolve extract_combine.

Theorem zip_In_l : forall {A B : Type} (la : list A) (lb : list B) a b,
    In (a, b) (combine la lb) -> In a la.
Proof.
  induction la; intros.
  - inversion H.
  - destruct lb.
    + inversion H.
    + simpl in H. simpl. destruct H.
      * inversion H. eauto.
      * right. apply IHla with lb b. eauto.
Qed.
Hint Resolve zip_In_l.

Theorem zip_In_r : forall {A B : Type} (la : list A) (lb : list B) a b,
    In (a, b) (combine la lb) -> In b lb.
Proof.
  intros A B la lb. generalize dependent la. induction lb; intros.
  - destruct la; inversion H.
  - destruct la.
    + inversion H.
    + simpl in H. simpl. destruct H.
      * inversion H. eauto.
      * right. apply IHlb with la a0. eauto.
Qed.
Hint Resolve zip_In_r.

Theorem get_nth : forall {A : Type} (l : list A) (m n : nat),
    length l = n -> m < n -> exists a, nth_error l m = Some a.
Proof.
  induction l; intros; simpl in H.
  - rewrite <- H in H0. inversion H0.
  - destruct n; inversion H.
    destruct m.
    + exists a. reflexivity.
    + simpl. apply IHl with n; trivial.
      apply Lt.lt_S_n. trivial.
Qed.
Hint Resolve get_nth.

Lemma union_comm : forall {A : Type} (s1 s2 : set A),
    s1 U s2 = s2 U s1.
Proof.
  intros. apply E.Extensionality_Ensembles.
  unfold E.Same_set. unfold E.Included.
  split; unfold union; intros; inversion H;
    solve [apply union_introl; trivial | apply union_intror; trivial].
Qed.
Hint Resolve union_comm.

Lemma union_addl : forall A (s1 s2 : set A) (a : A),
    add a s1 U s2 = add a (s1 U s2).
  intros. apply E.Extensionality_Ensembles.
  unfold E.Same_set. unfold E.Included. unfold union. unfold add.
  split; intros; inversion H; try (inversion H0);
    solve [apply union_intror; trivial
          | apply union_introl; solve [apply union_introl; trivial
                                      | apply union_intror; solve [trivial | reflexivity]]].
Qed.
Hint Resolve union_addl.

Lemma union_addr : forall A (s1 s2 : set A) (a : A),
    s1 U add a s2 = add a (s1 U s2).
  intros. apply E.Extensionality_Ensembles.
  unfold E.Same_set. unfold E.Included. unfold union. unfold add.
  split; intros; inversion H; try (inversion H0);
    solve [ apply union_introl; solve [ apply union_introl; reflexivity || trivial
                                      | apply union_intror; reflexivity || trivial
                                      | reflexivity || trivial]
          | apply union_intror; solve [ apply union_introl; reflexivity || trivial
                                      | apply union_intror; reflexivity || trivial
                                      | reflexivity || trivial]].
Qed.
Hint Resolve union_addr.

Lemma union_assoc : forall {A: Type} (s1 s2 s3 : set A),
    (s1 U s2) U s3 = s1 U s2 U s3.
Proof.
  intros. apply E.Extensionality_Ensembles. unfold E.Same_set. unfold E.Included. unfold union.
  split; intros; inversion H; try (inversion H0);
    solve [ apply union_introl; solve [ apply union_introl; reflexivity || trivial
                                      | apply union_intror; reflexivity || trivial
                                      | reflexivity || trivial]
          | apply union_intror; solve [ apply union_introl; reflexivity || trivial
                                      | apply union_intror; reflexivity || trivial
                                      | reflexivity || trivial]].
Qed.
Hint Resolve union_assoc.

Lemma union_same : forall {A : Type} (s : set A),
    s U s = s.
Proof.
  intros. apply E.Extensionality_Ensembles. unfold E.Same_set. unfold E.Included. unfold union.
  split; intros; try (inversion H); trivial. apply union_introl. apply H.
Qed.
Hint Resolve union_same.

Lemma union_include : forall {A : Type} (s1 s2 : set A),
    subset s1 s2 -> s2 = s2 U s1.
Proof.
  intros. apply E.Extensionality_Ensembles.
  unfold E.Same_set. unfold subset in H. unfold E.Included. unfold E.Included in H.
  split; intros.
  - apply union_introl. apply H0.
  - destruct H0.
    + apply H0.
    + apply H. apply H0.
Qed.
Hint Resolve union_include.

Lemma In_list_set_In_list : forall {A : Type} (l : list A) (a : A),
    In a l -> set_In a (set_from_list l).
Proof.
  induction l; intros; inversion H.
  - subst a0. simpl. apply union_intror. apply E.In_singleton.
  - simpl. apply union_introl. apply IHl. apply H0.
Qed.
Hint Resolve In_list_set_In_list.

Lemma nth_error_first_n : forall {A : Type} (l : list A) (a : A) (n : nat),
    nth_error l n = Some a -> nth_error (first_n l (S n)) n = Some a.
Proof.
  induction l; intros; destruct n; inversion H.
  - subst a0. reflexivity.
  - simpl. rewrite H1. apply IHl. apply H1.
Qed.
Hint Resolve nth_error_first_n.

Lemma remove_last_length : forall {A : Type} (l : list A) (n : nat),
    length l = S n -> length (remove_last l) = n.
Proof.
  induction l; intros; inversion H.
  destruct l; try reflexivity.
  simpl. simpl in IHl. rewrite IHl with (length l); reflexivity.
Qed.
Hint Resolve remove_last_length.

Lemma remove_last_first_n : forall {A : Type} (l : list A) (n : nat),
    n < length l -> first_n l n = first_n (remove_last l) n.
Proof.
  induction l; intros.
  - inversion H.
  - destruct l.
    + simpl in H. inversion H. reflexivity. inversion H1.
    + destruct n; try reflexivity.
      simpl. f_equal. unfold first_n in IHl. fold (@first_n A) in IHl.
      unfold remove_last in IHl. fold (@remove_last A) in IHl.
      apply IHl. apply Lt.lt_S_n. apply H.
Qed.
Hint Resolve remove_last_first_n.

Lemma remove_last_nth_error : forall {A : Type} (l : list A) (n : nat),
    S n < length l -> nth_error l n = nth_error (remove_last l) n.
Proof.
  induction l; intros.
  - inversion H.
  - destruct n.
    + destruct l.
      * inversion H. inversion H1.
      * reflexivity.
    + destruct l.
      * inversion H. inversion H1.
      * simpl. simpl in IHl. apply IHl. apply Lt.lt_S_n. apply H.
Qed.
Hint Resolve remove_last_nth_error.

Lemma first_n_length : forall {A : Type} (l : list A),
    first_n l (length l) = l.
Proof.
  induction l; try reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.
Hint Resolve first_n_length.

Lemma last_error_In : forall {A : Type} (l : list A) (a : A),
    last_error l = Some a -> In a l.
Proof.
  induction l.
  - intros. inversion H.
  - destruct l.
    + intros. inversion H. left. reflexivity.
    + intros. right. apply IHl. apply H.
Qed.
Hint Resolve last_error_In.

Lemma zip_with_ind_h_length : forall {A : Type} (l : list A) (n : nat),
    length (zip_with_ind_h l n) = length l.
Proof.
  induction l.
  - reflexivity.
  - intros. simpl. f_equal. apply IHl.
Qed.

Lemma zip_with_ind_length : forall {A : Type} (l : list A),
    length (zip_with_ind l) = length l.
Proof. intros. apply zip_with_ind_h_length. Qed.
Hint Resolve zip_with_ind_length.

Lemma last_repeat : forall {A : Type} (a : A) (n : nat),
    last_error (repeat a (S n)) = Some a.
Proof.
  induction n.
  - reflexivity.
  - simpl. apply IHn.
Qed.
Hint Resolve last_repeat.

Lemma last_error_map : forall {A B : Type} (f : A -> B) (l : list A) (a : A),
    last_error l = Some a -> last_error (map f l) = Some (f a).
Proof.
  induction l.
  - intros. inversion H.
  - intros. destruct l.
    + inversion H. subst a0. reflexivity.
    + simpl. apply IHl. apply H.
Qed.
Hint Resolve last_error_map.

Lemma last_error_zip_with_ind_h : forall {A : Type} (l : list A) (n : nat) (m : nat) (a : A),
    length l = S m -> last_error l = Some a ->
    last_error (zip_with_ind_h l n) = Some (m + n, a).
Proof.
  induction l.
  - intros. inversion H.
  - intros. destruct l.
    + inversion H0. subst a0. inversion H. reflexivity.
    + destruct m. inversion H. simpl. rewrite plus_n_Sm. apply IHl.
      * simpl. f_equal. inversion H. reflexivity.
      * apply H0.
Qed.
Hint Resolve last_error_zip_with_ind_h.

Lemma last_error_zip_with_ind : forall {A : Type} (l : list A) (n : nat) (a : A),
    length l = S n -> last_error l = Some a ->
    last_error (zip_with_ind l) = Some (n, a).
Proof.
  intros. unfold zip_with_ind. rewrite (plus_n_O n). apply last_error_zip_with_ind_h; trivial.
Qed.
Hint Resolve last_error_zip_with_ind.

Lemma nth_error_map : forall {A B : Type} (l : list A) (f : A -> B) (a : A) (n : nat),
    nth_error l n = Some a -> nth_error (map f l) n = Some (f a).
Proof.
  induction l; intros; destruct n; inversion H.
  - subst a0. reflexivity.
  - rewrite <- IHl with (n := n); try reflexivity. apply H.
Qed.
Hint Resolve nth_error_map.

Lemma nth_error_zip_with_ind_h : forall {A : Type} (l : list A) (n : nat) (m : nat) (a : A),
    nth_error l m = Some a -> nth_error (zip_with_ind_h l n) m = Some (n + m, a).
Proof.
  induction l; intros; destruct m; inversion H.
  - subst a0. rewrite PeanoNat.Nat.add_comm. reflexivity.
  - simpl. rewrite <- plus_n_Sm. replace (S (n + m)) with (S n + m) by reflexivity.
    apply IHl. trivial.
Qed.

Lemma nth_error_zip_with_ind : forall {A : Type} (l : list A) (m : nat) (a : A),
    nth_error l m = Some a -> nth_error (zip_with_ind l) m = Some (m, a).
Proof.
  intros. apply nth_error_zip_with_ind_h. trivial.
Qed.
Hint Resolve nth_error_zip_with_ind.

Lemma nth_error_better_Some : forall {A : Type} (l : list A) (n : nat),
    n < length l <-> exists a, nth_error l n = Some a.
Proof.
  split.
  - intros. assert (nth_error l n <> None) by (apply nth_error_Some; trivial).
    destruct (nth_error l n) eqn:ntherr.
    + exists a. reflexivity.
    + destruct H0; reflexivity.
  - intros. apply (nth_error_Some). intro. destruct H. rewrite H in H0. inversion H0.
Qed.
Hint Resolve nth_error_better_Some.

Lemma index_of_existsb : forall {A : Type} (f : A -> bool) (l : list A),
    (exists n, index_of f l = Some n) <-> existsb f l = true.
Proof.
  intros. induction l.
  - simpl. split; intros; inversion H. inversion H0.
  - simpl. destruct (f a) eqn:fa; simpl.
    + split; intros; try (exists 0); reflexivity.
    + rewrite <- IHl. split; intros; destruct H as [n Hn].
      * exists (pred n). destruct (index_of f l); inversion Hn. reflexivity.
      * exists (S n). rewrite Hn. reflexivity.
Qed.
Hint Resolve index_of_existsb.

Lemma index_of_In : forall {A : Type} (l : list A) (f : A -> bool) (a : A),
    (forall b, f b = true <-> a = b) -> ((exists n, index_of f l = Some n) <-> In a l).
Proof.
  induction l; split; intros; simpl; try solve [inversion H0].
  - inversion H0. inversion H1.
  - destruct H0 as [n Hn]. inversion Hn. destruct (f a) eqn:fa.
    + apply H in fa. subst. left. reflexivity.
    + right. specialize (IHl f a0 H). apply IHl. exists (pred n).
      destruct (index_of f l).
      * simpl in H1. injection H1 as H2. rewrite <- H2. reflexivity.
      * inversion H1.
  - destruct (f a) eqn:fa.
    + exists 0. reflexivity.
    + inversion H0.
      * symmetry in H1. apply H in H1. rewrite H1 in fa. inversion fa.
      * specialize (IHl f a0 H). apply IHl in H1. destruct H1 as [n Hn].
        rewrite Hn. simpl. exists (S n). reflexivity.
Qed.
Hint Resolve index_of_In.

Lemma nth_error_combine : forall {A} l l' n (a a' : A),
    nth_error l n = Some a -> nth_error l' n = Some a' ->
    nth_error (combine l l') n = Some (a, a').
Proof.
  induction l; intros; try solve [destruct n; inversion H].
  destruct n.
  + destruct l'; inversion H0. inversion H. reflexivity.
  + destruct l'; try solve [inversion H0]. simpl in H. simpl in H0. simpl.
    apply IHl; assumption.
Qed.
Hint Resolve nth_error_combine.

Lemma index_of_length : forall A (f : A -> bool) l n,
    index_of f l = Some n -> n < length l.
Proof.
  induction l; intros; try inversion H.
  destruct (f a) eqn:fa.
  - inversion H1. simpl. apply le_n_S. apply le_0_n.
  - destruct (index_of f l) as [m|]; try solve [inversion H1].
    simpl in H1. inversion H1. simpl. apply Lt.lt_n_S. apply IHl. reflexivity.
Qed.
Hint Resolve index_of_length.

Lemma nth_error_repeat : forall A n m (a : A),
    n < m -> nth_error (repeat a m) n = Some a.
Proof.
  intros. generalize dependent n. induction m; intros.
  - inversion H.
  - destruct n; try reflexivity.
    apply Lt.lt_S_n in H. simpl. apply IHm. assumption.
Qed.
Hint Resolve nth_error_repeat.

Lemma subset_trans : forall {A} (s : set A) s' s'',
    subset s s' -> subset s' s'' -> subset s s''.
Proof. intros A s s' s'' H H0 a a_in_s. apply H0, H, a_in_s. Qed.
Hint Resolve subset_trans.

Lemma existsb_find : forall {A} (P : A -> bool) (l : list A),
    existsb P l = true <-> (exists a, find P l = Some a).
Proof.
  induction l; (split; intros; [| destruct H]; inversion H).
  - destruct (P a) eqn:Pa; simpl; rewrite Pa.
    + eexists. reflexivity.
    + apply IHl. assumption.
  - destruct (P a) eqn:Pa; simpl; rewrite Pa.
    + reflexivity.
    + apply IHl. eexists. eassumption.
Qed.
Hint Resolve existsb_find.

Lemma existsb_map : forall {A B} (f : A -> B) (P : B -> bool) (l : list A),
    existsb P (map f l) = existsb (fun a => P (f a)) l.
Proof.
  induction l; try reflexivity.
  simpl. destruct (P (f a)); try reflexivity; assumption.
Qed.
Hint Resolve existsb_map.

Lemma In_set_from_list_In_list : forall {A} l (a : A),
    set_In a (set_from_list l) <-> In a l.
Proof.
  induction l; split; intros; inverts 2; subst; eauto.
  - right. apply IHl. eauto.
  - left. reflexivity.
Qed.
Hint Resolve In_set_from_list_In_list.

Lemma find_app : forall {A} l1 l2 f (a : A),
    find f (l1 ++ l2) = Some a -> find f l1 = Some a \/ find f l2 = Some a.
Proof.
  induction l1; intros; eauto.
  simpl in *. destruct (f a); eauto.
Qed.
Hint Resolve find_app.

Lemma not_find_app : forall {A} (f : A -> bool) l1 l2,
    find f (l1 ++ l2) = None <-> find f l1 = None /\ find f l2 = None.
Proof.
  induction l1; split; intros; decomp; auto; simpl in *;
    destruct (f a); auto; try discriminate; apply IHl1; try split; auto.
Qed.
Hint Resolve not_find_app.

Lemma combine_map_l : forall {A B C} la (lb : list B) (f : A -> C),
    combine (map f la) lb = map (fun p => (f (fst p), snd p)) (combine la lb).
Proof.
  induction la; destruct lb; try reflexivity.
  simpl. intros. rewrite IHla. reflexivity.
Qed.
Hint Resolve combine_map_l.

Lemma combine_map_r : forall {A B C} lb (la : list A) (f : B -> C),
    combine la (map f lb) = map (fun p => (fst p, f (snd p))) (combine la lb).
Proof.
  induction lb; destruct la; try reflexivity.
  simpl. intros. rewrite IHlb. reflexivity.
Qed.
Hint Resolve combine_map_r.

Lemma Forall_add_combine : forall {A B} (P : A -> B -> Prop) la lb,
    Forall (fun a => forall b, P a b) la -> Forall (fun p => P (fst p) (snd p)) (combine la lb).
Proof. induction la; intros; simpl; destruct lb; trivial. inversion H. eauto. Qed.
Hint Resolve Forall_add_combine.

Lemma Forall_combine_same : forall {A} (P : A -> A -> Prop) l,
    Forall (fun p => P (fst p) (snd p)) (combine l l) <-> Forall (fun a => P a a) l.
Proof.
  induction l; split; intros; auto;
    inversion H; subst; simpl in *; constructor; auto;
      apply IHl; auto.
Qed.
Hint Resolve Forall_combine_same.

Lemma Forall_exists : forall {A B} (P : A -> B -> Prop) la lb,
    length la <= length lb ->
    Forall (fun p => P (fst p) (snd p)) (combine la lb) ->
    Forall (fun a => exists b, P a b) la.
Proof.
  induction la; auto.
  intros. destruct lb; try solve [inversion H].
  inversion H0. subst. simpl in *.
  constructor.
  - eexists; eassumption.
  - eapply IHla; eauto. apply le_S_n. assumption.
Qed.
Hint Resolve Forall_exists.

Lemma find_map : forall {A B} (f : A -> B) (p : B -> bool) l,
    find p (map f l) = option_map f (find (fun a => p (f a)) l).
Proof.
  induction l; auto.
  simpl in *. destruct (p (f a)); auto.
Qed.
Hint Resolve find_map.

Lemma option_map_None : forall {A B} (f : A -> B) oa,
    option_map f oa = None <-> oa = None.
Proof. split; intros; destruct oa; auto; discriminate. Qed.
Hint Resolve option_map_None.

Hint Resolve nth_error_In. Hint Resolve in_map_iff.


Require Export ProjectiveGeometry.Dev.desargues_3D_lemmas.

(*****************************************************************************)
(** Proof of Desargues in 3D **)

Section s_desargues3D.

Context `{RPSOH : RankProjectiveSpaceOrHigher}.
Context `{EP : EqDecidability Point}.

Variables a b c : Point.
Variables A B C : Point.
Variables alpha beta gamma : Point.
Variables O : Point.

Variable raAO : rk(triple a A O)=2.
Variable rbBO : rk(triple b B O)=2.
Variable rcCO : rk(triple c C O)=2.
Variable rABC : rk(triple A B C)=3.
Variable rabc : rk(triple a b c)=3.

Variable rABCabc : rk(union (triple A B C) (triple a b c))>=4. (* not coplanar *)

Variable rABgamma : rk(triple A B gamma)=2.
Variable rabgamma : rk(triple a b gamma)=2.

Variable rACbeta : rk(triple A C beta)=2.
Variable racbeta : rk(triple a c beta)=2.

Variable rBCalpha : rk(triple B C alpha)=2.
Variable rbcalpha : rk(triple b c alpha)=2.

Definition ps : set Point := triple a b c.
Definition Ps : set Point := triple A B C.

Variable raA : rk(couple a A)=2.
Variable rcC : rk(couple c C)=2.
Variable rbB : rk(couple b B)=2.

Hint Resolve rk_singleton rk_couple1 rk_couple2 couple_rk1 couple_rk2 couple_rk_degen rk_couple_1 rk_couple_2 : rk_base.
Hint Resolve rk_triple_ABC_couple_AB rk_triple_ABC_couple_BC rk_triple_ABC_couple_AC : rk_base.
Hint Resolve  rk_triple_singleton : rk_base.
Hint Resolve rk_couple_not_zero : rk_base.

Lemma a_not_alpha :rk(couple a alpha) =2. (* contradicts hyp rabc *)
Proof.
apply rk_couple1.
intro H0;rewrite H0 in *;clear H0.
setoid_replace (triple alpha b c) with (triple b c alpha) in rabc by (clear_all;fsetdecide).
rewrite rabc in rbcalpha; omega.
Qed.

Lemma a_not_gamma :rk(couple a gamma) =2 \/ rk (triple gamma alpha beta) = 2.
Proof.
apply (a_not_gamma_scheme a b c A B C alpha beta gamma O); try assumption.
Qed.

Lemma c_not_beta : rk(couple c beta) = 2 \/ rk (triple beta gamma alpha)=2.
Proof.
apply (a_not_gamma_scheme c a b C A B gamma alpha beta O); try assumption.
setoid_replace (triple C A B) with (triple A B C) by (clear_all;fsetdecide); assumption.
setoid_replace (triple c a b) with (triple a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple C A B) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple c a b) with (triple a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple C A beta) with (triple A C beta) by (clear_all;fsetdecide); assumption.
setoid_replace (triple c a beta) with (triple a c beta) by (clear_all;fsetdecide); assumption.
setoid_replace (triple C B alpha) with (triple B C alpha) by (clear_all;fsetdecide); assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by (clear_all;fsetdecide); assumption.
Qed.

Lemma b_not_gamma : rk(couple b gamma) = 2 \/ rk (triple gamma beta alpha)=2.
Proof.
apply (a_not_gamma_scheme b a c B A C beta alpha gamma O); try assumption.
setoid_replace (triple B A C) with (triple A B C) by (clear_all;fsetdecide); assumption.
setoid_replace (triple b a c) with (triple a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple B A C) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple b a c) with  (triple a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by (clear_all;fsetdecide); assumption.
setoid_replace (triple b a gamma) with( triple a b gamma) by (clear_all;fsetdecide); assumption.
Qed.

Hint Resolve  a_not_alpha a_not_gamma c_not_beta b_not_gamma : rk_base.

Lemma A_not_alpha  : rk(couple A alpha) =2.
Proof.
apply rk_couple1.
intro H0;rewrite H0 in *;clear H0.
setoid_replace (triple alpha B C) with (triple B C alpha) in rABC by (clear_all;fsetdecide).
rewrite rABC in rBCalpha; omega.
Qed.

Lemma B_not_beta :rk(couple B beta) =2.
Proof.
apply rk_couple1.
intro H0;rewrite H0 in *;clear H0.
setoid_replace (triple A beta C) with (triple A C beta) in rABC by (clear_all;fsetdecide).
rewrite rABC in rACbeta; omega.
Qed.

Lemma C_not_gamma :rk(couple C gamma) =2.
Proof.
apply rk_couple1.
intro H0;rewrite H0 in *;clear H0.
omega.
Qed.

Lemma A_not_beta  : rk(couple A beta)=2 \/ rk(triple alpha beta gamma)=2.
Proof.
eapply (A_not_beta_scheme a b c A B C alpha beta gamma O); try assumption.
Qed.

Lemma A_not_gamma :rk(couple A gamma) =2\/rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple alpha gamma beta) by (clear_all;fsetdecide).
apply (A_not_beta_scheme a c b A C B alpha gamma beta O); try assumption.
setoid_replace (triple A C B) with (triple A B C) by (clear_all;fsetdecide); assumption.
setoid_replace (triple a c b) with (triple  a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple A C B) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace  (triple a c b) with (triple a b c)  by (clear_all;fsetdecide); assumption.
setoid_replace (triple C B alpha) with (triple B C alpha) by (clear_all;fsetdecide);assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by (clear_all;fsetdecide); assumption.
Qed.

Lemma B_not_alpha :rk(couple B alpha)=2 \/ rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple beta alpha gamma)  by (clear_all;fsetdecide).
apply (A_not_beta_scheme b a c B A C beta alpha gamma O); try assumption.
setoid_replace (triple B A C) with (triple A B C) by (clear_all;fsetdecide); assumption.
setoid_replace (triple b a c) with (triple  a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple B A C) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple b a c) with (triple a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by (clear_all;fsetdecide); assumption.
setoid_replace (triple b a gamma) with (triple a b gamma) by (clear_all;fsetdecide); assumption.
Qed.

Lemma B_not_gamma:rk(couple B gamma)=2 \/ rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple beta gamma alpha) by (clear_all;fsetdecide).
apply (A_not_beta_scheme b c a B C A beta gamma alpha O); try assumption.
setoid_replace (triple B C A) with (triple A B C) by (clear_all;fsetdecide); assumption.
setoid_replace (triple b c a) with (triple a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple B C A) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple b c a)  with  (triple a b c)  by (clear_all;fsetdecide); assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by (clear_all;fsetdecide); assumption.
setoid_replace (triple b a gamma) with (triple a b gamma) by (clear_all;fsetdecide); assumption.
setoid_replace (triple C A beta) with (triple A C beta) by (clear_all;fsetdecide); assumption.
setoid_replace (triple c a beta) with (triple a c beta) by (clear_all;fsetdecide); assumption.
Qed.

Lemma C_not_alpha :rk(couple C alpha) =2\/rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple gamma alpha beta) by (clear_all;fsetdecide).
apply (A_not_beta_scheme c a b C A B gamma alpha beta O); try assumption.
setoid_replace (triple C A B) with (triple A B C) by (clear_all;fsetdecide); assumption.
setoid_replace (triple c a b) with (triple a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple C A B) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple c a b) with (triple a b c)  by (clear_all;fsetdecide); assumption.
setoid_replace (triple C A beta) with (triple A C beta) by (clear_all;fsetdecide);assumption.
setoid_replace (triple c a beta) with (triple a c beta) by (clear_all;fsetdecide);assumption.
setoid_replace (triple C B alpha) with (triple B C alpha) by (clear_all;fsetdecide);assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by (clear_all;fsetdecide);assumption.
Qed.

Lemma C_not_beta :rk(couple C beta) =2\/rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple gamma beta alpha) by (clear_all;fsetdecide).
apply (A_not_beta_scheme c b a C B A gamma beta alpha O) ; try assumption.
setoid_replace (triple C B A) with (triple A B C) by (clear_all;fsetdecide); assumption.
setoid_replace (triple c b a) with (triple a b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple C B A) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace  (triple c b a) with (triple a b c)  by (clear_all;fsetdecide); assumption.
setoid_replace (triple C B alpha) with (triple B C alpha) by (clear_all;fsetdecide);assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by (clear_all;fsetdecide);assumption.
setoid_replace (triple C A beta) with (triple A C beta) by (clear_all;fsetdecide);assumption.
setoid_replace (triple c a beta) with (triple a c beta) by (clear_all;fsetdecide);assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by (clear_all;fsetdecide);assumption.
setoid_replace (triple b a gamma) with (triple a b gamma) by (clear_all;fsetdecide);assumption.
Qed.

(* these 6 lemmas (above) contradict coplanarity hyp rABCabc or lead to rk(alpha,beta,gamma)=2 *)

Hint Resolve A_not_alpha B_not_beta C_not_gamma
 A_not_beta A_not_gamma B_not_alpha B_not_gamma
C_not_alpha C_not_beta.

Lemma rAB :  rk(couple A B)=2.
Proof.
eauto with rk_base.
Qed.

Lemma rBC : rk(couple B C)=2.
Proof.
eauto with rk_base.
Qed.

Lemma rAC : rk(couple A C)=2.
Proof.
eauto with rk_base.
Qed.

Lemma rab : rk(couple a b)=2.
Proof.
eauto with rk_base.
Qed.

Lemma rac : rk(couple a c)=2.
Proof.
eauto with rk_base.
Qed.

Lemma rbc : rk(couple b c)=2.
Proof.
eauto with rk_base.
Qed.

Lemma L1alpha : rk(union Ps (singleton alpha))=3.
Proof.
unfold Ps.
eapply (rk_triple_singleton).
intuition.
Qed.

Lemma L1palpha:rk(union ps (singleton alpha)) = 3.
Proof.
unfold ps.
eapply (rk_triple_singleton).
intuition.
Qed.

Lemma L1Pbeta : rk(union Ps (singleton beta))=3.
Proof.
apply  L1beta_gen;auto.
Qed.

Lemma L1pbeta : rk(union ps (singleton beta))=3.
Proof.
apply  L1beta_gen;auto.
Qed.

Lemma L1Pgamma : rk(union Ps (singleton gamma))=3.
Proof.
apply  L1gamma_gen;auto.
Qed.

Lemma L1pgamma : rk(union ps (singleton gamma))=3.
Proof.
apply  L1gamma_gen;auto.
Qed.

Lemma ralphabeta : rk(couple alpha beta)=2 \/ rk(triple alpha beta gamma)=2.
Proof.
my_classical_left.
rename n into HnotDes.
apply le_antisym.
auto with rk_base.
assert (rk (couple alpha beta) = 0 \/ rk (couple alpha beta) =1 \/ rk (couple alpha beta) >= 2).
omega.
elim H0;intro.
apply False_ind.
assert(HH := rk_couple_not_zero alpha beta H1).
assumption.

elim H1;intro.
assert (rk (couple c beta) = 2 \/ rk (triple beta gamma alpha) = 2).
apply c_not_beta.
elim H3;intro c_not_beta_local.
2:setoid_replace (triple beta gamma alpha)  with (triple alpha beta gamma)
in c_not_beta_local by (clear_all;fsetdecide);omega.
assert(HH : alpha [==] beta).
apply couple_rk2;assumption.
rewrite HH in *; clear HH.
assert  (T:= (col_trans a b c beta racbeta rbcalpha c_not_beta_local)).
omega.
omega.
Qed.

Lemma ralphagamma : rk(couple alpha gamma)=2\/rk(triple alpha beta gamma)=2.
Proof.
my_classical_left.
rename n into HnotDes.
apply le_antisym.
auto with rk_base.
assert (rk (couple alpha gamma) = 0 \/ rk (couple alpha gamma) =1 \/ rk (couple alpha gamma) >= 2).
omega.

elim H0;intro.
apply False_ind.
assert(HH := rk_couple_not_zero alpha gamma H1).
assumption.

elim H1;intro.
assert (rk (couple b gamma) = 2 \/ rk (triple gamma beta alpha) = 2).
apply b_not_gamma.
elim H3;intro b_not_gamma_local.
2:setoid_replace (triple gamma beta alpha)  with (triple alpha beta gamma)
in b_not_gamma_local by (clear_all;fsetdecide);omega.
assert(HH : alpha [==] gamma).
apply couple_rk2;assumption.
rewrite HH in *; clear HH.
setoid_replace (triple b c gamma) with (triple c b gamma) in rbcalpha by (clear_all;fsetdecide).
assert  (T:= (col_trans a c b gamma rabgamma rbcalpha b_not_gamma_local)).
setoid_replace (triple a b c) with (triple a c b) in rabc by (clear_all;fsetdecide).
omega.
omega.
Qed.

Lemma rbetagamma : rk(couple beta gamma)= 2 \/ rk (triple alpha beta gamma) = 2.
Proof.
my_classical_left.
rename n into HnotDes.
apply le_antisym.
auto with rk_base.
assert (rk (couple beta gamma) = 0 \/ rk (couple beta gamma) =1 \/ rk (couple beta gamma) >= 2).
omega.

elim H0;intro.
apply False_ind.
assert(HH := rk_couple_not_zero beta gamma H1).
assumption.
elim H1;intro.

assert (rk (couple a gamma) = 2 \/ rk (triple gamma alpha beta) = 2).
apply a_not_gamma.
elim H3;intro a_not_gamma_local.
2:setoid_replace (triple gamma alpha beta) with (triple alpha beta gamma)
in a_not_gamma_local by (clear_all;fsetdecide);omega.
assert(HH : beta [==] gamma).
apply couple_rk2;assumption.
rewrite HH in *; clear HH.
setoid_replace (triple a c gamma) with (triple c a gamma) in racbeta by (clear_all;fsetdecide).
setoid_replace (triple a b gamma) with (triple b a gamma) in rabgamma by (clear_all;fsetdecide).
assert (rk (triple c b a) <= 2) by (apply (col_trans  c b a gamma racbeta rabgamma a_not_gamma_local)).
setoid_replace (triple a b c) with (triple c b a) in rabc by (clear_all;fsetdecide).
omega.
omega.
Qed.

Lemma L2P : rk(union Ps (triple alpha beta gamma))= 3 \/  rk (triple alpha beta gamma) = 2.
Proof.
my_classical_left.
rename n into HnotDes.
apply le_antisym.

(* >= *)
assert (rk (union Ps (couple alpha beta)) <= 3).

generalize (matroid3 (union Ps (singleton alpha)) (union Ps (singleton beta))).
rewrite L1alpha.
rewrite L1Pbeta.
setoid_replace (inter (union Ps (singleton alpha)) (union Ps (singleton beta))) with Ps.
unfold Ps at 3; rewrite rABC.

setoid_replace (union (union Ps (singleton alpha)) (union Ps (singleton beta))) with (union Ps (couple alpha beta)).
omega.
(clear_all;fsetdecide).
unfold Ps.
assert (~ alpha [==] beta).
generalize ralphabeta.
intro.
elim H0;intros;clear H0.
apply couple_rk1;auto.
intuition.
(clear_all;fsetdecide).

generalize (matroid3 (union Ps (couple alpha beta)) (union Ps (singleton gamma))).

setoid_replace (union (union Ps (couple alpha beta)) (union Ps (singleton gamma))) with
                        (union Ps (triple alpha beta gamma)) by (clear_all;fsetdecide).

setoid_replace (inter (union Ps (couple alpha beta)) (union Ps (singleton gamma))) with Ps.
rewrite L1Pgamma.
unfold Ps at 2.
rewrite rABC.
omega.
unfold Ps.
assert (~ alpha [==] gamma).
generalize ralphagamma.
intro.
elim H1;intro; clear H1.
apply couple_rk1;auto.
intuition.
assert (~ beta [==] gamma).
generalize rbetagamma.
intro.
elim H2;intro; clear H2.
apply couple_rk1;auto.
intuition.
(clear_all;fsetdecide).
(* <= *)
assert (Hsubset : (Subset (union Ps (couple alpha beta)) (union Ps (triple alpha beta gamma))))
by (clear_all;fsetdecide).
apply le_trans with (rk (union Ps (couple alpha beta))).
2:apply (matroid2 (union Ps (couple alpha beta)) (union Ps (triple alpha beta gamma)) Hsubset).
assert (Hsubset' : Subset (union Ps (singleton alpha)) (union Ps (couple alpha beta))) by (clear_all;fsetdecide).
apply le_trans with (rk (union Ps (singleton alpha))).
2: apply (matroid2 (union Ps (singleton alpha)) (union Ps (couple alpha beta)) Hsubset').
rewrite L1alpha.
solve[intuition].
Qed.

Lemma  L2p : rk(union ps (triple alpha beta gamma))=3 \/ rk (triple alpha beta gamma) = 2.
Proof.
my_classical_left.
rename n into HnotDes.
apply le_antisym.
(*<=*)
assert (rk(union ps (couple alpha beta)) <=3).
generalize (matroid3 (union ps (singleton alpha)) (union ps (singleton beta))).
rewrite L1palpha.
rewrite L1pbeta.
setoid_replace (union(union ps (singleton alpha))(union ps (singleton beta)))
with (union ps (couple alpha beta)).
2:(clear_all;fsetdecide).
setoid_replace (inter (union ps (singleton alpha))(union ps (singleton beta)))
                        with ps.
unfold ps.
rewrite rabc.
omega.
assert (~ alpha [==] beta).
generalize (ralphabeta).
intros.
elim H0; intros;clear H0.
apply couple_rk1;auto.
intuition.
(clear_all;fsetdecide).

generalize (matroid3 (union ps(couple alpha beta))(union ps(singleton gamma))).
rewrite L1pgamma.
setoid_replace (union(union ps (couple alpha beta))(union ps (singleton gamma)))
                with (union ps(triple alpha beta gamma)) by (clear_all;fsetdecide).

assert (~ alpha [==] gamma).
  generalize (ralphagamma).
  intros.
  elim H1; intros;clear H1.
  apply couple_rk1;auto.
  intuition.
  auto.

assert (~ beta [==] gamma).
   generalize (rbetagamma).
   intros.
   elim H2; intros;clear H2.
   apply couple_rk1;auto.
   intuition.
   auto.

setoid_replace (inter (union ps(couple alpha beta))(union ps (singleton gamma)))
                        with ps by (clear_all;fsetdecide).

unfold ps at 2.
rewrite rabc.
omega.

(*>=*)

assert (Hsubset : (Subset (union ps (couple alpha beta)) (union ps (triple alpha beta gamma))) )
by (clear_all;fsetdecide).
apply le_trans with (rk(union ps (couple alpha beta))).
2:apply (matroid2 (union ps (couple alpha beta))(union ps (triple alpha beta gamma)));
assumption.

assert (Hsubset' : (Subset (union ps (singleton alpha)) (union ps (couple alpha beta))) )
by (clear_all;fsetdecide).
generalize (matroid2 (union ps (singleton alpha)) (union ps (couple alpha beta))).
rewrite L1palpha.
solve[intuition].
Qed.

Lemma rPpalbega :
  rk (union Ps (union ps (triple alpha beta gamma))) >= 4 \/ rk (triple alpha beta gamma) = 2.
Proof.
my_classical_left.
rename n into HnotDes.
assert(Hsubset:Subset (union Ps ps) (union Ps(union ps(triple alpha beta gamma))) )
by (unfold Ps, ps;(clear_all;fsetdecide)).
generalize (matroid2 (union Ps ps) (union Ps(union ps (triple alpha beta gamma))) Hsubset).
unfold Ps,ps.
omega.
Qed.

Ltac unfold_p := unfold Ps, ps.

Theorem Desargues_general : rk (triple alpha beta gamma) <= 2.
Proof.
assert (T: rk
         (union (union Ps (triple alpha beta gamma))
            (union ps (triple alpha beta gamma))) +
       rk (triple alpha beta gamma) <=
       rk (union Ps (triple alpha beta gamma)) +
       rk (union ps (triple alpha beta gamma))).
apply (matroid3_useful (union Ps (triple alpha beta gamma))
                                    (union ps (triple alpha beta gamma))
                                    (triple alpha beta gamma)).
(clear_all;fsetdecide).
setoid_replace (union (union Ps (triple alpha beta gamma))
     (union ps (triple alpha beta gamma))) with (union Ps (union ps (triple alpha beta gamma)))
     in T by (unfold Equal; split; (clear_all;fsetdecide)).
assert (rk (union Ps (union ps (triple alpha beta gamma))) >= 4 \/
       rk (triple alpha beta gamma) = 2).
apply rPpalbega.
elim H0;intro.
rename H1 into HrPpalbega.
2:omega.
assert (rk (union ps (triple alpha beta gamma)) = 3 \/
       rk (triple alpha beta gamma) = 2).
apply L2p.
elim H1;intro.
rename H2 into HL2p.
2:omega.
rewrite HL2p in T.
assert ( rk (union Ps (triple alpha beta gamma)) = 3 \/
       rk (triple alpha beta gamma) = 2).
apply L2P.
elim H2;intro.
rename H3 into HL2P.
2:omega.
rewrite HL2P in T.
omega.
Qed.

End s_desargues3D.


Require Import ListAux.
Require Import TreeAux.
Lemma stream3consistent_Nil0 (il_0:list nat) (u_0:nat) (u_1:nat) : (nil_spec  il_0) -> ((True) -> (not (list_once  il_0 u_1))).
Proof. solve_nil; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma stream3consistent_Nil1 (il_0:list nat) (u_0:nat) (u_1:nat) : (nil_spec  il_0) -> ((True) -> (not (list_member  il_0 u_1))).
Proof. solve_nil; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma stream3consistent_Nil2 (il_0:list nat) (u_0:nat) (u_1:nat) : (nil_spec  il_0) -> ((True) -> (not (list_member  il_0 u_0))).
Proof. solve_nil; try (assert (u_0 = u_1); subst; eauto). Qed.


From SSL_Iris Require Import core.
From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Export tactics coq_tactics ltac_tactics reduction.
From iris.heap_lang Require Import lang notation proofmode.
Require Import common.
From iris_string_ident Require Import ltac2_string_ident.
From Hammer Require Import Hammer.
Context `{!heapG Σ}.
Set Default Proof Using "Type".

Definition max : val :=
rec: "max" "r" "x" "y" :=
if: "y" ≤ "x"
then (
("r") <- ("x");;
#()
)
else (
("r") <- ("y");;
#()
).

Lemma max_spec :
∀ (r : loc) (x : Z) (y : Z),
{{{ r ↦ #0 }}}
  max #r #x #y
{{{ RET #(); ∃ (m : Z), ⌜(x ≤ m)%Z ∧ (y ≤ m)%Z⌝ ∗ r ↦ #m }}}.
Proof.
iIntros (r x y ϕ) "iH1 Post".
iRewriteHyp.
iLöb as "max" forall (r x y ϕ).
ssl_begin.
ssl_if iH2.
ssl_store.
try wp_pures.
iFindApply.
iExists x.
ssl_finish.

ssl_store.
try wp_pures.
iFindApply.
iExists y.
ssl_finish.
Qed.