Require Import List.
Require Import Bool.
Require Import Char.
Require Import Xform.
Require Import CommonTacs.

Set Implicit Arguments.

Inductive astgram : Set :=
| aAny : astgram
| aEps : astgram
| aZero : astgram
| aChar : char_t -> astgram
| aCat : astgram -> astgram -> astgram
| aAlt : astgram -> astgram -> astgram
| aStar : astgram -> astgram.

Fixpoint astgram_cmp (a1 a2:astgram) : comparison :=
  match a1, a2 with
    | aEps, aEps => Eq
    | aEps, _ => Lt
    | _, aEps => Gt
    | aZero, aZero => Eq
    | aZero, _ => Lt
    | _, aZero => Gt
    | aAny, aAny => Eq
    | aAny, _ => Lt
    | _, aAny => Gt
    | aChar c1, aChar c2 => char_cmp c1 c2
    | aChar _, _ => Lt
    | _ , aChar _ => Gt
    | aCat a1 a2, aCat a3 a4 =>
      match astgram_cmp a1 a3 with
        | Eq => astgram_cmp a2 a4
        | Lt => Lt
        | Gt => Gt
      end
    | aCat _ _, _ => Lt
    | _, aCat _ _ => Gt
    | aAlt a1 a2, aAlt a3 a4 =>
      match astgram_cmp a1 a3 with
        | Eq => astgram_cmp a2 a4
        | Lt => Lt
        | Gt => Gt
      end
    | aAlt _ _, _ => Lt
    | _, aAlt _ _ => Gt
    | aStar a1, aStar a3 => astgram_cmp a1 a3
  end.

Lemma astgram_eq_corr a1 : forall a2:astgram,
  astgram_cmp a1 a2 = Eq -> a1 = a2.
Proof.
  induction a1 ; induction a2 ; simpl ; auto ; intros ;
  try discriminate ; try (rewrite (char_eq_leibniz c c0) ; auto) ;
  try (specialize (IHa1_1 a2_1) ; specialize (IHa1_2 a2_2) ;
  destruct (astgram_cmp a1_1 a2_1) ; try discriminate ; rewrite IHa1_1 ; auto ;
  rewrite IHa1_2 ; auto). erewrite IHa1 ; eauto.
Qed.

Lemma astgram_cmp_sym : forall a1 a2, astgram_cmp a2 a1 = CompOpp (astgram_cmp a1 a2).
Proof.
  induction a1 ; destruct a2 ; auto ; simpl. apply CharOrderedTypeAlt.compare_sym.
  repeat rewrite IHa1_1. repeat rewrite IHa1_2. destruct (astgram_cmp a1_1 a2_1) ; auto.
  repeat rewrite IHa1_1. repeat rewrite IHa1_2. destruct (astgram_cmp a1_1 a2_1) ; auto.
  rewrite IHa1. auto.
Qed.

Lemma astgram_cmp_trans :
  forall cmp a1 a2 a3,
    astgram_cmp a1 a2 = cmp ->
    astgram_cmp a2 a3 = cmp -> astgram_cmp a1 a3 = cmp.
Proof.
  Local Ltac trans_simp :=
    match goal with
      | [ H: astgram_cmp ?a1 ?a2 = Eq |- _ ] => apply astgram_eq_corr in H ; subst a2
    end.
  intros cmp a1. generalize cmp. clear cmp.
  induction a1 ; destruct a2 ; intros  ; destruct a3 ; simpl in *;
  intros ; try congruence ; eauto.
  Case "aChar".
    eapply CharOrderedTypeAlt.compare_trans ; eauto.
  Case "aCat".
    remember_rev (astgram_cmp a1_1 a2_1) as cmp1.
    remember_rev (astgram_cmp a2_1 a3_1) as cmp2.
    destruct cmp1; destruct cmp2 ; try (repeat trans_simp ; crush ; fail).
    assert (H10:astgram_cmp a1_1 a3_1 = Eq) by eauto. rewrite H10. eauto.
    assert (H10:astgram_cmp a1_1 a3_1 = Lt) by eauto. rewrite H10. eauto.
    assert (H10:astgram_cmp a1_1 a3_1 = Gt) by eauto. rewrite H10. eauto.
  case "aAlt".
    remember_rev (astgram_cmp a1_1 a2_1) as cmp1.
    remember_rev (astgram_cmp a2_1 a3_1) as cmp2.
    destruct cmp1; destruct cmp2 ; try (repeat trans_simp ; crush ; fail).
    assert (H10:astgram_cmp a1_1 a3_1 = Eq) by eauto. rewrite H10. eauto.
    assert (H10:astgram_cmp a1_1 a3_1 = Lt) by eauto. rewrite H10. eauto.
    assert (H10:astgram_cmp a1_1 a3_1 = Gt) by eauto. rewrite H10. eauto.
Qed.

(** Compute the return [type] of an [astgram]. *)
Fixpoint astgram_type (pg : astgram) : type :=
  match pg with
    | aEps => Unit_t
    | aZero => Void_t
    | aChar _ => Char_t
    | aAny => Char_t
    | aCat pg1 pg2 => Pair_t (astgram_type pg1) (astgram_type pg2)
    | aAlt pg1 pg2 => Sum_t (astgram_type pg1) (astgram_type pg2)
    | aStar pg => List_t (astgram_type pg)
  end.

Inductive in_astgram : forall a, list char_t -> interp (astgram_type a) -> Prop :=
| InaEps : forall s v, s = nil -> v = tt -> in_astgram aEps s v
| InaChar : forall c s v, s = c::nil -> v = c -> in_astgram (aChar c) s v
| InaAny : forall c s v, s = c::nil -> v = c -> in_astgram aAny s v
| InaCat :
    forall a1 a2 s1 s2 v1 v2 s v,
      in_astgram a1 s1 v1 -> in_astgram a2 s2 v2 -> s = s1 ++ s2 -> v = (v1,v2) ->
      in_astgram (aCat a1 a2) s v
| InaAlt_l :
    forall a1 a2 s v1 v,
      in_astgram a1 s v1 -> v = inl _ v1 -> in_astgram (aAlt a1 a2) s v
| InaAlt_r :
    forall a1 a2 s v2 v,
      in_astgram a2 s v2 -> v = inr _ v2 -> in_astgram (aAlt a1 a2) s v
| InaStar_eps : forall a s v, s = nil -> v = nil -> in_astgram (aStar a) s v
| InaStar_cons :
    forall a s1 v1 s2 v2 s v,
      in_astgram a s1 v1 -> in_astgram (aStar a) s2 v2 ->
      s1 <> nil -> s = s1 ++ s2 -> v = v1::v2 -> in_astgram (aStar a) s v.
Hint Constructors in_astgram.

Definition af_pair (t:type) := {a : astgram & astgram_type a ->> t }.
Definition af (t:type) (a:astgram) (f:astgram_type a ->> t) : af_pair t :=
  existT _ a f.

Definition in_af t (e: af_pair (List_t t)) cs v :=
  match e with
    | existT ag x => exists v', in_astgram ag cs v' /\ In v (xinterp x v')
  end.

Definition xsingle {t1 t2:type} : (t1 ->> t2) -> t1 ->> List_t t2 :=
  fun f => xcons f xempty.

Section BALANCE.
  Variable A : Type.
  Variable B : Type.
  Variable node : B -> B -> B.
  Variable singleton : A -> B.
  Variable emp : B.

  Fixpoint merge_adj (xs:list B) : list B :=
    match xs with
      | nil => nil
      | x::nil => x::nil
      | x::y::rest => (node x y)::(merge_adj rest)
    end.

  Require Import Recdef Omega.

  Lemma balance_lt (l:list B) (x b:B) : length (merge_adj (x::b::l)) < length (x::b::l).
  Proof.
    assert ((forall b,length (merge_adj (b::l)) <= length (b::l)) /\
            (forall x b, length (merge_adj (x::b::l)) < length (x::b::l))).
    intros ; subst.
    induction l ; intros ; split ; auto. destruct IHl. intro. specialize (H0 b0 a).
    omega. intros. simpl. destruct IHl. specialize (H a). simpl in H. omega.
    destruct H. eapply H0.
  Qed.

  Function balance' (xs:list B) {measure length xs} : B :=
  match xs with
    | nil => emp
    | x::nil => x
    | xs' => balance' (merge_adj xs')
  end.
  intros ; subst ; eapply balance_lt.
  Defined.

  Definition balance (xs:list A) : B :=
    balance' (List.map singleton xs).
End BALANCE.

Fixpoint sum_type (ags : list astgram) : type :=
  match ags with
    | nil => Void_t
    | a::rest => Sum_t (astgram_type a) (sum_type rest)
  end.

Fixpoint prod_type (ags : list astgram) : type :=
  match ags with
    | nil => Unit_t
    | a::rest => Pair_t (astgram_type a) (prod_type rest)
  end.

Definition af_sum t := {ags : list astgram & sum_type ags ->> t}.
Definition afsl {t} (ags : list astgram) (f : sum_type ags ->> t) :
  af_sum t := existT _ ags f.
Definition af_prod t := {ags : list astgram & prod_type ags ->> t}.
Definition afpl {t} (ags : list astgram) (f : prod_type ags ->> t) :
  af_prod t := existT _ ags f.

Fixpoint append_cat (p1s p2s:list astgram) :
  af_prod (List_t (Pair_t (prod_type p1s) (prod_type p2s))) :=
  match p1s return af_prod (List_t (Pair_t (prod_type p1s) (prod_type p2s))) with
    | nil => afpl p2s (xsingle (xpair xunit xid))
    | p::p1s' =>
      let (ps, f) := append_cat p1s' p2s in
      afpl (p::ps)
           (xcomp (xpair xfst (xcomp xsnd f))
                  (xmapenv (xpair (xpair xfst (xcomp xsnd xfst)) (xcomp xsnd xsnd))))
  end.

Definition re_cat' : forall (ps:list astgram), af_pair (prod_type ps).
  refine (fix re_cat' (ps:list astgram) : af_pair (prod_type ps) :=
            match ps as ps' return af_pair (prod_type ps') with
              | nil => af aEps xid
              | p::ps' =>
                match ps' as qs return (qs = ps') -> af_pair (prod_type (p::qs)) with
                  | nil => fun _ => af p (xpair xid xunit)
                  | qs =>
                    match re_cat' ps' return (qs = ps') -> af_pair (prod_type (p::qs)) with
                      | existT a f => fun H => af (aCat p a) _
                    end
                end eq_refl
            end). simpl.
refine (xcoerce (xpair xfst (xcomp xsnd f)) eq_refl _).
rewrite <- H. auto.
Defined.

Fixpoint merge_pairs_dep (al : list astgram) : af_sum (sum_type al) :=
  match al return af_sum (sum_type al) with
    | nil => afsl nil xid
    | a1::al' =>
      match al' return af_sum (sum_type (a1::al')) with
        | nil => afsl (a1::nil) xid
        | a2::al'' =>
          let (b, f) := merge_pairs_dep al'' in
          afsl ((aAlt a1 a2)::b)
               (xmatch (xmatch xinl (xcomp xinl xinr)) (xcomp f (xcomp xinr xinr)))
      end
  end.

Definition get_sum_list {t} (af : af_sum t) : list astgram :=
  let (al,_) := af in al.

Lemma dep_balance_lt : forall (l:list astgram) (a1 a2:astgram),
  length (get_sum_list (merge_pairs_dep (a1::a2::l))) < length (a1::a2::l).
Proof.
  assert (forall l, (get_sum_list (merge_pairs_dep l)) = (merge_adj aAlt l) /\
                    forall a, (get_sum_list (merge_pairs_dep (a::l))) =
                              (merge_adj aAlt (a::l))).
  induction l ; auto. destruct IHl ; split ; auto. simpl.
  unfold get_sum_list in H. destruct (merge_pairs_dep l). simpl. subst. auto.
  intros. specialize (H (a1::a2::l)). destruct H. rewrite H. apply balance_lt.
Qed.

Function re_alt' (ps:list astgram) {measure length ps} : af_pair (sum_type ps) :=
  match ps return af_pair (sum_type ps) with
    | nil => af aZero xid
    | x::nil => af x xinl
    | ps' => let (xs,f) := merge_pairs_dep ps' in
             let (a,g) := re_alt' xs in
             af a (xcomp g f)
  end.
  intros ; subst. specialize (dep_balance_lt l0 x a). rewrite teq1. simpl. auto.
Defined.

(*
Definition re_alt' : forall (ps:list astgram), af_pair (sum_type ps).
  refine (fix re_alt' (ps:list astgram) : af_pair (sum_type ps) :=
            match ps as ps' return af_pair (sum_type ps') with
              | nil => af aZero xid
              | p::ps' =>
                match ps' as qs return (qs = ps') -> af_pair (sum_type (p::qs)) with
                  | nil => fun _ => af p xinl
                  | qs =>
                    match re_alt' ps' return (qs = ps') -> af_pair (sum_type (p::qs)) with
                      | existT a f => fun H => af (aAlt p a) _
                    end
                end eq_refl
            end).
  subst. rewrite H. simpl. refine (xmatch xinl (xcomp f xinr)).
Defined.
*)

Definition re_cat {t} (ps : list astgram) (f: prod_type ps ->> t) : af_pair t :=
  let (a,g) := re_cat' ps in af a (xcomp g f).

Definition re_alt {t} (ps : list astgram) (f: sum_type ps ->> t) : af_pair t :=
  let (a,g) := re_alt' ps in af a (xcomp g f).

Definition merge_alt : forall (p1s p2s: list astgram),
                         af_sum (List_t (Sum_t (sum_type p1s) (sum_type p2s))).
refine (fix merge_alt (p1s : list astgram) :
          forall p2s, af_sum (List_t (Sum_t (sum_type p1s) (sum_type p2s))) :=
          match p1s return
                forall p2s, af_sum (List_t (Sum_t (sum_type p1s) (sum_type p2s))) with
            | nil => fun p2s => afsl p2s (xsingle xinr)
            | p1::p1s' =>
              fix merge_alt_aux (p2s:list astgram) :
                af_sum (List_t (Sum_t (sum_type (p1::p1s')) (sum_type p2s))) :=
              match p2s as p2s' return
                    af_sum (List_t (Sum_t (sum_type (p1::p1s')) (sum_type p2s'))) with
                | nil => afsl (p1::p1s') (xsingle xinl)
                | p2::p2s' =>
                  match astgram_cmp p1 p2 as x return
                        (astgram_cmp p1 p2 = x) ->
                        af_sum (List_t (Sum_t (sum_type (p1::p1s')) (sum_type (p2::p2s'))))
                  with
                    | Eq =>
                      fun H =>
                        let (ps, f) := merge_alt p1s' p2s' in
                        afsl (p1::ps) _
                    | Lt =>
                      fun H =>
                        let (ps, f) := merge_alt p1s' (p2::p2s') in
                        afsl (p1::ps)
                             (xmatch (xsingle (xcomp xinl xinl))
                                     (xcomp f (xmap (xmatch (xcomp xinr xinl) xinr))))
                    | Gt =>
                      fun H =>
                        let (ps,f) := merge_alt_aux p2s' in
                        afsl (p2::ps)
                             (xmatch (xsingle (xcomp xinl xinr))
                                     (xcomp f (xmap (xmatch xinl (xcomp xinr xinr)))))
                  end eq_refl
              end
          end) ; simpl.
rewrite ((astgram_eq_corr p1 p2) H) ;
refine (xmatch (xcons (xcomp xinl xinl)
                      (xcons (xcomp xinl xinr) xempty))
               (xcomp f (xmap (xmatch (xcomp xinr xinl) (xcomp xinr xinr))))).
Defined.

Fixpoint flatten_alt (a : astgram) : af_sum (List_t (astgram_type a)) :=
  match a return af_sum (List_t (astgram_type a)) with
    | aAlt a1 a2 =>
      let (p1s,f1s) := flatten_alt a1 in
      let (p2s,f2s) := flatten_alt a2 in
      let (a',f) := merge_alt p1s p2s in
      afsl a' (xcomp f (xcomp (xmap (xmatch (xcomp f1s (xmap xinl))
                                            (xcomp f2s (xmap xinr)))) xflatten))
    | aZero => afsl nil (xsingle xid)
    | a' => afsl (a'::nil) (xmatch (xsingle xid) xzero)
  end.

Fixpoint flatten_cat (a:astgram) : af_prod (List_t (astgram_type a)) :=
  match a return af_prod (List_t (astgram_type a)) with
    | aEps => afpl nil (xsingle xid)
    | aCat a1 a2 =>
      let (p1s,f1s) := flatten_cat a1 in
      let (p2s,f2s) := flatten_cat a2 in
      let (ps, f) := append_cat p1s p2s in
      afpl ps (xcomp f (xcomp (xcomp (xmap (xpair (xcomp xfst f1s)
                                                  (xcomp xsnd f2s)))
                                     (xmap xcross)) xflatten))
    | a' => afpl (a'::nil) (xsingle xfst)
  end.

Fixpoint opt_ag (a:astgram) : af_pair (List_t (astgram_type a)) :=
  match a with
    | aAlt a1 a2 =>
      let (a1', f1) := opt_ag a1 in
      let (a2', f2) := opt_ag a2 in
      let (p1s, f1s) := flatten_alt a1' in
      let (p2s, f2s) := flatten_alt a2' in
      let (p, f) := merge_alt p1s p2s in
      re_alt p
             (xcomp f (xcomp
                         (xmap (xmatch (xcomp (xthen f1s f1) (xmap xinl))
                                       (xcomp (xthen f2s f2) (xmap xinr)))) xflatten))
    | aCat a1 a2 =>
      let (a1', f1) := opt_ag a1 in
      let (a2', f2) := opt_ag a2 in
      match a1' return af_pair (List_t (astgram_type (aCat a1 a2))) with
        | aZero => af aZero xzero
        | b1 =>
          match a2' return af_pair (List_t (astgram_type (aCat a1 a2))) with
            | aZero => af aZero xzero
            | b2 =>
              let (p1s, f1s) := flatten_cat b1 in
              let (p2s, f2s) := flatten_cat b2 in
              let (p, f) := append_cat p1s p2s in
              re_cat p
                     (xcomp f (xcomp (xmap (xpair (xcomp xfst (xthen f1s f1))
                                                  (xcomp xsnd (xthen f2s f2))))
                                     (xcomp (xmap xcross) xflatten)))
            end
      end
    | aStar a1 =>
      let (a', f) := opt_ag a1 in
      match a' return astgram_type a' ->> List_t (astgram_type a1) ->
                      af_pair (List_t (astgram_type (aStar a1)))
      with
        | aZero => fun _ => af aEps (xsingle xempty)
        | aStar a'' => fun f1 => af (aStar a'')
                                    (xcomp f1 (xcons xid (xcons xempty xempty)))
        | a'' => fun f1 => af (aStar a'') (xmap f1)
      end f
    | a' => af a' (xsingle xid)
  end.

Definition opt_af {t} (a:astgram) (f:astgram_type a ->> List_t t):af_pair (List_t t) :=
  let (a',f1) := opt_ag a in
  af a' (xopt (xthen f1 f)).

Fixpoint null_and_split (a:astgram): af_pair (List_t (astgram_type a)) :=
  match a return af_pair (List_t (astgram_type a)) with
    | aEps => af aEps (xsingle xid)
    | aZero => af aZero xempty
    | aChar c => af aZero xempty
    | aAny => af aZero xempty
    | aAlt a11 a12 =>
      let (a11', f1) := null_and_split a11 in
      let (a12', f2) := null_and_split a12 in
      opt_af (aAlt a11' a12')
             (xmatch  (xcomp f1 (xmap xinl)) (xcomp f2 (xmap xinr)))
    | aCat a11 a12 =>
      let (a11', f1) := null_and_split a11 in
      match a11' with
        | aZero => af aZero xempty
        | a11'' =>
          let (a12', f2) := null_and_split a12 in
          opt_af (aCat a11'' a12')
                 (xcomp (xpair (xcomp xfst f1) (xcomp xsnd f2)) xcross)
      end
    | aStar a11 => af aEps (xsingle xempty)
  end.

Fixpoint deriv_and_split (a:astgram) (c:char_t) : af_pair (List_t (astgram_type a)) :=
  match a return af_pair (List_t (astgram_type a)) with
    | aEps => af aZero xempty
    | aZero => af aZero xempty
    | aChar c' =>
      match char_cmp c c' with
          | Eq => af aEps (xsingle (xchar c))
          | _ => af aZero xempty
      end
    | aAny => af aEps (xsingle (xchar c))
    | aAlt ag11 ag12 =>
      let (ag11', f1) := deriv_and_split ag11 c in
      let (ag12', f2) := deriv_and_split ag12 c in
      opt_af (aAlt ag11' ag12')
             (xmatch (xcomp f1 (xmap xinl)) (xcomp f2 (xmap xinr)))
    | aCat ag11 ag12 =>
      let (ag11', f1) := deriv_and_split ag11 c in
      let (ag_left, f_left) := opt_ag (aCat ag11' ag12) in
      let (ag11null', fnull) := null_and_split ag11 in
      match ag11null' with
        | aZero =>
          opt_af ag_left
                 (xcomp f_left (xcomp (xmap (xcrossmap f1 (xsingle xid))) xflatten))
        | ag11null =>
          let (ag12', f2) := deriv_and_split ag12 c in
          let (ag_right, f_right) := opt_ag (aCat ag11null ag12') in
          opt_af (aAlt ag_left ag_right)
                 (xmatch
                    (xcomp f_left (xcomp (xmap (xcrossmap f1 (xsingle xid))) xflatten))
                    (xcomp f_right (xcomp (xmap (xcrossmap fnull f2)) xflatten)))
      end
    | aStar ag0 =>
      let (ag0', f) := deriv_and_split ag0 c in
      opt_af (aCat ag0' (aStar ag0))
             (xcomp (xpair xsnd (xcomp xfst f)) (xmapenv (xcons xsnd xfst)))
  end.

Definition cross_prod t1 t2 (xs:list t1) (ys:list t2) : list (t1 * t2) :=
  (fold_right (fun v a => (map (fun w => (v,w)) ys) ++ a) nil xs).

Fixpoint astgram_extract_nil (a:astgram) : list (interp (astgram_type a)) :=
  match a return list (interp (astgram_type a)) with
    | aEps => tt::nil
    | aZero => nil
    | aChar _ => nil
    | aAny => nil
    | aCat ag1 ag2 => cross_prod (astgram_extract_nil ag1) (astgram_extract_nil ag2)
    | aAlt ag1 ag2 =>
      (List.map (fun x => inl _ x) (astgram_extract_nil ag1)) ++
      (List.map (fun x => inr _ x) (astgram_extract_nil ag2))
    | aStar ag => nil::nil
  end.

Fixpoint derivs_and_split (a:astgram) (cs:list char_t) :
  af_pair (List_t (astgram_type a)) :=
  match cs with
    | nil => af a (xsingle xid)
    | c::cs' => let (a1, x1) := deriv_and_split a c in
                let (a2, x2) := derivs_and_split a1 cs' in
                af a2 (xthen x2 x1)
  end.

(*********************************************)
(* Proofs                                    *)
(*********************************************)
Fixpoint mrg_alt (p1s : list astgram) : list astgram -> list astgram :=
  match p1s with
    | nil => fun p2s => p2s
    | p1::p1s' =>
      (fix mrg_alt_aux (p2s:list astgram) : list astgram :=
         match p2s with
           | nil => p1::p1s'
           | p2::p2s' =>
             match astgram_cmp p1 p2 with
               | Eq => let ps := mrg_alt p1s' p2s' in p1::ps
               | Lt => let ps := mrg_alt p1s' (p2::p2s') in (p1::ps)
               | Gt => let ps := mrg_alt_aux p2s' in (p2::ps)
             end
         end)
  end.

Lemma mrg_alt_corr p1s : forall p2s,
  match merge_alt p1s p2s with
      | existT ps _ => ps = mrg_alt p1s p2s
  end.
Proof.
  induction p1s ; [simpl ; auto | idtac].
  induction p2s ; [simpl ; auto | idtac].
  simpl. generalize (astgram_eq_corr a a0). generalize (astgram_cmp a a0) as c.
  destruct c  ; intros.
  specialize (IHp1s p2s). destruct (merge_alt p1s p2s). simpl. congruence.
  specialize (IHp1s (a0::p2s)).
  destruct (merge_alt p1s (a0::p2s)). simpl. congruence. simpl in *.
  match goal with
      | [ H : match ?e1 with | existT _ _ => _ end |- _] => remember e1
  end.
  destruct a1. simpl. congruence.
Qed.

Fixpoint flat_alt (a:astgram) : list astgram :=
  match a with
    | aAlt a1 a2 =>
      let p1s := flat_alt a1 in
      let p2s := flat_alt a2 in
      mrg_alt p1s p2s
    | aZero => nil
    | a' => (a'::nil)
  end.

Lemma flat_alt_corr :
  forall a,
    match flatten_alt a with
      | existT ps _ => ps = flat_alt a
    end.
Proof.
  induction a ; simpl ; auto.
  destruct (flatten_alt a1). destruct (flatten_alt a2).
  generalize (mrg_alt_corr x x1). destruct (merge_alt x x1).
  intros ; simpl. congruence.
Qed.

Fixpoint flat_cat (a:astgram) : list astgram :=
  match a with
    | aCat a1 a2 =>
      let p1s := flat_cat a1 in
      let p2s := flat_cat a2 in
      p1s ++ p2s
    | aEps => nil
    | a' => (a'::nil)
  end.

Lemma append_cat_corr :
  forall (as1 as2:list astgram),
    match append_cat as1 as2 with
      | existT ps _ => ps = as1 ++ as2
    end.
Proof.
  induction as1. simpl ; auto. simpl. intros. specialize (IHas1 as2).
  destruct (append_cat as1 as2). simpl. congruence.
Qed.

Lemma flat_cat_corr (a:astgram) :
  match flatten_cat a with
      | existT ps _ => ps = flat_cat a
  end.
Proof.
  induction a ; simpl ; auto. destruct (flatten_cat a1). destruct (flatten_cat a2).
  generalize (append_cat_corr x x1). destruct (append_cat x x1). intros. simpl.
  congruence.
Qed.

Fixpoint recat (ps:list astgram) : astgram :=
  match ps with
    | nil => aEps
    | p::nil => p
    | p::ps' => aCat p (recat ps')
  end.

Definition realt (ps:list astgram) : astgram :=
  balance aAlt (fun x => x) aZero ps.

Lemma recat_corr ps :
  match re_cat' ps with
    | existT ps1 _ => ps1 = recat ps
  end.
Proof.
  induction ps ; simpl ; auto. destruct ps. simpl ; auto.
  destruct (re_cat' (a0::ps)). simpl in *. congruence.
Qed.

Lemma merge_adj_corr' n :
  forall zs, length zs < n ->
  match merge_pairs_dep zs with
      | existT ys _ => ys = merge_adj aAlt zs
  end.
Proof.
  induction n ; simpl ; intros. omega.
  destruct zs. simpl ; auto. simpl in *. assert (length zs < n). omega.
  destruct zs ; simpl ; auto. simpl in *. assert (length zs < n). omega.
  specialize (IHn _ H1). destruct (merge_pairs_dep zs). simpl. congruence.
Qed.

Lemma merge_adj_corr zs :
  match merge_pairs_dep zs with
      | existT ys _ => ys = merge_adj aAlt zs
  end.
Proof.
  assert (length zs < S(length zs)). omega. eapply merge_adj_corr' ; eauto.
Qed.

Lemma map_id {A} (xs:list A) :
  List.map (fun x => x) xs = xs.
Proof.
  induction xs ; simpl ; auto ; rewrite IHxs ; auto.
Qed.

Lemma realt_corr' n :
  forall ps, length ps < n ->
  match re_alt' ps with
      | existT ps1 _ => ps1 = realt ps
  end.
Proof.
 induction n ; simpl ; intros. omega.
 destruct ps ; simpl ; auto. destruct ps. simpl ; auto.
 rewrite re_alt'_equation. unfold realt. unfold balance.
 rewrite balance'_equation. rewrite map_id.
 generalize (merge_adj_corr (a::a0::ps)).
 destruct (merge_pairs_dep (a::a0::ps)). intros ; subst.
 assert (length (merge_adj aAlt (a::a0::ps)) < n). generalize (balance_lt aAlt ps a a0).
 simpl in *. intros ; omega. specialize (IHn _ H0).
 destruct (re_alt' (merge_adj aAlt (a::a0::ps))). subst. simpl. unfold realt.
 unfold balance. rewrite map_id. auto.
Qed.

Lemma realt_corr ps :
  match re_alt' ps with
    | existT ps1 _ => ps1 = realt ps
  end.
Proof.
  eapply (@realt_corr' (S (length ps))). omega.
Qed.

Definition appcat (p1s p2s:list astgram) := p1s ++ p2s.

Lemma appcat_corr p1s :
  forall p2s, match append_cat p1s p2s with
                | existT ps _ => ps = appcat p1s p2s
              end.
Proof.
  induction p1s ; simpl ; auto. intro. specialize (IHp1s p2s).
  destruct (append_cat p1s p2s). simpl ; congruence.
Qed.

Fixpoint opt_a (a:astgram) : astgram :=
  match a with
    | aAlt a1 a2 =>
      let a1' := opt_a a1 in
      let a2' := opt_a a2 in
      let p1s := flat_alt a1' in
      let p2s := flat_alt a2' in
      let p := mrg_alt p1s p2s in
      balance aAlt (fun x => x) aZero p
    | aCat a1 a2 =>
      let a1' := opt_a a1 in
      let a2' := opt_a a2 in
      match a1' with
        | aZero => aZero
        | b1 =>
          match a2' with
              | aZero => aZero
              | b2 =>
                let p1s := flat_cat b1 in
                let p2s := flat_cat b2 in
                let p := appcat p1s p2s in
                recat p
          end
      end
    | aStar a1 =>
      let a1' := opt_a a1 in
      match a1' with
        | aZero => aEps
        | aStar a'' => aStar a''
        | a'' => aStar a''
      end
    | a' => a'
  end.

Lemma opt_a_corr :
  forall a, match opt_ag a with
              | existT a' _ => a' = opt_a a
            end.
Proof.
  induction a ; simpl ; auto. destruct (opt_ag a1) ; destruct (opt_ag a2) ; simpl.
  rewrite <- IHa1 ; rewrite <- IHa2.
  generalize (flat_cat_corr x) (flat_cat_corr x1). destruct (flatten_cat x) ;
  destruct (flatten_cat x1). intros. rewrite <- H ; rewrite <- H0.
  generalize (appcat_corr x3 x5). destruct (append_cat x3 x5). intro. rewrite <- H1.
  generalize (recat_corr x7). unfold re_cat. destruct (re_cat' x7). intros. rewrite <- H2.
  destruct x ; destruct x1 ; simpl ; auto.
  destruct (opt_ag a1) ; destruct (opt_ag a2) ; simpl ; rewrite <- IHa1 ; rewrite <- IHa2.
  generalize (flat_alt_corr x) (flat_alt_corr x1) ; destruct (flatten_alt x) ;
  destruct (flatten_alt x1) ; intros. rewrite <- H ; rewrite <- H0.
  generalize (mrg_alt_corr x3 x5). destruct (merge_alt x3 x5) ; intros. rewrite <- H1.
  generalize (realt_corr x7). unfold re_alt. destruct (re_alt' x7). intros. simpl.
  rewrite H2. auto.
  destruct (opt_ag a) ; simpl. rewrite <- IHa. destruct x ; simpl ; auto.
Qed.

Fixpoint list_all {A} (P:A -> Prop) (xs: list A) : Prop :=
  match xs with
    | nil => True
    | h::t => P h /\ list_all P t
  end.

Lemma list_all_app {A} (P:A->Prop) (xs ys:list A) :
  list_all P xs -> list_all P ys -> list_all P (xs ++ ys).
Proof.
  induction xs ; auto. simpl. intros. destruct H. split ; auto.
Qed.

Lemma list_all_imp {A} (P1:A->Prop) (P2:A->Prop) :
  (forall x, P1 x -> P2 x) -> forall xs, list_all P1 xs -> list_all P2 xs.
Proof.
  intro ; induction xs ; crush.
Qed.

Fixpoint increasing (xs:list astgram) : Prop :=
  match xs with
    | nil => True
    | x::xs => increasing xs /\ list_all (fun y => astgram_cmp x y = Lt) xs
  end.

Fixpoint wf_astgram (a:astgram) : Prop :=
  match a with
    | aAlt a1 a2 =>
      a1 <> aZero /\ a2 <> aZero /\
      wf_astgram a1 /\ wf_astgram a2 /\ increasing (flat_alt a1 ++ flat_alt a2)
    | aCat a1 a2 =>
      (match a1 with aEps => False | aCat _ _ => False | aZero => False | _ => True end) /\
      (match a2 with aEps => False | aZero => False | _ => True end) /\
      wf_astgram a1 /\ wf_astgram a2
    | aStar a1 =>
      (match a1 with aZero => False | aStar _ => False | _ => True end) /\ wf_astgram a1
    | _ => True
  end.

Ltac mycrush :=
  simpl in * ;
  match goal with
    | [ H : _ /\ _ |- _ ] => destruct H ; crush
    | [ H : False |- _ ] => contradiction H
    | [ |- forall _,_ ] => intro ; crush
    | [ |- _ /\ _ ] => split ; crush
    | [ |- _ <> _ ] => discriminate
    | _ => eauto
  end.

Lemma recat_wf (xs:list astgram) :
  list_all (fun x => wf_astgram x /\
                     match x with aEps => False | aZero => False | aCat _ _ => False
                               | _ => True
                     end) xs -> wf_astgram (recat xs).
Proof.
  induction xs ; crush. specialize (IHxs H0). destruct xs ; auto. repeat split ; auto.
  simpl in *. destruct xs ; auto. destruct H0. destruct H0. destruct a0 ; auto.
Qed.

Lemma flat_cat_wf (a:astgram) :
  a <> aZero ->
  wf_astgram a ->
  list_all (fun x : astgram =>
      wf_astgram x /\
      match x with
      | aAny => True
      | aEps => False
      | aZero => False
      | aChar _ => True
      | aCat _ _ => False
      | aAlt _ _ => True
      | aStar _ => True
      end) (flat_cat a).
Proof.
  induction a ; crush. assert (a1 <> aZero). destruct a1 ; try congruence.
  specialize (IHa1 H4 H2). assert (a2 <> aZero). destruct a2 ; try congruence.
  specialize (IHa2 H5 H3). apply list_all_app; auto.
Qed.

Definition notadd (a:astgram) : Prop :=
  match a with
      | aZero => False
      | aAlt _ _ => False
      | _ => True
  end.

Lemma mrg_alt_wf (a1s:list astgram) :
  list_all notadd a1s -> increasing a1s -> list_all wf_astgram a1s ->
  forall a2s,
    list_all notadd a2s -> increasing a2s -> list_all wf_astgram a2s ->
    list_all notadd (mrg_alt a1s a2s) /\ increasing (mrg_alt a1s a2s) /\
    list_all wf_astgram (mrg_alt a1s a2s) /\
    forall a, list_all (fun y => astgram_cmp a y = Lt) a1s ->
              list_all (fun y => astgram_cmp a y = Lt) a2s ->
              list_all (fun y => astgram_cmp a y = Lt) (mrg_alt a1s a2s).
Proof.
  induction a1s. simpl ; intros ; split ; auto.
  simpl. intros. destruct H. destruct H0. destruct H1.
  induction a2s. crush.
  simpl in *. destruct H2. destruct H3. destruct H4. specialize (IHa2s H8 H3 H10).
  specialize (IHa1s H5 H0 H7). remember (astgram_cmp a a0) as e.
  destruct e.
  Case "Eq".
    clear IHa2s. specialize (IHa1s _ H8 H3 H10) ; crush. apply H14 ; auto.
    rewrite (astgram_eq_corr _ _ (eq_sym Heqe)). auto.
  Case "Lt".
    clear IHa2s. specialize (IHa1s (a0::a2s) (conj H2 H8) (conj H3 H9) (conj H4 H10)).
    crush. rewrite <- Heqe. apply H14 ; crush. rewrite <- Heqe.
    apply (@list_all_imp _ (fun y => astgram_cmp a0 y = Lt)) ; auto. intros.
    eapply astgram_cmp_trans. eauto. auto.
  Case "Gt".
    clear IHa1s. assert (astgram_cmp a0 a = Lt). rewrite (astgram_cmp_sym a a0).
    rewrite <- Heqe ; auto. crush. apply H15 ; crush.
    apply (@list_all_imp _ (fun y => astgram_cmp a y = Lt)) ; auto. intros.
    eapply astgram_cmp_trans ; eauto.
Qed.

Lemma flat_alt_wf (a:astgram) :
  wf_astgram a ->
  list_all notadd (flat_alt a) /\ increasing (flat_alt a) /\ list_all wf_astgram (flat_alt a).
Proof.
  induction a ; try (crush ; fail). simpl ; intros. destruct H as [H [H1 [H2 [H3 H4]]]].
  specialize (IHa1 H2). specialize (IHa2 H3). destruct IHa1 as [H5 [H6 H7]].
  destruct IHa2 as [H8 [H9 H10]].
  generalize (mrg_alt_wf _ H5 H6 H7 _ H8 H9 H10). crush.
Qed.

Lemma merge_adj_nz' (n:nat) :
  forall l, length l < n -> list_all (fun x => x <> aZero) l ->
            list_all (fun x => x <> aZero) (merge_adj aAlt l).
Proof.
  induction n ; crush. destruct l ; crush. destruct l ; crush.
  apply IHn; crush.
Qed.

Lemma merge_adj_nz l : list_all (fun x => x <> aZero) l ->
                       list_all (fun x => x <> aZero) (merge_adj aAlt l).
Proof.
  apply (@merge_adj_nz' (S (length l))) ; crush.
Qed.

Lemma app_list_all {A} (P:A->Prop) (xs ys:list A) :
  list_all P (xs ++ ys) -> list_all P xs /\ list_all P ys.
Proof.
  induction xs. crush. simpl. intros. destruct H. specialize (IHxs H0). crush.
Qed.

Lemma increasing_app :
  forall (l1 l2:list astgram),
    increasing (l1 ++ l2) -> increasing l1 /\ increasing l2.
Proof.
  induction l1 ; crush. destruct (IHl1 _ H) ; auto. apply (proj1 (app_list_all _ _ _ H0)).
  apply (proj2 (IHl1 _ H)).
Qed.

Lemma inc_mrg_alt :
  forall as1 as2,
    increasing (as1 ++ as2) ->
    (mrg_alt as1 as2) = as1 ++ as2.
Proof.
  induction as1 ; crush. generalize H H0 ; clear H H0. induction as2. crush.
  rewrite <- app_nil_end. auto. intros. generalize (app_list_all _ _ _ H0). crush.
Qed.

Lemma fold_flat_merge' n :
  forall l, length l < n ->
  increasing (fold_right (fun a xs => flat_alt a ++ xs) nil l) ->
  (fold_right (fun a xs => flat_alt a ++ xs) nil l) =
  (fold_right (fun a xs => flat_alt a ++ xs) nil (merge_adj aAlt l)).
Proof.
  induction n ; crush. destruct l ; crush. destruct l ; crush. rewrite <- app_ass in H0.
  generalize (increasing_app _ _ H0). intro H1 ; destruct H1.
  rewrite IHn ; auto. rewrite inc_mrg_alt. rewrite <- app_ass. auto. auto. omega.
Qed.

Lemma fold_flat_merge l :
  increasing (fold_right (fun a xs => flat_alt a ++ xs) nil l) ->
  (fold_right (fun a xs => flat_alt a ++ xs) nil l) =
  (fold_right (fun a xs => flat_alt a ++ xs) nil (merge_adj aAlt l)).
Proof.
  apply (@fold_flat_merge' (S (length l))) ; crush.
Qed.

Lemma merge_adj_wf' n :
  forall l, length l < n ->
            list_all wf_astgram l ->
            list_all (fun x => x <> aZero) l ->
            increasing (fold_right (fun a xs => flat_alt a ++ xs) nil l) ->
            list_all wf_astgram (merge_adj aAlt l).
Proof.
  induction n ; crush. destruct l ; crush. destruct l ; crush.
  rewrite <- app_ass in H2. apply (proj1 (increasing_app _ _ H2)).
  apply IHn ; crush. rewrite <- app_ass in H2. apply (proj2 (increasing_app _ _ H2)).
Qed.

Lemma merge_adj_wf l :
  list_all wf_astgram l ->
  list_all (fun x => x <> aZero) l ->
  increasing (fold_right (fun a xs => flat_alt a ++ xs) nil l) ->
  list_all wf_astgram (merge_adj aAlt l).
Proof.
  apply (@merge_adj_wf' (S (length l))) ; crush.
Qed.

Lemma balance_wf' (n:nat) :
  forall (l:list astgram),
    length l < n -> list_all (fun x => x <> aZero) l ->
    list_all wf_astgram l ->
    increasing (fold_right (fun a xs => (flat_alt a) ++ xs) nil l) ->
    wf_astgram (balance' aAlt aZero l).
Proof.
  induction n ; crush. rewrite balance'_equation. destruct l ; crush.
  destruct l ; crush. rewrite <- app_ass in H2. generalize (increasing_app _ _ H2). crush.
  apply IHn. generalize (balance_lt aAlt l a a0). simpl in *. omega.
  crush. apply merge_adj_nz ; crush. simpl. crush.
  apply merge_adj_wf ; crush. simpl. rewrite inc_mrg_alt ; crush.
  rewrite <- fold_flat_merge ; auto.
Qed.

Lemma balance_wf l :
  list_all (fun x => x <> aZero) l ->
    list_all wf_astgram l ->
    increasing (fold_right (fun a xs => (flat_alt a) ++ xs) nil l) ->
    wf_astgram (balance' aAlt aZero l).
Proof.
  apply (@balance_wf' (S (length l))) ; crush.
Qed.

Lemma mrg_alt_nz l1 :
  list_all notadd l1 ->
  forall l2, list_all notadd l2 -> list_all notadd (mrg_alt l1 l2).
Proof.
  induction l1 ; crush ;induction l2 ; crush ; destruct (astgram_cmp a a0) ; crush.
  apply IHl1 ; crush.
Qed.

Lemma fold_flat l :
  increasing l -> list_all notadd l ->
  fold_right (fun a xs => flat_alt a ++ xs) nil l = l.
Proof.
  induction l ; crush. assert (flat_alt a = (a::nil)). destruct a ; crush.
  rewrite H3. crush.
Qed.

Lemma opt_wf (a:astgram) : wf_astgram (opt_a a).
Proof.
  induction a ; try (crush ; fail).
  Case "aCat".
    assert (opt_a a1 = aZero \/ opt_a a1 <> aZero).
    destruct (opt_a a1) ; try (right ; discriminate) ; left ; auto. destruct H.
    simpl ; rewrite H ; simpl ; auto.
    assert (opt_a a2 = aZero \/ opt_a a2 <> aZero).
    destruct (opt_a a2) ; try (right ; discriminate) ; left ; auto. destruct H0.
    simpl ; rewrite H0 ; destruct (opt_a a1) ; simpl ; auto.
    replace (opt_a (aCat a1 a2)) with
    (recat (appcat (flat_cat (opt_a a1))(flat_cat (opt_a a2))));
      [idtac | simpl ; destruct (opt_a a1) ; destruct (opt_a a2) ; auto ; congruence].
    apply recat_wf. unfold appcat. apply list_all_app. apply (flat_cat_wf H IHa1).
    apply (flat_cat_wf H0 IHa2). simpl.
  Case "aAlt".
    generalize (flat_alt_wf _ IHa1) (flat_alt_wf _ IHa2) ; crush. unfold balance.
    rewrite map_id. specialize (mrg_alt_wf _ H H3 H4 _ H0 H1 H2). crush.
    apply balance_wf ; crush. apply (list_all_imp notadd). destruct x ; crush.
    apply mrg_alt_nz ; auto. rewrite fold_flat ; crush.
  Case "aStar".
    simpl. destruct (opt_a a) ; crush.
Qed.

Lemma notadd_flat (a:astgram) :
  wf_astgram a -> list_all notadd (flat_alt a).
Proof.
  induction a ; crush. apply mrg_alt_nz ; crush.
Qed.

Lemma flat_balance' n :
  forall l,
    length l < n ->
    list_all (fun x => x <> aZero) l ->
    list_all wf_astgram l -> increasing l ->
    flat_alt (balance' aAlt aZero l) = fold_right (fun a x => flat_alt a ++ x) nil l.
Proof.
  induction n; crush.
  destruct l ; crush ; destruct l. destruct a; crush.
  apply app_nil_end. rewrite balance'_equation. generalize (balance_lt aAlt l a a0).
  intros. rewrite IHn.  Focus 2. crush.
crush.
  rewrite inc_mrg_alt ; crush. rewrite <- fold_flat_merge. auto.

Lemma flat_balance' (a1 a2:astgram) :
  wf_astgram a1 -> wf_astgram a2 ->
  flat_alt (balance' aAlt aZero (mrg_alt (flat_alt a1) (flat_alt a2))) =
  mrg_alt (flat_alt a1) (flat_alt a2).
Proof.
  intros.
  assert (list_all (fun x => x <> aZero) (mrg_alt (flat_alt a1) (flat_alt a2))).
  apply (list_all_imp notadd). destruct x ; crush.
  apply mrg_alt_nz. apply (notadd_flat a1 H). apply (notadd_flat a2 H0).
  generalize H1 ; clear H1. generalize (mrg_alt (flat_alt a1) (flat_alt a2)).
  clear a1 a2 H H0.
  assert (forall n, forall l, length l < n -> list_all (fun x => x <> aZero) l ->
                              flat_alt (balance' aAlt aZero l) = l).
  induction n; crush. destruct l ; crush. destruct l ; crush.
  destruct a ; crush. rewrite balance'_equation. simpl. rewrite IHn ; crush.
*)

Lemma opt_alt_assoc (a1 a2 a3:astgram) :
  opt_a (aAlt a1 (aAlt a2 a3)) = opt_a (aAlt (aAlt a1 a2) a3).
Proof.
  intros.
  generalize (opt_wf a1) (opt_wf a2) (opt_wf a3)
             (opt_wf (aAlt a1 (aAlt a2 a3))) (opt_wf (aAlt (aAlt a1 a2) a3)).
  simpl. generalize (opt_a a1) (opt_a a2) (opt_a a3). clear a1 a2 a3.
  intros a1 a2 a3 H1 H2 H3 H4 H5.
  unfold balance. repeat rewrite map_id.

SearchAbout (notadd (flat_alt _)).
  generalize (fun p1 p2 => mrg_alt_nz (flat_alt a1) p1 (flat_alt a2) p2).
  remember (mrg_alt (flat_alt a1) (flat_alt a2)) as e.
  SearchAbout (mrg_alt _ _).

  unfold balance. repeat rewrite map_id.
  Lemma flat_balance' n :
    forall l, length l < n ->
              list_all wf_astgram l ->
              list_all (fun x => x <> aZero) l ->
              flat_alt (balance' aAlt aZero l) = l.
  Proof.
    induction n ; crush ; destruct l ; crush. rewrite balance'_equation.
    destruct l ; crush. destruct a ; crush.

SearchAbout mrg_alt.

Lemma flatten_re_alt :
  forall (ps1 ps : list astgram),
    length ps <= length ps1 ->
    list_all not_sum ps ->
    match re_alt' ps with
      | existT a _ => match flatten_alt a with
                        | existT ps' _ => ps = ps'
                      end
    end.
Proof.
  induction ps1. simpl. intros. destruct ps. simpl. auto.
  simpl in *. omega. destruct ps. simpl ; auto. rewrite re_alt'_equation.
  destruct ps. simpl. intros. destruct H0. apply (flatten_not_sum a0 H0).
  intros. destruct H0 as [H0 [H1 H2]]. assert (length ps <= length ps1).
  simpl in H. omega. specialize (IHps1 _ H3 H2). simpl (merge_pairs_dep _).

Definition alts := List.fold_right aAlt aZero.
Definition cats := List.fold_right aCat aEps.
Definition ff := aChar false.
Definition tt := aChar true.

Fixpoint xopt' {t1 t2} (n:nat) (x:t1->>t2) : t1->>t2 :=
  match n with
    | 0 => x
    | S m => xopt' m (xopt x)
  end.

Definition foo g n :=
  match deriv_and_split g false with
      | existT a x =>
        let y := xopt' n x in
        (a, show_xform y, xform_count y)
  end.

Definition xs : list astgram :=
  (cats (ff::ff::ff::ff::nil))::
  (cats (ff::tt::ff::tt::nil))::
        (cats (tt::ff::tt::ff::nil))::
        (cats (ff::nil))::
        (cats (ff::tt::nil))::
        (cats (ff::tt::tt::nil))::
        (cats (ff::tt::tt::tt::nil))::
        (cats (ff::tt::tt::tt::tt::nil))::
        (cats (ff::tt::tt::tt::tt::tt::nil))::
        (cats (ff::tt::tt::tt::tt::tt::tt::nil))::
        (cats (ff::tt::tt::tt::tt::tt::tt::tt::nil))::
        nil.

Definition g := balance aAlt (fun x => x) aZero xs.

Time Eval vm_compute in foo g 20.


Require Import Basics.
Require Import Types.

Declare Scope dpath_scope.
Delimit Scope dpath_scope with dpath.

Local Open Scope dpath_scope.

Definition DPath {A} (P : A -> Type) {a0 a1} (p : a0 = a1)
  (b0 : P a0) (b1 : P a1) : Type.
Proof.
  destruct p.
  exact (b0 = b1).
Defined.

(* This allows DPaths to collapse to paths under cbn *)
Arguments DPath _ / _ _ _ : simpl nomatch.

(* Here is an alternative definition of DPath, for now the original suffices *)
(* Definition DPath {A} (P : A -> Type) {a0 a1} (p : a0 = a1)
  (b0 : P a0) (b1 : P a1) := transport P p b0 = b1.  *)

(* We can prove they are equivalent anyway *)
Definition dp_path_transport {A : Type} {P : A -> Type}
           {a0 a1 : A} {p : a0 = a1} {b0 : P a0} {b1 : P a1}
  : transport P p b0 = b1 -> DPath P p b0 b1.
Proof.
  by destruct p.
Defined.

Global Instance isequiv_dp_path_transport {A} (P : A -> Type) {a0 a1}
  (p : a0 = a1) (b0 : P a0) (b1 : P a1)
  : IsEquiv (@dp_path_transport A P a0 a1 p b0 b1).
Proof.
  serapply isequiv_adjointify; by destruct p.
Defined.

Definition equiv_dp_path_transport {A : Type} (P : A -> Type)
           {a0 a1 : A} (p : a0 = a1) (b0 : P a0) (b1 : P a1)
  : transport P p b0 = b1 <~> DPath P p b0 b1
  := Build_Equiv _ _ (@dp_path_transport A P a0 a1 p b0 b1) _.

Global Instance istrunc_dp {A : Type} {P : A -> Type} {n : trunc_index}
 {a0 a1} {p : a0 = a1} {b0 : P a0} {b1 : P a1} `{IsTrunc n.+1 (P a0)}
  `{IsTrunc n.+1 (P a1)} : IsTrunc n (DPath P p b0 b1).
Proof.
  apply (trunc_equiv _ dp_path_transport).
Defined.

Definition dp_ishprop {A : Type} (P : A -> Type) {a0 a1} {p : a0 = a1}
  {b0 : P a0} {b1 : P a1} `{IsHProp (P a0)} `{IsHProp (P a1)}
  : DPath P p b0 b1.
Proof.
  apply dp_path_transport, path_ishprop.
Defined.

(* Here is a notation for DPaths that can make it easier to use *)
Notation "x =[ q ] y" := (DPath (fun t => DPath _ t _ _) q x y) (at level 10)
  : dpath_scope.

(* We have reflexivity for DPaths, this helps coq guess later *)
Definition dp_id {A} {P : A -> Type} {a : A} {x : P a} : DPath P 1 x x := 1%path.

(* Althought 1%dpath is definitionally 1%path, coq cannot guess this so it helps
   to have 1 be a dpath before hand. *)
Notation "1" := dp_id : dpath_scope.

(* DPath induction *)
Definition DPath_ind (A : Type) (P : A -> Type) (P0 : forall (a0 a1 : A)
  (p : a0 = a1) (b0 : P a0) (b1 : P a1), DPath P p b0 b1 -> Type)
  : (forall (x : A) (y : P x), P0 x x 1%path y y 1) ->
    forall (a0 a1 : A) (p : a0 = a1) (b0 : P a0) (b1 : P a1)
    (d : DPath P p b0 b1), P0 a0 a1 p b0 b1 d.
Proof.
  intros X a0 a1 [] b0 b1 []; apply X.
Defined.

(* DPath version of apD *)
Definition dp_apD {A P} (f : forall a, P a) {a0 a1 : A}
  (p : a0 = a1) : DPath P p (f a0) (f a1).
Proof.
  by destruct p.
Defined.

(* which corresponds to ordinary apD *)
Definition dp_path_transport_apD {A P} (f : forall a, P a) {a0 a1 : A} (p : a0 = a1)
  : dp_path_transport (apD f p) = dp_apD f p.
Proof.
  by destruct p.
Defined.

(* A DPath over a constant family is just a path *)
Definition dp_const {A C} {a0 a1 : A} {p : a0 = a1} {x y}
  : (x = y) -> DPath (fun _ => C) p x y.
Proof.
  by destruct p.
Defined.

Global Instance isequiv_dp_const {A C} {a0 a1 : A} {p : a0 = a1} {x y}
  : IsEquiv (@dp_const _ C _ _ p x y).
Proof.
  destruct p; exact _.
Defined.

Definition equiv_dp_const {A C} {a0 a1 : A} {p : a0 = a1} {x y}
  : (x = y) <~> DPath (fun _ => C) p x y
  := Build_Equiv _ _ dp_const _.

(* dp_apD of a non-dependent map is just a constant DPath *)
Definition dp_apD_const {A B} (f : A -> B) {a0 a1 : A}
  (p : a0 = a1) : dp_apD f p = dp_const (ap f p).
Proof.
  by destruct p.
Defined.

(* An alternate version useful for proving recursion computation rules from induction ones *)
Definition dp_apD_const' {A B : Type} {f : A -> B} {a0 a1 : A}
  {p : a0 = a1} : dp_const^-1 (dp_apD f p) = ap f p.
Proof.
  apply moveR_equiv_V.
  apply dp_apD_const.
Defined.

(* Concatenation of dependent paths *)
Definition dp_concat {A} {P : A -> Type} {a0 a1 a2}
  {p : a0 = a1} {q : a1 = a2} {b0 : P a0} {b1 : P a1} {b2 : P a2}
  : DPath P p b0 b1 -> DPath P q b1 b2 -> DPath P (p @ q) b0 b2.
Proof.
  destruct p, q.
  exact concat.
Defined.

(* TODO: Is level correct? *)
Notation "x '@D' y" := (dp_concat x y) (at level 10) : dpath_scope.

(* Inverse of dependent paths *)
Definition dp_inverse {A} {P : A -> Type} {a0 a1} {p : a0 = a1}
  {b0 : P a0} {b1 : P a1} : DPath P p b0 b1 -> DPath P p^ b1 b0.
Proof.
  destruct p.
  exact inverse.
Defined.

(* TODO: Is level correct? *)
Notation "x '^D'" := (dp_inverse x) (at level 20) : dpath_scope.

(* dp_apD distributes over concatenation *)
Definition dp_apD_pp (A : Type) (P : A -> Type) (f : forall a, P a)
  {a0 a1 a2 : A} (p : a0 = a1) (q : a1 = a2)
  : dp_apD f (p @ q) = (dp_apD f p) @D (dp_apD f q).
Proof.
  by destruct p, q.
Defined.

(* dp_apD respects inverses *)
Definition dp_apD_V (A : Type) (P : A -> Type) (f : forall a, P a)
  {a0 a1 : A} (p : a0 = a1) : dp_apD f p^ = (dp_apD f p)^D.
Proof.
  by destruct p.
Defined.

(* dp_const preserves concatenation *)
Definition dp_const_pp {A B : Type} {a0 a1 a2 : A}
  {p : a0 = a1} {q : a1 = a2} {x y z : B} (r : x = y) (s : y = z)
  : dp_const (p:=p @ q) (r @ s) = (dp_const (p:=p) r) @D (dp_const (p:=q) s).
Proof.
  by destruct p,q.
Defined.

Section DGroupoid.

  Context {A} {P : A -> Type} {a0 a1} {p : a0 = a1}
    {b0 : P a0} {b1 : P a1} {dp : DPath P p b0 b1}.

  Definition dp_concat_p1 : (dp @D 1) =[concat_p1 _] dp.
  Proof.
    destruct p.
    apply concat_p1.
  Defined.

  Definition dp_concat_1p : (1 @D dp) =[concat_1p _] dp.
  Proof.
    destruct p.
    apply concat_1p.
  Defined.

  Definition dp_concat_Vp : dp^D @D dp =[concat_Vp _] 1.
  Proof.
    destruct p.
    apply concat_Vp.
  Defined.

  Definition dp_concat_pV : dp @D (dp^D) =[concat_pV _] 1.
  Proof.
    destruct p.
    apply concat_pV.
  Defined.

  Section Concat.

    Context {a2 a3} {q : a1 = a2} {r : a2 = a3}
       {b2 : P a2} {b3 : P a3}
       (dq : DPath P q b1 b2) (dr : DPath P  r b2 b3).

    Definition dp_concat_pp_p
      : ((dp @D dq) @D dr) =[concat_pp_p _ _ _] (dp @D (dq @D dr)).
    Proof.
      destruct p, q, r.
      apply concat_pp_p.
    Defined.

    Definition dp_concat_p_pp
      : (dp @D (dq @D dr)) =[concat_p_pp _ _ _] ((dp @D dq) @D dr).
    Proof.
      destruct p, q, r.
      apply concat_p_pp.
    Defined.

  End Concat.

End DGroupoid.

(* Dependent paths over paths *)
(* These can be found under names such as dp_paths_l akin to transport_paths_l *)

Definition dp_paths_l {A : Type} {x1 x2 y : A} (p : x1 = x2) (q : x1 = y) r
  : p^ @ q = r <~> DPath (fun x => x = y) p q r.
Proof.
  refine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
  apply equiv_concat_l, transport_paths_l.
Defined.

Definition dp_paths_r {A : Type} {x y1 y2 : A} (p : y1 = y2) (q : x = y1) r
  :  q @ p = r <~> DPath (fun y => x = y) p q r.
Proof.
  refine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
  apply equiv_concat_l, transport_paths_r.
Defined.

Definition dp_paths_lr {A : Type} {x1 x2 : A} (p : x1 = x2) (q : x1 = x1) r
  : (p^ @ q) @ p = r <~> DPath (fun x : A => x = x) p q r.
Proof.
  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
  apply equiv_concat_l, transport_paths_lr.
Defined.

Definition dp_paths_Fl {A B} {f : A -> B} {x1 x2 : A} {y : B} (p : x1 = x2)
  (q : f x1 = y) r :  (ap f p)^ @ q = r <~> DPath (fun x => f x = y) p q r.
Proof.
  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
  apply equiv_concat_l, transport_paths_Fl.
Defined.

Definition dp_paths_Fr {A B} {g : A -> B} {y1 y2 : A} {x : B} (p : y1 = y2)
  (q : x = g y1) r :  q @ ap g p = r <~> DPath (fun y : A => x = g y) p q r.
Proof.
  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
  apply equiv_concat_l, transport_paths_Fr.
Defined.

Definition dp_paths_FFlr {A B} {f : A -> B} {g : B -> A} {x1 x2 : A}
  (p : x1 = x2) (q : g (f x1) = x1) r
  : ((ap g (ap f p))^ @ q) @ p = r <~> DPath (fun x : A => g (f x) = x) p q r.
Proof.
  refine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
  apply equiv_concat_l, transport_paths_FFlr.
Defined.

Definition dp_paths_FlFr {A B} {f g : A -> B} {x1 x2 : A} (p : x1 = x2)
  (q : f x1 = g x1) r
  : ((ap f p)^ @ q) @ ap g p = r <~> DPath (fun x : A => f x = g x) p q r.
Proof.
  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
  apply equiv_concat_l, transport_paths_FlFr.
Defined.

Definition dp_paths_lFFr {A B} {f : A -> B} {g : B -> A} {x1 x2 : A}
  (p : x1 = x2) (q : x1 = g (f x1)) r
  :  (p^ @ q) @ ap g (ap f p) = r <~> DPath (fun x : A => x = g (f x)) p q r.
Proof.
  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
  apply equiv_concat_l, transport_paths_lFFr.
Defined.

Definition dp_paths_FlFr_D {A B} (f g : forall a : A, B a)
  {x1 x2 : A} (p : x1 = x2) (q : f x1 = g x1) (r : f x2 = g x2)
  : ((apD f p)^ @ ap (transport B p) q) @ apD g p = r
    <~> DPath (fun x : A => f x = g x) p q r.
Proof.
  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
  apply equiv_concat_l, transport_paths_FlFr_D.
Defined.

Definition dp_compose' {A B} (f : A -> B) (P : B -> Type) {x y : A}
  {p : x = y} {q : f x = f y} (r : ap f p = q) (u : P (f x)) (v : P (f y))
  : DPath (fun x => P (f x)) p u v <~> DPath P q u v.
Proof.
  by destruct r, p.
Defined.

Definition dp_compose {A B} (f : A -> B) (P : B -> Type) {x y : A}
  (p : x = y) (u : P (f x)) (v : P (f y))
  : DPath (fun x => P (f x)) p u v <~> DPath P (ap f p) u v
  := dp_compose' f P (idpath (ap f p)) u v.

Definition dp_apD_compose {A B : Type} (f : A -> B) (P : B -> Type)
           {x y : A} (p : x = y) (g : forall b:B, P b)
  : dp_apD (g o f) p = (dp_compose f P p (g (f x)) (g (f y)))^-1 (dp_apD g (ap f p)).
Proof.
  by destruct p.
Defined.

(* Type constructors *)

(* Many of these lemmas exist already for transports but we prove them for
   DPaths anyway. If we change the definition of DPath to the transport,
   then these will no longer be needed. It is however, far more readable
   to keep such lemmas seperate, since it is difficult to otherwise search
   for a DPath lemma if they are all written using transports. *)

(** A version of [path_sigma] for [DPath]s *)
Definition path_sigma_dp {A P} {x x' : A} {y : P x} {y' : P x'}
  (p : x = x') (q : DPath P p y y') : (x; y) = (x'; y').
Proof.
  destruct p.
  apply (ap _ q).
Defined.

(** An uncurried version *)
Definition path_sigma_dp_uncurried {A P} {x x' : A} {y : P x} {y' : P x'}
  : {p : x = x' & DPath P p y y'} -> (x; y) = (x'; y').
Proof.
  intros [p q].
  exact (path_sigma_dp p q).
Defined.

(** This is an equivalnece. "A path in a sigma type is a sigma type of paths" *)
Global Instance isequiv_path_sigma_dp_uncurried
  {A P} {x x' : A} {y : P x} {y' : P x'}
  : IsEquiv (@path_sigma_dp_uncurried A P x x' y y').
Proof.
  serapply isequiv_adjointify.
  { intro r.
    exists (ap pr1 r).
    serapply dp_compose.
    apply (dp_apD pr2 r). }
  { intros r.
    set (xy := (x; y)) in *.
    set (x'y':= (x';y')) in *.
    change x with xy.1; change y with xy.2;
    change x' with x'y'.1; change y' with x'y'.2.
    clearbody xy x'y'; clear x y x' y'.
    by destruct r. }
  intros [p q].
  by destruct p, q.
Defined.

Lemma ap_pr1_path_sigma_dp {A : Type} {P : A -> Type}
  {x x' : A} {y : P x} {y' : P x'} (p : x = x') (q : DPath P p y y')
  : ap pr1 (path_sigma_dp p q) = p.
Proof.
  by destruct p, q.
Defined.

(* DPath over a forall *)
Definition dp_forall `{Funext} {A : Type} {B : A -> Type} {C : sig B -> Type}
  {a1 a2 : A} {p : a1 = a2} {f : forall x, C (a1; x)} {g : forall x, C (a2; x)}
  : (forall (x : B a1) (y : B a2) (q : DPath B p x y),
    DPath C (path_sigma_dp p q) (f x) (g y))
    <~> DPath (fun a => forall x, C (a; x)) p f g.
Proof.
  symmetry.
  destruct p; cbn.
  refine (equiv_compose' _ (equiv_apD10 _ _ _)).
  apply equiv_functor_forall_id.
  intro a.
  serapply equiv_adjointify.
  + by intros ? ? [].
  + intro F; exact (F a 1).
  + repeat (intro; apply path_forall).
    by intros [].
  + by intro.
Defined.

(* DPath over an arrow *)
Definition dp_arrow `{Funext} {A : Type} {B C : A -> Type}
  {a1 a2 : A} {p : a1 = a2} {f :  B a1 -> C a1} {g : B a2 -> C a2}
  : (forall x, DPath C p (f x) (g (p # x)))
    <~> DPath (fun x => B x -> C x) p f g.
Proof.
  destruct p.
  apply equiv_path_forall.
Defined.

(* Restricted version allowing us to pull the domain of a forall out *)
Definition dp_forall_domain `{Funext} {D : Type} {A : Type} {B : D -> A -> Type}
  {t1 t2 : D} {d : t1 = t2} {f : forall x, B t1 x} {g : forall x, B t2 x}
  : (forall x, DPath (fun t => B t x) d (f x) (g x))
   <~> DPath (fun t => forall x, B t x) d f g.
Proof.
  destruct d.
  apply equiv_path_forall.
Defined.

(** Necessery data to give a dependent path over a sigma type. *)
Definition dp_sigma {A : Type} {B : A -> Type}
  {C : sig B -> Type} {x1 x2 : A} {p : x1 = x2}
  {y1 : { y : B x1 & C (x1; y) }} {y2 : { y : B x2 & C (x2; y) }}
  (n : DPath B p y1.1 y2.1) (m : DPath C (path_sigma_dp p n) y1.2 y2.2)
  : DPath (fun x => { y : B x & C (x; y) }) p y1 y2.
Proof.
  destruct p.
  apply (path_sigma_dp n).
  by apply dp_compose.
Defined.

(** Uncurried version of dp_sigma *)
Definition dp_sigma_uncurried {A : Type} {B : A -> Type}
  {C : sig B -> Type} {x1 x2 : A} {p : x1 = x2}
  (y1 : { y : B x1 & C (x1; y) }) (y2 : { y : B x2 & C (x2; y) })
  : {n : DPath B p y1.1 y2.1 & DPath C (path_sigma_dp p n) y1.2 y2.2}
    -> DPath (fun x => { y : B x & C (x; y) }) p y1 y2.
Proof.
  destruct p.
  simpl.
  intro nm.
  apply path_sigma_dp_uncurried.
  erapply equiv_functor_sigma_id.
  { intro p.
    symmetry; serapply (dp_compose (exist B x1)). }
  apply nm.
Defined.

(** This is an equivlance. "A DPath of sigmas is a sigma of DPaths" *)
Global Instance isequiv_dp_sigma_uncurried {A : Type} {B : A -> Type}
  {C : sig B -> Type} {x1 x2 : A} {p : x1 = x2}
  {y1 : { y : B x1 & C (x1; y) }} {y2 : { y : B x2 & C (x2; y) }}
  : IsEquiv (@dp_sigma_uncurried A B C x1 x2 p y1 y2).
Proof.
  destruct p.
  exact _.
Defined.

(* Useful for turning computation rules of HITs written with transports to
   ones written with DPaths. *)
Definition dp_apD_path_transport {A P} (f : forall a : A, P a)
  {a0 a1 : A} (p : a0 = a1) l
  : apD f p = dp_path_transport^-1 l -> dp_apD f p = l.
Proof.
  by destruct p.
Defined.


Require Import
  MathClasses.theory.lattices MathClasses.varieties.monoids MathClasses.implementations.bool
  MathClasses.implementations.list_finite_set MathClasses.orders.lattices
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.finite_sets MathClasses.interfaces.orders.

Definition fset_car_setoid A `{FSet A} : Setoid A := setoidmor_a singleton.

Section fset_props.
  Context `{FSet A}.

  Instance: Setoid A := fset_car_setoid A.

  Lemma fset_extend_correct_applied `{BoundedJoinSemiLattice B} (f : A → B) `{!Setoid_Morphism f} x :
    f x = fset_extend f {{ x }}.
  Proof. now apply fset_extend_correct. Qed.

  Lemma fset_extend_unique_applied `{Equiv B} `{Join B} `{Bottom B} (f : A → B) `{!Setoid_Morphism f}
      (h : set_type A → B) `{!BoundedJoinSemiLattice_Morphism (h : set_type A → B)} :
    (∀ x, f x = h {{ x }}) → ∀ x, h x = fset_extend f x.
  Proof.
    intros. apply setoids.ext_equiv_applied, (fset_extend_unique _ _).
    now apply setoids.ext_equiv_applied_iff.
  Qed.

  Let F (x y z : A) := if decide (z = x) then false else true.
  Instance: ∀ x y, Setoid_Morphism (F x y).
  Proof.
    split; try apply _. intros ?? E. unfold F.
    do 2 case (decide _); try reflexivity; rewrite E; contradiction.
  Qed.

  Global Instance: Injective (singleton : A → set_type A).
  Proof.
    split; try apply _. intros x y E1. apply stable; intros E2.
    assert (fset_extend (F x y) {{ x }} ≠ fset_extend (F x y) {{ y }}) as E3.
     rewrite <-!(fset_extend_correct_applied (F x y)).
     unfold F. do 2 case (decide _); intuition try discriminate; auto.
    destruct E3. now rewrite E1.
  Qed.

  Lemma fset_singleton_ne_empty x : {{ x }} ≠ ∅.
  Proof.
    intros E1.
    set (g (z : A) := true).
    assert (Setoid_Morphism g) by (split; try apply _; firstorder).
    assert (fset_extend g {{ x }} ≠ ⊥) as E2.
     rewrite <-(fset_extend_correct_applied g). discriminate.
    destruct E2. now rewrite E1, preserves_bottom.
  Qed.

  Lemma fset_join_singletons x : {{ x ;  x }} = {{ x }}.
  Proof. now rewrite (idempotency (⊔) _). Qed.

  Lemma fset_join_singletons_eq_l x y : {{ x ;  y }} = {{ x }} ↔ x = y.
  Proof.
    split.
     intros E1. apply stable; intros E2.
     assert (fset_extend (F x y)  {{ x ; y }} ≠ fset_extend (F x y) {{ x }}) as E3.
      rewrite preserves_join, <-!(fset_extend_correct_applied (F x y)).
      unfold F. do 2 (case (decide _)); intuition try discriminate; auto.
     destruct E3. now rewrite E1.
    intros E. now rewrite E, fset_join_singletons.
  Qed.

  Lemma fset_join_singletons_eq_r x y : {{ x ;  y }} = {{ y }} ↔ x = y.
  Proof. rewrite commutativity, fset_join_singletons_eq_l. intuition. Qed.
End fset_props.

#[global]
Instance fset_map_mor `{FSet A} `{FSet B} (f : A → B) `{!Setoid_Morphism f} :
  BoundedJoinSemiLattice_Morphism (fset_map (H:=At) (H0:=At0) (SetSingleton0:=Asingle0)  f).
Proof. apply _. Qed.

Lemma fset_map_correct `{FSet A} `{FSet B} (f : A → B) `{!Setoid_Morphism f} :
  singleton ∘ f = fset_map f ∘ singleton.
Proof (fset_extend_correct _).

Lemma fset_map_correct_applied `{FSet A} `{FSet B} (f : A → B) `{!Setoid_Morphism f} x :
  {{ f x }} = fset_map f {{ x }}.
Proof.
  pose proof (fset_car_setoid A).
  now apply (setoids.ext_equiv_applied (fset_map_correct f)).
Qed.

Lemma fset_map_unique `{FSet A} `{FSet B} (f : A → B) `{!Setoid_Morphism f}
    (h : set_type A → set_type B) `{!BoundedJoinSemiLattice_Morphism h} :
  singleton ∘ f = h ∘ singleton → h = fset_map f.
Proof. intros. unfold fset_map. now apply (fset_extend_unique _ _). Qed.

Lemma fset_map_id `{FSet A} :
  fset_map id = id.
Proof.
  pose proof (fset_car_setoid A).
  symmetry. apply (fset_map_unique id id).
  now apply setoids.ext_equiv_refl.
Qed.

Lemma fset_map_id_applied `{FSet A} x :
  fset_map id x = x.
Proof. now apply fset_map_id. Qed.

Lemma fset_map_compose `{FSet A} `{FSet B} `{FSet C}
     (f : B → C) `{!Setoid_Morphism f} (g : A → B) `{!Setoid_Morphism g} :
  fset_map (f ∘ g) = fset_map f ∘ fset_map g.
Proof.
  pose proof (fset_car_setoid A).
  symmetry. apply (fset_map_unique (f ∘ g) _).
  rewrite compose_assoc.
  rewrite <-(fset_map_correct g).
  rewrite <-compose_assoc.
  rewrite (fset_map_correct f).
  now apply setoids.ext_equiv_refl.
Qed.

Section fset_map_inverse.
  Context `{FSet A} `{FSet B} (f : A → B) `{!Inverse f} `{!Bijective f}.

  Global Instance fset_map_inverse: Inverse (fset_map f) := fset_map (f⁻¹).

  Instance fset_map_surjective: Surjective (fset_map f).
  Proof.
    pose proof (fset_car_setoid A). pose proof (fset_car_setoid B).
    pose proof (injective_mor f). split; try apply _.
    unfold inverse, fset_map_inverse.
    rewrite <-(fset_map_compose _ _).
    symmetry. apply (fset_map_unique _ _).
    rewrite (surjective f).
    now apply setoids.ext_equiv_refl.
  Qed.
End fset_map_inverse.

#[global]
Instance fset_map_bijective `{FSet A} `{FSet B}
  (f : A → B) `{!Inverse f} `{!Bijective f} : Bijective (fset_map f).
Proof.
  pose proof (fset_car_setoid A). pose proof (fset_car_setoid B).
  pose proof (injective_mor f).
  pose proof (fset_map_surjective f). pose proof (fset_map_surjective (f⁻¹)).
  repeat (split; try apply _). intros x y E.
  rewrite <-(jections.surjective_applied (fset_map (f⁻¹)) x).
  rewrite <-(jections.surjective_applied (fset_map (f⁻¹)) y).
  now apply sm_proper.
Qed.

Lemma preserves_in `{FullFSet A} `{FullFSet B} (f : A → B) `{!Inverse f} `{!Bijective f} x X :
  f x ∈ fset_map f X ↔ x ∈ X.
Proof.
  pose proof (injective_mor f).
  pose proof (join_sl_mor_preserving (fset_map f)).
  pose proof (join_sl_mor_reflecting (fset_map f)).
  rewrite !fset_in_singleton_le.
  split; intros E.
   apply (order_reflecting (fset_map f)).
   now rewrite <-(fset_map_correct_applied f).
  rewrite (fset_map_correct_applied f).
  now apply (order_preserving _).
Qed.

Lemma preserves_notin `{FullFSet A} `{FullFSet B} (f : A → B) `{!Inverse f} `{!Bijective f} x X :
  f x ∉ fset_map f X ↔ x ∉ X.
Proof. split; intros E ?; now apply E, (preserves_in f). Qed.

Section full_fset_props.
  Context `{FullFSet A}.

  Instance: Setoid A := fset_car_setoid A.

  Notation to_listset := (fset_map id : set_type A → @set_type _ (listset A)).
  Notation from_listset := (to_listset⁻¹).

  Lemma to_listset_preserves_in x X : x ∈ to_listset X ↔ x ∈ X.
  Proof preserves_in id x X.

  Lemma fset_induction (P : set_type A → Prop) `{proper : !Proper ((=) ==> iff) P} :
    P ∅ → (∀ x X, x ∉ X → P X → P ({{ x }} ⊔ X)) → ∀ X, P X.
  Proof.
    intros Pempty Padd X.
    mc_setoid_replace X with (from_listset (to_listset X))
     by (symmetry; apply (jections.bijective_applied _)).
    generalize (to_listset X). apply listset_induction.
      solve_proper.
     now rewrite preserves_bottom.
    intros x l E1 E2.
    change (P (fset_map id ({{x}} ⊔ l))).
    rewrite preserves_join, <-(fset_map_correct_applied _ x).
    apply Padd; auto. intros E3. destruct E1. now apply (preserves_in id x).
  Qed.

  Global Instance fset_in_proper : Proper ((=) ==> (=) ==> iff) ((∈): A → set_type A).
  Proof. intros x y E1 X Y E2. now rewrite !fset_in_singleton_le, E1, E2. Qed.

  Global Program Instance fset_in_dec_slow: ∀ x X, Decision (x ∈ X) | 50 := λ x X,
    match decide_rel (∈) x (to_listset X) with left E => left _ | right E => right _ end.
  Next Obligation. now apply to_listset_preserves_in. Qed.
  Next Obligation. intros F. destruct E. now apply to_listset_preserves_in. Qed.

  Lemma fset_notin_empty x : x ∉ ∅.
  Proof. intro. now apply fset_singleton_ne_empty with x, below_bottom, fset_in_singleton_le. Qed.

  Lemma fset_in_join X Y x : x ∈ X ⊔ Y ↔ x ∈ X ∨ x ∈ Y.
  Proof. rewrite <-!to_listset_preserves_in, preserves_join. apply listset_in_join. Qed.

  Lemma fset_notin_join X Y x : x ∉ X ⊔ Y ↔ x ∉ X ∧ x ∉ Y.
  Proof. rewrite fset_in_join. tauto. Qed.

  Lemma fset_in_singleton x : x ∈ {{ x }}.
  Proof. now rewrite fset_in_singleton_le, join_sl_le_spec, fset_join_singletons. Qed.

  Lemma fset_in_singleton_eq x y : x ∈ {{ y }} ↔ x = y.
  Proof.
    split; intros E.
     now apply fset_join_singletons_eq_r, join_sl_le_spec, fset_in_singleton_le.
    rewrite E. apply fset_in_singleton.
  Qed.

  Lemma fset_notin_singleton_neq x y : x ∉ {{ y }} ↔ x ≠ y.
  Proof. now rewrite fset_in_singleton_eq. Qed.

  Lemma fset_in_add y X x : y ∈ {{ x }} ⊔ X ↔ y = x ∨ y ∈ X.
  Proof.
    rewrite fset_in_join. split; intros [?|?]; try tauto.
     left. now apply fset_in_singleton_eq.
    left. now apply fset_in_singleton_eq.
  Qed.

  Lemma fset_notin_add y X x : y ∉ {{ x }} ⊔ X ↔ y ≠ x ∧ y ∉ X.
  Proof. rewrite fset_in_add. tauto. Qed.

  Lemma fset_in_inversion y X x : y ∈ {{ x }} ⊔ X → y = x ∨ y ∈ X.
  Proof.
    rewrite fset_in_join. intros [?|?]; try tauto.
    left. now apply fset_in_singleton_eq.
  Qed.

  Lemma fset_le_in X Y : X ≤ Y ↔ ∀ x, x ∈ X → x ∈ Y.
  Proof.
    pose proof (join_sl_mor_preserving to_listset).
    pose proof (join_sl_mor_reflecting to_listset).
    setoid_rewrite <-to_listset_preserves_in.
    split; intros E.
     now apply (order_preserving (to_listset)) in E.
    now apply (order_reflecting (to_listset)).
  Qed.

  Lemma fset_eq_in X Y : X = Y ↔ ∀ x, x ∈ X ↔ x ∈ Y.
  Proof.
    setoid_rewrite <-to_listset_preserves_in.
    split.
     intros E. change (to_listset X = to_listset Y).
     now apply sm_proper.
    intros. now apply (injective (to_listset)).
  Qed.

  Instance: Proper ((=) ==> (=) ==> (=)) (⊓).
  Proof. intros ?? E1 ?? E2. apply fset_eq_in. intros. now rewrite !fset_in_meet, E1, E2. Qed.
  Instance: Associative (⊓).
  Proof. repeat intro. apply fset_eq_in. intros. rewrite !fset_in_meet. tauto. Qed.
  Instance: Commutative (⊓).
  Proof. repeat intro. apply fset_eq_in. intros. rewrite !fset_in_meet. tauto. Qed.
  Instance: BinaryIdempotent (⊓).
  Proof. repeat intro. apply fset_eq_in. intros. rewrite !fset_in_meet. tauto. Qed.
  Instance: MeetSemiLattice (set_type A).
  Proof. repeat (split; try apply _). Qed.

  Global Instance: DistributiveLattice (set_type A).
  Proof.
    repeat (split; try apply _); repeat intro; apply fset_eq_in; intro;
      repeat (rewrite fset_in_meet || rewrite fset_in_join); tauto.
  Qed.

  Global Instance: MeetSemiLatticeOrder (≤).
  Proof.
    apply alt_Build_MeetSemiLatticeOrder. intros.
    rewrite fset_le_in, fset_eq_in. setoid_rewrite fset_in_meet. firstorder trivial.
  Qed.

  Lemma fset_meet_singletons x : {{ x }} ⊓ {{ x }} = {{ x }}.
  Proof. now rewrite (idempotency (⊔) _). Qed.

  Lemma fset_meet_singletons_eq_l x y : {{ x }} ⊓ {{ y }} = {{ x }} ↔ x = y.
  Proof.
    split; intros E.
     apply fset_in_singleton_eq.
     rewrite fset_eq_in in E. setoid_rewrite fset_in_meet in E.
     now destruct (proj2 (E x) (fset_in_singleton _)).
    now rewrite E, fset_meet_singletons.
  Qed.

  Lemma fset_meet_singletons_eq_r x y : {{ x }} ⊓ {{ y }} = {{ y }} ↔ x = y.
  Proof. rewrite commutativity, fset_meet_singletons_eq_l. intuition. Qed.

  Lemma fset_meet_distinct_singletons (x y: A) : x ≠ y → {{ x }} ⊓ {{ y }} = ∅.
  Proof.
    intros E1. apply fset_eq_in. intros z.
    rewrite fset_in_meet. split.
     intros [E2 E3]. destruct E1.
     apply fset_in_singleton_eq in E2. apply fset_in_singleton_eq in E3.
     now rewrite <-E2, <-E3.
    intro. now destruct (fset_notin_empty z).
  Qed.

  Global Instance: Proper ((=) ==> (=) ==> (=)) (∖).
  Proof. intros ?? E1 ?? E2. apply fset_eq_in. intros. now rewrite !fset_in_difference, E1, E2. Qed.

  Global Instance fset_difference_empty_r: RightIdentity (∖) ∅.
  Proof.
    intro. apply fset_eq_in. intro. rewrite fset_in_difference.
    split; intuition. edestruct fset_notin_empty; eassumption.
  Qed.

  Global Instance fset_difference_empty_l: LeftAbsorb (∖) ∅.
  Proof.
    intro. apply fset_eq_in. intro. rewrite fset_in_difference.
    split; intuition. edestruct fset_notin_empty; eassumption.
  Qed.

  Global Instance diff_meet_distr_r: RightDistribute (∖) (⊓).
  Proof.
    intros X Y Z. apply fset_eq_in. intro.
    repeat (rewrite fset_in_meet || rewrite fset_in_difference). intuition.
  Qed.

  Global Instance diff_join_distr_r: RightDistribute (∖) (⊔).
  Proof.
    intros X Y Z. apply fset_eq_in. intro.
    repeat (rewrite fset_in_join || rewrite fset_in_difference). intuition.
  Qed.

  Lemma diff_meet_join_diff X Y Z : X ∖ (Y ⊓ Z) = X ∖ Y ⊔ X ∖ Z.
  Proof.
    apply fset_eq_in. intro.
    repeat (rewrite fset_in_join || rewrite fset_in_meet || rewrite fset_in_difference).
    split; try tauto. intros [??]. case (decide (x ∈ Y)); tauto.
  Qed.

  Lemma diff_join_diff_meet X Y Z : X ∖ (Y ⊔ Z) = X ∖ Y ⊓ X ∖ Z.
  Proof.
    apply fset_eq_in. intro.
    repeat (rewrite fset_in_join || rewrite fset_in_meet || rewrite fset_in_difference). tauto.
  Qed.
End full_fset_props.

Ltac split_sets :=
  repeat (match goal with
  | E : _ ∈ ∅ |- _ => apply fset_notin_empty in E; destruct E
  | E : _ ∈ {{ _ }} |- _ => apply fset_in_singleton_eq in E
  | E : _ ∉ {{ _ }} |- _ => apply fset_notin_singleton_neq in E
  | E : _ ∈ _ ⊔ _ |- _ => apply fset_in_join in E; destruct E
  | E : _ ∉ _ ⊔ _ |- _ => apply fset_notin_join in E; destruct E
  | E : _ ∈ _ ⊓ _ |- _ => apply fset_in_meet in E; destruct E
  | |-  context [_ ∈ _ ⊔ _] => rewrite !fset_in_join
  end).

Section iso_is_fset.
  Context `{Setoid A} `{At : SetType A}
    `{BoundedJoinSemiLattice (set_type A)} `{fsetB : FSet B}
    `{SetSingleton A} `{!Setoid_Morphism (singleton : A → At)}
    (A_to_B : A → B) `{!Inverse A_to_B} `{!Bijective A_to_B}
    (At_to_Bt : set_type A → set_type B) `{!Inverse At_to_Bt}
   `{!Bijective At_to_Bt} `{!BoundedJoinSemiLattice_Morphism At_to_Bt}
   `{∀ a₁ a₂ : A, Decision (a₁ = a₂)}
    (singleton_correct : At_to_Bt ∘ singleton = singleton ∘ A_to_B).

  Instance: Setoid B := fset_car_setoid B.

  Lemma singleton_correct_alt :
    At_to_Bt⁻¹ ∘ singleton = singleton ∘ A_to_B⁻¹.
  Proof.
    pose proof (injective_mor A_to_B). pose proof (injective_mor At_to_Bt).
    apply (jections.injective_compose_cancel At_to_Bt).
    rewrite <-!compose_assoc.
    rewrite (surjective At_to_Bt), singleton_correct.
    rewrite compose_assoc, (surjective A_to_B).
    rewrite compose_id_left, compose_id_right.
    now apply setoids.ext_equiv_refl.
  Qed.

  Instance iso_is_fset_extend: FSetExtend A := λ C _ _ f,
    fset_extend (f ∘ A_to_B⁻¹) ∘ At_to_Bt.

  Instance iso_is_fset: FSet A.
  Proof.
    pose proof (injective_mor A_to_B).
    split; unfold fset_extend, iso_is_fset_extend; try apply _.
     intros C ? ? ? ? f ?.
     rewrite compose_assoc, singleton_correct, <-compose_assoc.
     rewrite <-(fset_extend_correct (f ∘ A_to_B ⁻¹)).
     rewrite compose_assoc, (jections.bijective _), compose_id_right.
     now apply setoids.ext_equiv_refl.
    intros C ? ? ? f ? h ? E1.
    pose proof (bounded_join_slmor_b (f:=h)).
    rewrite <-(fset_extend_unique (f ∘ A_to_B⁻¹) (h ∘ At_to_Bt⁻¹)).
     rewrite compose_assoc, (jections.bijective _), compose_id_right.
     now apply setoids.ext_equiv_refl.
    rewrite E1, !compose_assoc, singleton_correct_alt.
    now apply setoids.ext_equiv_refl.
  Qed.
End iso_is_fset.


Require Import Iron.Language.SystemF2.Step.
Require Import Iron.Language.SystemF2.SubstExpExp.
Require Import Iron.Language.SystemF2.SubstTypeExp.
Require Import Iron.Language.SystemF2.SubstTypeType.
Require Import Iron.Language.SystemF2.TyJudge.

(* A closed, well typed expression is either a value
   or can take a step. *)
Theorem progress
 :  forall x
 ,  (exists t, TYPE nil nil x t)
 -> value x \/ (exists x', STEP x x').
Proof.
 intros.
 induction x; destruct H as [tx].

 Case "XVar".
  inverts H. false.

 Case "XLAM".
  left. apply type_wfX in H. auto.

 Case "XAPP".
  inverts H.
  destruct IHx. eauto.
  SCase "x value".
   right. inverts H. inverts H4.
    inverts H1. false.
    inverts H0.
    exists (substTX 0 t x1). eapply ESLAMAPP.
    inverts H0.
  SCase "x steps".
   right.
    destruct H as [x'].
    exists (XAPP x' t).
    apply ESAPP1. auto.

 Case "XLam".
  left. apply type_wfX in H. auto.

 Case "XApp".
  right.
  inverts H.
  destruct IHx1; eauto.
  SCase "x1 value".
   destruct IHx2; eauto.
   inverts H.

   SSCase "x2 value".
    inverts H1.
     inverts H2. false.
     inverts H4.
     exists (substXX 0 x2 x0).
      inverts H0. apply ESLamApp. auto.

   SSCase "x2 steps".
    destruct H0 as [x2'].
    exists (XApp x1 x2').
     inverts H. apply ESApp2; auto.

  SCase "x1 steps".
   destruct H as [x1'].
   exists (XApp x1' x2).
   apply ESApp1; auto.
Qed.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris_atomic Require Import atomic.
From iris.proofmode Require Import tactics.
From iris.prelude Require Import coPset.
From iris.heap_lang.lib Require Import par.

Section incr.
  Context `{!heapG Σ} (N : namespace).

  Definition incr: val :=
    rec: "incr" "l" :=
       let: "oldv" := !"l" in
       if: CAS "l" "oldv" ("oldv" + #1)
         then "oldv" (* return old value if success *)
         else "incr" "l".

  (* TODO: Can we have a more WP-style definition and avoid the equality? *)
  Definition incr_triple (l: loc) :=
    atomic_triple (fun (v: Z) => l ↦ #v)%I
                  (fun v ret => ⌜ret = #v⌝ ∗ l ↦ #(v + 1))%I
                  ∅
                  ⊤
                  (incr #l).

  Lemma incr_atomic_spec: ∀ (l: loc), incr_triple l.
  Proof.
    iIntros (l).
    rewrite /incr_triple.
    rewrite /atomic_triple.
    iIntros (P Q) "#Hvs".
    iLöb as "IH".
    iIntros "!# HP".
    wp_rec.
    wp_bind (! _)%E.
    iMod ("Hvs" with "HP") as (x) "[Hl [Hvs' _]]".
    wp_load.
    iMod ("Hvs'" with "Hl") as "HP".
    iModIntro. wp_let. wp_bind (CAS _ _ _). wp_op.
    iMod ("Hvs" with "HP") as (x') "[Hl Hvs']".
    destruct (decide (x = x')).
    - subst.
      iDestruct "Hvs'" as "[_ Hvs']".
      iSpecialize ("Hvs'" $! #x').
      wp_cas_suc.
      iMod ("Hvs'" with "[Hl]") as "HQ"; first by iFrame.
      iModIntro. wp_if. done.
    - iDestruct "Hvs'" as "[Hvs' _]".
      wp_cas_fail.
      iMod ("Hvs'" with "[Hl]") as "HP"; first by iFrame.
      iModIntro. wp_if. by iApply "IH".
  Qed.
End incr.

Section user.
  Context `{!heapG Σ, !spawnG Σ} (N : namespace).

  Definition incr_2 : val :=
    λ: "x",
       let: "l" := ref "x" in
       incr "l" ||| incr "l";;
       !"l".

  (* prove that incr is safe w.r.t. data race. TODO: prove a stronger post-condition *)
  Lemma incr_2_safe:
    ∀ (x: Z), (WP incr_2 #x {{ _, True }})%I.
  Proof.
    iIntros (x).
    rewrite /incr_2 /=.
    wp_lam.
    wp_alloc l as "Hl".
    iMod (inv_alloc N _ (∃x':Z, l ↦ #x')%I with "[Hl]") as "#?"; first eauto.
    wp_let.
    wp_bind (_ ||| _)%E.
    iAssert (□ WP incr #l {{ _, True }})%I as "#?".
    { (* prove worker triple *)
      iDestruct (incr_atomic_spec l) as "Hincr"=>//.
      rewrite /incr_triple /atomic_triple.
      iSpecialize ("Hincr"  $! True%I (fun _ => True%I) with "[]").
      - iIntros "!# _".
        (* open the invariant *)
        iInv N as (x') ">Hl'" "Hclose".
        (* mask magic *)
        iMod (fupd_intro_mask' _ ∅) as "Hvs"; first set_solver.
        iModIntro. iExists x'. iFrame "Hl'". iSplit.
        + (* provide a way to rollback *)
          iIntros "Hl'".
          iMod "Hvs". iMod ("Hclose" with "[Hl']"); eauto.
        + (* provide a way to commit *)
          iIntros (v) "[Heq Hl']".
          iMod "Hvs". iMod ("Hclose" with "[Hl']"); eauto.
      - iDestruct "Hincr" as "#HIncr". iAlways. by iApply "HIncr". }
    iApply (wp_par (λ _, True%I) (λ _, True%I) with "[] []"); [done..|].
    iIntros (v1 v2) "_ !>".
    wp_seq. iInv N as (x') ">Hl" "Hclose".
    wp_load. iApply "Hclose". eauto.
  Qed.
End user.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Numbers.Natural.Peano.NPeano
        Coq.Strings.String
        Coq.Arith.Lt
        Coq.Arith.Compare_dec
        Coq.Lists.List
        Coq.ZArith.ZArith.

Section GenSym.
  Local Unset Implicit Arguments.
  Local Open Scope string_scope.
  Local Open Scope list_scope.

  Lemma digitLtBase m {n} : not (m + n < m).
  Proof.
    red; intros; eapply Le.le_Sn_n; eauto using Le.le_trans, Plus.le_plus_l.
  Qed.

  Definition DigitToString (n: {n | n < 10}) :=
    match n with
    | exist 0 _ => "0" | exist 1 _ => "1" | exist 2 _ => "2" | exist 3 _ => "3" | exist 4 _ => "4"
    | exist 5 _ => "5" | exist 6 _ => "6" | exist 7 _ => "7" | exist 8 _ => "8" | exist 9 _ => "9"
    | exist n pr => False_rect _ (digitLtBase 10 pr)
    end.

  Fixpoint NumberToString_rec (fuel: nat) (n: nat) :=
    match fuel with
    | O => ""
    | S fuel =>
      match (lt_dec n 10) with
      | left pr  => DigitToString (exist _ n pr)
      | right pr => append (NumberToString_rec fuel (n / 10)) (NumberToString_rec fuel (n mod 10))
      end
    end.

  Definition NumberToString (n: nat) :=
    NumberToString_rec n (pred n).

  Definition nthArgName n := append "arg" (NumberToString n).
  Definition nthRepName n := append "rep" (NumberToString n).

  Fixpoint NumUpTo n acc :=
    match n with
    | 0 => acc
    | S n' => NumUpTo n' (n' :: acc)
    end.

  Lemma NoDupNumUpTo
    : forall n l,
      NoDup l
      -> (forall n', In n' l -> S n' > n)
      -> NoDup (NumUpTo n l).
  Proof.
    induction n.
    - simpl; eauto.
    - simpl; intros.
      eapply IHn.
      + constructor; eauto.
        intro H'; apply H0 in H'; eapply Gt.gt_irrefl; eauto.
      + intros; destruct H1; subst.
        eauto with arith.
        apply H0 in H1; eauto with arith.
  Qed.

  Definition BuildArgNames n m :=
    List.app (rev (map nthArgName (NumUpTo n nil)))
             (rev (map nthRepName (NumUpTo m nil))).

  Lemma NumberToString_rec_lt_10 :
    forall n m,
      n > 0
      -> m < 10
      -> NumberToString_rec n m = NumberToString_rec 1 m.
  Proof.
    simpl; intros.
    destruct n.
    - exfalso; eapply Gt.gt_irrefl; eauto.
    - simpl; destruct (Compare_dec.lt_dec m 10).
      + reflexivity.
      + tauto.
  Qed.

  Lemma divmod_gt_10
    : forall m,
      9 < m
      -> 0 < fst (NPeano.divmod m 9 0 8).
  Proof.
    intros; pose proof (NPeano.divmod_spec m 9 0 8 (Le.le_n_Sn _)).
    destruct (NPeano.divmod m 9 0 8); intuition.
    simpl in *.
    destruct n; eauto; simpl in *.
    rewrite Plus.plus_comm in H1; simpl in *.
    rewrite Plus.plus_comm in H1; simpl in *.
    destruct n0; try omega.
    destruct n0; try omega.
    destruct n0; try omega.
    destruct n0; try omega.
    destruct n0; try omega.
    destruct n0; try omega.
    destruct n0; try omega.
    destruct n0; try omega.
    destruct n0; try omega.
    destruct n0; try omega.
  Qed.

  Lemma divmod_lt_self :
    forall m,
      fst (NPeano.divmod m 9 0 8) <= m.
  Proof.
    intros; pose proof (NPeano.divmod_spec m 9 0 8 (Le.le_n_Sn _)).
    destruct (NPeano.divmod m 9 0 8); intuition.
    simpl in *.
    destruct n; eauto; omega.
  Qed.

  Lemma divmod_lt_9 :
    forall m,
      snd (NPeano.divmod m 9 0 8) <= 9.
  Proof.
    intros; pose proof (NPeano.divmod_spec m 9 0 8 (Le.le_n_Sn _)).
    destruct (NPeano.divmod m 9 0 8); intuition.
  Qed.

  Lemma divmod_eq :
    forall n m,
      NPeano.divmod n 9 0 8 = NPeano.divmod m 9 0 8 ->
      n = m.
  Proof.
    intros; pose proof (NPeano.divmod_spec m 9 0 8 (Le.le_n_Sn _)).
    pose proof (NPeano.divmod_spec n 9 0 8 (Le.le_n_Sn _)).
    destruct (NPeano.divmod m 9 0 8);
      destruct (NPeano.divmod n 9 0 8);
      intuition.
    simpl in *.
    rewrite Plus.plus_comm in *; simpl in *.
    rewrite Plus.plus_comm in *; simpl in *.
    injection H; intros; subst.
    omega.
  Qed.

  Lemma string_append_nil
    : forall s1 s2, append s1 s2 = "" -> s1 = "" /\ s2 = "".
  Proof.
    induction s1; simpl; eauto.
    intros; discriminate.
  Qed.

  Lemma append_single_char :
    forall s1 s2 a1 a2,
      append s1 (String a1 EmptyString) = append s2 (String a2 EmptyString)
      -> s1 = s2 /\ a1 = a2.
  Proof.
    induction s1; simpl.
    - destruct s2; simpl; intros; try discriminate.
      injection H; intros; subst; intuition.
      destruct s2; discriminate.
    - destruct s2; simpl; intros; try discriminate.
      injection H; intros; subst; intuition.
      destruct s1; discriminate.
      destruct s1; discriminate.
      injection H; intros; subst; intuition.
      apply IHs1 in H0; intuition subst; eauto.
      apply IHs1 in H0; intuition subst; eauto.
  Qed.

  Lemma NumberToString_rec_10
    : forall fuel_m m,
      0 < fuel_m
      -> m < fuel_m
      -> NumberToString_rec fuel_m m <> "".
  Proof.
    induction fuel_m; simpl; intros.
    - omega.
    - destruct (Compare_dec.lt_dec m 10).
      + destruct m; try (discriminate || omega).
        destruct m; try (discriminate || omega).
        destruct m; try (discriminate || omega).
        destruct m; try (discriminate || omega).
        destruct m; try (discriminate || omega).
        destruct m; try (discriminate || omega).
        destruct m; try (discriminate || omega).
        destruct m; try (discriminate || omega).
        destruct m; try (discriminate || omega).
        destruct m; try (discriminate || omega).
      + intro H'; apply string_append_nil in H'; intuition.
        destruct fuel_m.
        omega.
        simpl in H2.
        destruct (snd (NPeano.divmod m 9 0 9)); simpl in *; try discriminate.
        * destruct (snd (NPeano.divmod m 9 0 9)); simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
          destruct n0; simpl in *; try discriminate.
  Qed.

  Lemma string_append_single
    : forall a s1 s2,
      String a EmptyString = append s1 s2
      -> (s1 = String a EmptyString /\ s2 = EmptyString)
         \/ (s2 = String a EmptyString /\ s1 = EmptyString).
  Proof.
    induction s1; simpl; intuition.
    injection H; intros; subst.
    symmetry in H0; apply string_append_nil in H0; subst; intuition.
    subst; intuition.
  Qed.

  Lemma NumberToString_rec_snd_divmod
    : forall fuel_n n,
      n < fuel_n
      -> exists a,
        NumberToString_rec
          fuel_n
          match snd (NPeano.divmod n 9 0 8) with
          | 0 => 9
          | 1 => 8
          | 2 => 7
          | 3 => 6
          | 4 => 5
          | 5 => 4
          | 6 => 3
          | 7 => 2
          | 8 => 1
          | S (S (S (S (S (S (S (S (S _)))))))) => 0
          end = String a EmptyString.
  Proof.
    destruct fuel_n; intros.
    omega.
    destruct (snd (NPeano.divmod n 9 0 8)); [simpl; eauto | ].
    do 9 (destruct n0; [simpl; eauto | ]).
    simpl; eauto.
  Qed.

  Lemma NumberToString_rec_inj' :
    forall fuel_n n m fuel_m,
      n < fuel_n
      -> m < fuel_m
      -> NumberToString_rec fuel_n n = NumberToString_rec fuel_m m
      -> n = m.
  Proof.
    induction fuel_n.
    intros; try omega.
    induction m; auto.
    destruct n; try omega; intros.
    destruct fuel_m; try omega.
    destruct fuel_m; try omega.
    simpl in H1.
    destruct (Compare_dec.lt_dec (S n) 10).
    do 10 (destruct n; try discriminate).
    omega.
    omega.
    symmetry in H1; apply string_append_single in H1; intuition.
    exfalso.
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3).
    omega.
    pose proof (divmod_lt_self n); omega.
    intros.
    destruct n; simpl in *; try omega.
    destruct fuel_m; simpl in *; try omega.
    destruct (Compare_dec.lt_dec (S m) 10); simpl in *.
    do 10 (destruct m; try discriminate).
    omega.
    omega.
    apply string_append_single in H1; intuition.
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3).
    omega.
    pose proof (divmod_lt_self m); omega.
    destruct fuel_m; simpl in *; try omega.
    destruct (Compare_dec.lt_dec (S n) 10).
    destruct (Compare_dec.lt_dec (S m) 10).
    do 9 (destruct n; [ do 9 (try destruct m; try discriminate; try omega; auto) | ]).
    do 9 (try destruct m; try discriminate; try omega; auto).
    destruct n.
    apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self m); omega ].
    destruct n.
    apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self m); omega ].
    destruct n.
    apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self m); omega ].
    destruct n.
    apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self m); omega ].
    destruct n.
    apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self m); omega ].
    destruct n.
    apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self m); omega ].
    destruct n.
    apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self m); omega ].
    destruct n.
    apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self m); omega ].
    destruct n.
    apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self m); omega ].
    omega.
    destruct (Compare_dec.lt_dec (S m) 10).
    destruct m.
    symmetry in H1; apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self n); omega ].
    destruct m.
    symmetry in H1; apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self n); omega ].
    destruct m.
    symmetry in H1; apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self n); omega ].
    destruct m.
    symmetry in H1; apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self n); omega ].
    destruct m.
    symmetry in H1; apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self n); omega ].
    destruct m.
    symmetry in H1; apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self n); omega ].
    destruct m.
    symmetry in H1; apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self n); omega ].
    destruct m.
    symmetry in H1; apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self n); omega ].
    destruct m.
    symmetry in H1; apply string_append_single in H1; intuition;
    [ exfalso;
      apply (fun H H' => NumberToString_rec_10 _ _ H H' H3); try omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | congruence].
    exfalso; eapply (fun H H' => NumberToString_rec_10 _ _ H H' H3);
    [ omega | pose proof (divmod_lt_self n); omega ].
    omega.
    destruct (@NumberToString_rec_snd_divmod fuel_m m); [omega | ].
    destruct (@NumberToString_rec_snd_divmod fuel_n n); [omega | ].
    rewrite H3, H2 in H1.
    eapply append_single_char in H1; intuition.
    eapply IHfuel_n in H4.
    subst.
    rewrite <- H2 in H3.
    eapply IHfuel_n in H3.
    assert (snd (NPeano.divmod n 9 0 8) = snd (NPeano.divmod m 9 0 8)).
    revert H3; clear.
    pose proof (divmod_lt_9 n);
      pose proof (divmod_lt_9 m);
      destruct (snd (NPeano.divmod n 9 0 8));
      destruct (snd (NPeano.divmod m 9 0 8)); eauto.
    do 10 (destruct n0; try discriminate; eauto).
    do 10 (destruct n0; try discriminate; eauto).
    destruct n0; destruct n1; eauto.
    do 10 (destruct n1; try discriminate; eauto).
    do 10 (destruct n0; try discriminate; eauto).
    destruct n0; destruct n1; eauto.
    do 10 (destruct n1; try discriminate; eauto).
    do 10 (destruct n0; try discriminate; eauto).
    destruct n0; destruct n1; eauto.
    do 10 (destruct n1; try discriminate; eauto).
    do 10 (destruct n0; try discriminate; eauto).
    destruct n0; destruct n1; eauto.
    do 10 (destruct n1; try discriminate; eauto).
    do 10 (destruct n0; try discriminate; eauto).
    destruct n0; destruct n1; eauto.
    do 10 (destruct n1; try discriminate; eauto).
    do 10 (destruct n0; try discriminate; eauto).
    destruct n0; destruct n1; eauto.
    do 10 (destruct n1; try discriminate; eauto).
    do 10 (destruct n0; try discriminate; eauto).
    destruct n0; destruct n1; eauto.
    do 10 (destruct n1; try discriminate; eauto).
    do 10 (destruct n0; try discriminate; eauto).
    destruct n0; destruct n1; eauto.
    do 10 (destruct n1; try discriminate; eauto).
    do 10 (destruct n0; try discriminate; eauto).
    intros; omega.
    clear H3.
    rewrite (divmod_eq m n); auto.
    destruct (NPeano.divmod m 9 0 8);
      destruct (NPeano.divmod n 9 0 8); simpl in *; congruence.
    destruct (snd (NPeano.divmod n 9 0 8)); try omega.
    do 10 (destruct n2; try omega).
    destruct (snd (NPeano.divmod m 9 0 8)); try omega.
    do 10 (destruct n2; try omega).
    pose proof (divmod_lt_self n); omega.
    pose proof (divmod_lt_self m); omega.
  Qed.

End GenSym.

Ltac gensym_rec prefix start :=
  let name := (eval compute in (prefix ++ NumberToString start)%string) in
  lazymatch goal with
| |- context[name] => gensym_rec prefix (S start)
| H : context[name] |- _ => gensym_rec prefix (S start)
| H := context[name] |- _ => gensym_rec prefix (S start)
| _ => constr:(name)
end.

Ltac gensym prefix :=
  gensym_rec prefix 0.

Arguments nthRepName _ / .
Arguments nthArgName _ / .
Arguments BuildArgNames !n !m / .