From HoTT Require Import HoTT HIT.Truncations.

(** If ||Σ n, f n = 0||, then Σ n, f n = 0 *)
(** This method is similar to the "ConstructiveEpsilon" in Coq, adapted to HoTT/hProp. It can be further generalized to arbitrary decidable hProps. *)
Section contents.
  Context `{Univalence}.
  Variable f : nat -> nat.

  Inductive rootD : nat -> Type :=
  | is_root : forall {n}, f n = 0 -> rootD n
  | root_step : forall {n}, f n <> 0 -> rootD (S n) -> rootD n.

  (* Here we use the fact that 'nat' is an hset, hence
     ||f n = 0|| = (f n = 0) *)
  Instance rootD_hprop n : IsHProp (rootD n).
  Proof.
    apply hprop_allpath.
    intros x y. induction y as [n p|n p].
    - destruct x as [n q|n q].
      + f_ap. apply path_ishprop.
      + refine (Empty_rec (q p)).
    - destruct x as [n q|n q].
      + refine (Empty_rec (p q)).
      + f_ap. apply path_ishprop.
  Defined.

  Lemma rootD_step n (y : rootD n) (w : ~ (f n = 0)) : rootD (S n).
  Proof.
    induction y.
    - refine (Empty_rec (w p)).
    - apply y.
  Defined.

  Fixpoint search n (w : rootD n) {struct w} : sig (fun n => f n = 0).
  Proof.
    destruct (dec_paths (f n) 0) as [p | p].
    - exists n. apply p.
    - apply (search (S n)).
      apply rootD_step; assumption.
  Defined.

  Lemma downclosure n : rootD n -> rootD 0.
  Proof.
    induction n.
    - exact idmap.
    - intros Hr. apply IHn.
      destruct (dec_paths (f n) 0) as [p | p].
      + by apply is_root.
      + by apply root_step.
  Defined.

  Theorem witness :
    Trunc -1 (sig (fun n => f n = 0)) -> sig (fun n => f n = 0).
  Proof.
    intros root.
    apply (search 0).
    strip_truncations.
    destruct root as [n Hroot].
    apply (downclosure n).
    by apply is_root.
  Defined.

End contents.


Require Export Category.Core Functor.Core Functor.Composition Functor.Identity.
Require Import Common Functor.Equality.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope morphism_scope.

Section IdentityFunctorLemmas.
  Variable C : PreCategory.
  Variable D : PreCategory.

  Context `{Funext}.

  Local Open Scope functor_scope.

  Local Transparent ComposeFunctors_FIdentityOf.
  Local Transparent ComposeFunctors_FCompositionOf.

  Lemma LeftIdentityFunctor (F : Functor D C) : IdentityFunctor _ ∘ F = F.
  Proof.
    functor_eq.
  Defined.

  Lemma RightIdentityFunctor (F : Functor C D) : F ∘ IdentityFunctor _ = F.
  Proof.
    functor_eq.
  Defined.

  Definition LeftIdentityFunctor_fst F : ap ObjectOf (LeftIdentityFunctor F) = idpath
    := @Functor_eq'_sig_fst _ _ _ (IdentityFunctor C ∘ F) F 1%path 1%path.

  Definition RightIdentityFunctor_fst F : ap ObjectOf (RightIdentityFunctor F) = idpath
    := @Functor_eq'_sig_fst _ _ _ (F ∘ IdentityFunctor C) F 1%path 1%path.
End IdentityFunctorLemmas.

Hint Rewrite @LeftIdentityFunctor @RightIdentityFunctor : category.
Hint Rewrite @LeftIdentityFunctor @RightIdentityFunctor : functor.
Hint Immediate @LeftIdentityFunctor @RightIdentityFunctor : category functor.

Section FunctorCompositionLemmas.
  Variable B : PreCategory.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable E : PreCategory.

  Context `{H0 : Funext}.

  Local Open Scope functor_scope.

  Local Transparent ComposeFunctors_FCompositionOf.
  Local Transparent ComposeFunctors_FIdentityOf.

  Lemma ComposeFunctorsAssociativity (F : Functor B C) (G : Functor C D) (H : Functor D E)
  : (H ∘ G) ∘ F = H ∘ (G ∘ F).
  Proof.
    functor_eq.
  Defined.

  Definition ComposeFunctorsAssociativity_fst F G H
  : ap ObjectOf (ComposeFunctorsAssociativity F G H) = idpath
    := @Functor_eq'_sig_fst _ _ _ (H ∘ G ∘ F) (H ∘ (G ∘ F)) 1%path 1%path.
End FunctorCompositionLemmas.

Hint Resolve @ComposeFunctorsAssociativity : category functor.

Opaque ComposeFunctorsAssociativity LeftIdentityFunctor RightIdentityFunctor.


(* $Id$ *)

Section puzzle.

Parameters Scottish RedSocks WearKilt Married GoOutSunday : Prop.

Hypothesis rule1 : ~ Scottish -> RedSocks.
Hypothesis rule2 : WearKilt \/ ~ RedSocks.
Hypothesis rule3 : Married -> ~ GoOutSunday.
Hypothesis rule4 : GoOutSunday <-> Scottish.
Hypothesis rule5 : WearKilt -> Scottish /\ Married.
Hypothesis rule6 : Scottish -> WearKilt.

Lemma NoMember : False.
Proof.
  apply rule3.
  apply rule5.
  elim rule2.
  intro.
  assumption.
  intro.
  apply rule6.
  elim H.
  apply rule1.
  intro.
  apply rule3.
  apply rule5.
  apply rule6.
  assumption.
  apply rule4.
  assumption.
  apply rule4.
  elim rule2.
  intro.
  apply rule5.
  assumption.
  intro.
  elim H.
  apply rule1.
  intro.
  apply rule3.
  apply rule5.
  apply rule6.
  assumption.
  apply rule4.
  assumption.
Qed.

End puzzle.


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import HoTT.Basics HoTT.Types.
Require Import HProp UnivalenceImpliesFunext Fibrations.
Require Import Modalities.Modality HoTT.Truncations.
Import TrM.
Require Import Spaces.BAut Spaces.BAut.Rigid.
Require Import ExcludedMiddle.

Local Open Scope trunc_scope.
Local Open Scope path_scope.

(** * The universe *)

(** ** Automorphisms of the universe *)

(** See "Parametricity, automorphisms of the universe, and excluded middle" by Booij, Escardo, Lumsdaine, Shulman. *)

(** If two inequivalent types have equivalent automorphism oo-groups, then assuming LEM we can swap them and leave the rest of the universe untouched. *)
Section SwapTypes.
  (** Amusingly, this does not actually require univalence!  But of course, to verify [BAut A <~> BAut B] in any particular example does require univalence. *)
  Context `{Funext} `{ExcludedMiddle}.
  Context (A B : Type) (ne : ~(A <~> B)) (e : BAut A <~> BAut B).

  Definition equiv_swap_types : Type <~> Type.
  Proof.
    refine (((equiv_decidable_sum (fun X:Type => merely (X=A)))^-1)
              oE _ oE
              (equiv_decidable_sum (fun X:Type => merely (X=A)))).
    refine ((equiv_functor_sum_l
               (equiv_decidable_sum (fun X => merely (X.1=B)))^-1)
              oE _ oE
              (equiv_functor_sum_l
                 (equiv_decidable_sum (fun X => merely (X.1=B))))).
    refine ((equiv_sum_assoc _ _ _)
              oE _ oE
              (equiv_sum_assoc _ _ _)^-1).
    apply equiv_functor_sum_r.
    assert (q : BAut B <~> {x : {x : Type & ~ merely (x = A)} &
                                merely (x.1 = B)}).
    { refine (equiv_sigma_assoc _ _ oE _).
      apply equiv_functor_sigma_id; intros X.
      apply equiv_iff_hprop.
      - intros p.
        refine (fun q => _ ; p).
        strip_truncations.
        destruct q.
        exact (ne (equiv_path X B p)).
      - exact pr2. }
    refine (_ oE equiv_sum_symm _ _).
    apply equiv_functor_sum'.
    - exact (e^-1 oE q^-1).
    - exact (q oE e).
  Defined.

  Definition equiv_swap_types_swaps : merely (equiv_swap_types A = B).
  Proof.
    assert (ea := (e (point _)).2). cbn in ea.
    strip_truncations; apply tr.
    unfold equiv_swap_types.
    apply moveR_equiv_V.
    rewrite (equiv_decidable_sum_l
               (fun X => merely (X=A)) A (tr 1)).
    assert (ne' : ~ merely (B=A))
      by (intros p; strip_truncations; exact (ne (equiv_path A B p^))).
    rewrite (equiv_decidable_sum_r
               (fun X => merely (X=A)) B ne').
    cbn.
    apply ap, path_sigma_hprop; cbn.
    exact ea.
  Defined.

  Definition equiv_swap_types_not_id
    : equiv_swap_types <> equiv_idmap.
  Proof.
    intros p.
    assert (q := equiv_swap_types_swaps).
    strip_truncations.
    apply ne.
    apply equiv_path.
    rewrite p in q; exact q.
  Qed.

End SwapTypes.

(** In particular, we can swap any two distinct rigid types. *)

Definition equiv_swap_rigid `{Univalence} `{ExcludedMiddle}
           (A B : Type) `{IsRigid A} `{IsRigid B} (ne : ~(A <~> B))
  : Type <~> Type.
Proof.
  refine (equiv_swap_types A B ne _).
  apply equiv_contr_contr.
Defined.

(** Such as [Empty] and [Unit]. *)

Definition equiv_swap_empty_unit `{Univalence} `{ExcludedMiddle}
  : Type <~> Type
  := equiv_swap_rigid Empty Unit (fun e => e^-1 tt).

(** In this case we get an untruncated witness of the swapping. *)

Definition equiv_swap_rigid_swaps `{Univalence} `{ExcludedMiddle}
           (A B : Type) `{IsRigid A} `{IsRigid B} (ne : ~(A <~> B))
  : equiv_swap_rigid A B ne A = B.
Proof.
  unfold equiv_swap_rigid, equiv_swap_types.
  apply moveR_equiv_V.
  rewrite (equiv_decidable_sum_l
             (fun X => merely (X=A)) A (tr 1)).
  assert (ne' : ~ merely (B=A))
    by (intros p; strip_truncations; exact (ne (equiv_path A B p^))).
  rewrite (equiv_decidable_sum_r
             (fun X => merely (X=A)) B ne').
  cbn.
  apply ap, path_sigma_hprop; cbn.
  exact ((path_contr (center (BAut B)) (point (BAut B)))..1).
Defined.

(** We can also swap the products of two rigid types with another type [X], under a connectedness/truncatedness assumption. *)

Definition equiv_swap_prod_rigid  `{Univalence} `{ExcludedMiddle}
           (X A B : Type) (n : trunc_index) (ne : ~(X*A <~> X*B))
           `{IsRigid A} `{IsConnected n.+1 A}
           `{IsRigid B} `{IsConnected n.+1 B}
           `{IsTrunc n.+1 X}
  : Type <~> Type.
Proof.
  refine (equiv_swap_types (X*A) (X*B) ne _).
  transitivity (BAut X).
  - symmetry; exact (baut_prod_rigid_equiv X A n).
  - exact (baut_prod_rigid_equiv X B n).
Defined.

(** Conversely, from some nontrivial automorphisms of the universe we can deduce nonconstructive consequences. *)

Definition lem_from_aut_type_unit_empty `{Univalence}
           (f : Type <~> Type) (eu : f Unit = Empty)
  : ExcludedMiddle_type.
Proof.
  apply DNE_to_LEM, DNE_from_allneg; intros P ?.
  exists (f P); split.
  - intros p.
    assert (Contr P) by (apply contr_inhabited_hprop; assumption).
    assert (q : Unit = P)
      by (apply path_universe_uncurried, equiv_contr_contr).
    destruct q.
    rewrite eu.
    auto.
  - intros nfp.
    assert (q : f P = Empty)
      by (apply path_universe_uncurried, equiv_to_empty, nfp).
    rewrite <- eu in q.
    apply ((ap f)^-1) in q.
    rewrite q; exact tt.
Defined.

Lemma equiv_hprop_idprod `{Univalence}
      (A : Type) (P : Type) (a : merely A) `{IsHProp P}
  : P <-> (P * A = A).
Proof.
  split.
  - intros p; apply path_universe with snd.
    apply isequiv_adjointify with (fun a => (p,a)).
    + intros x; reflexivity.
    + intros [p' x].
      apply path_prod; [ apply path_ishprop | reflexivity ].
  - intros q.
    strip_truncations.
    apply equiv_path in q.
    exact (fst (q^-1 a)).
Defined.

Definition lem_from_aut_type_inhabited_empty `{Univalence}
           (f : Type <~> Type)
           (A : Type) (a : merely A) (eu : f A = Empty)
  : ExcludedMiddle_type.
Proof.
  apply DNE_to_LEM, DNE_from_allneg; intros P ?.
  exists (f (P * A)); split.
  - intros p.
    assert (q := fst (equiv_hprop_idprod A P a) p).
    apply (ap f) in q.
    rewrite eu in q.
    rewrite q; auto.
  - intros q.
    apply equiv_to_empty in q.
    apply path_universe_uncurried in q.
    rewrite <- eu in q.
    apply ((ap f)^-1) in q.
    exact (snd (equiv_hprop_idprod A P a) q).
Defined.

(** If you can derive a constructive taboo from an automorphism of the universe such that [g X <> X], then you get [X]-many beers; see <https://groups.google.com/d/msg/homotopytypetheory/8CV0S2DuOI8/blCo7x-B7aoJ>. *)

Definition zero_beers `{Univalence}
           (g : Type <~> Type) (ge : g Empty <> Empty)
  : ~~ExcludedMiddle_type.
Proof.
  pose (f := equiv_inverse g).
  intros nlem.
  apply ge.
  apply path_universe_uncurried, equiv_to_empty; intros gz.
  apply nlem.
  apply (lem_from_aut_type_inhabited_empty f (g Empty) (tr gz)).
  unfold f; apply eissect.
Defined.

Definition lem_beers `{Univalence}
           (g : Type <~> Type) (ge : g ExcludedMiddle_type <> ExcludedMiddle_type)
  : ~~ExcludedMiddle_type.
Proof.
  intros nlem.
  pose (nlem' := equiv_to_empty nlem).
  apply path_universe_uncurried in nlem'.
  rewrite nlem' in ge.
  apply (zero_beers g) in ge.
  exact (ge nlem).
Defined.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega Extraction.
Require Import list_utils wf_utils bt bft bft_spec bft_inj fifo_axm bfn_gen.

Set Implicit Arguments.

Local Definition fifo_sum { X } (q : fifo (bt X)) := lsum (fifo_list q).

Section bfr_gen.

  Variable (X Y : Type).

  Notation fifo_X := (fifo (bt X)).
  Notation fifo_Y := (fifo (bt Y)).

  Implicit Type (p : fifo_X) (ll : list Y).

  Fixpoint bfr_gen_f p (ll : list Y) { struct ll } :
            fifo_sum p = length ll
         -> { q  | fifo_list p ~lt rev (fifo_list q)
                /\ bft_f (rev (fifo_list q)) = ll }.
  Proof.
    unfold fifo_sum in *.
    refine (match ll with
      | nil   => fun Hll => let (q,Hq)   := fifo_nil
                            in  exist _ q _
      | y::mm => fun Hll => let (d1,Hd1) := fifo_deq p _
                            in  _
    end).
    all: cycle 2.
    revert Hd1; refine (match d1 with (t,p1) => _ end); intros Hp1.
    rewrite Hp1 in Hll; simpl in Hll; clear d1.
    revert Hll Hp1; refine (match t with
      | leaf x     => fun Hll Hp1 => let (q,Hq)   := bfr_gen_f p1 mm _ in
                                     let (q1,Hq1) := fifo_enq q (leaf y)
                                     in  exist _ q1 _
      | node a x b => fun Hll Hp1 => let (p2,Hp2) := fifo_enq p1 a     in
                                     let (p3,Hp3) := fifo_enq p2 b     in
                                     let (q,Hq)   := bfr_gen_f p3 mm _ in
                                     let (d2,Hd2) := fifo_deq q _
                                     in  _
    end); auto.
    all: cycle 3.
    revert Hd2; refine (match d2 with
      | (u,q1) => fun Hd2 => let (d3,Hd3) := fifo_deq q1 _
                             in  _
    end).
    all: cycle 1.
    revert Hd3; refine (match d3 with
      | (v,q2) => fun Hd3 => let (q3,Hq3) := fifo_enq q2 (node v y u)
                             in  exist _ q3 _
    end).
    all: cycle 1.

    * revert Hll; rewrite Hq; simpl.
      generalize (fifo_list p).
      intros [ | [] ? ]; simpl; try discriminate.
      split; auto.
      rewrite bft_f_fix_0; auto.
    * intros E; rewrite E in Hll; discriminate.
    * destruct Hq as (Hq2 & Hq3).
      rewrite Hp1, Hq1, rev_app_distr; split; simpl; auto.
      rewrite bft_f_fix_3, <- app_nil_end, Hq3; auto.
    * rewrite Hp3, Hp2; repeat rewrite lsum_app; simpl in Hll |- *; omega.
    * destruct Hq as (Hq_1 & Hq_2);
      apply Forall2_rev in Hq_1; rewrite rev_involutive in Hq_1.
      intros H; rewrite H, Hp3, rev_app_distr in Hq_1; inversion Hq_1.
    * destruct Hq as (Hq_1 & Hq_2).
      apply Forall2_rev in Hq_1; rewrite rev_involutive in Hq_1.
      intros H; rewrite Hd2, H, Hp3, Hp2 in Hq_1.
      repeat rewrite rev_app_distr in Hq_1.
      inversion Hq_1.
      inversion H5.
    * destruct Hq as (Hq_1 & Hq_2).
      apply Forall2_rev in Hq_1; rewrite rev_involutive in Hq_1.
      simpl in *.
      rewrite Hp1, Hq3, rev_app_distr; simpl.
      rewrite Hp3, Hp2, Hd2, Hd3 in Hq_1.
      repeat rewrite rev_app_distr in Hq_1.
      simpl in Hq_1.
      apply Forall2_cons_inv in Hq_1; destruct Hq_1 as (Hq_3 & Hq_1).
      apply Forall2_cons_inv in Hq_1; destruct Hq_1 as (Hq_4 & Hq_1).
      apply Forall2_rev in Hq_1.
      rewrite rev_involutive in Hq_1.
      split; auto.
      rewrite bft_f_fix_3; simpl; f_equal.
      rewrite <- Hq_2, Hd2, Hd3; f_equal; simpl.
      rewrite app_ass; auto.
  Defined.

  Section bfr.

    Let bfr_gen_full (t : bt X) (l : list Y) : m_bt t = length l -> { t' | t ~t t' /\ bft_std t' = l }.
    Proof.
      intros H.
      refine (let (p,Hp) := @fifo_nil _     in
              let (q,Hq) := fifo_enq p t    in
              let (r,Hr) := bfr_gen_f q l _ in
              let (d1,Hd1) := fifo_deq r _
              in _).
      all: cycle 2.
      revert Hd1; refine(match d1 with
        | (t',q') => fun Hd1 => exist _ t' _
      end).
      all: cycle 1.

      + unfold fifo_sum.
        rewrite Hq, Hp, <- H; simpl; omega.
      + intros E; rewrite E in Hr; apply proj2 in Hr; simpl in Hr.
        rewrite bft_f_fix_0 in Hr; subst.
        generalize (m_bt_ge_1 t); simpl in *; omega.
      + destruct Hr as (Hr_1 & Hr_2); simpl in Hd1.
        apply Forall2_rev in Hr_1.
        rewrite Hq, Hp, rev_involutive, Hd1 in Hr_1; simpl in Hr_1.
        apply Forall2_cons_inv in Hr_1.
        destruct Hr_1 as (Hr_3 & Hr_1).
        apply Forall2_nil_inv_right in Hr_1.
        split; auto.
        rewrite Hd1, Hr_1 in Hr_2.
        simpl in Hr_2.
        rewrite <- bft_eq_bft_std; auto.
    Qed.

    Definition bfr_gen t l H := proj1_sig (bfr_gen_full t l H).

    Fact bfr_gen_spec_1 t l H : t ~t bfr_gen t l H.
    Proof. apply (proj2_sig (bfr_gen_full t l H)). Qed.

    Fact bfr_gen_spec_2 t l H : bft_std (bfr_gen t l H) = l.
    Proof. apply (proj2_sig (bfr_gen_full t l H)). Qed.

  End bfr.

End bfr_gen.

Theorem bfr_bfn_gen X (t : bt X) : bfn_gen t = bfr_gen t (seq_an 0 (m_bt t)) (eq_sym (seq_an_length _ _)).
Proof.
  apply bft_std_inj.
  * apply bt_eq_trans with (s := t).
    + apply bt_eq_sym, bfn_gen_spec_1.
    + apply bfr_gen_spec_1.
  * rewrite bfr_gen_spec_2, bfn_gen_spec_3; trivial.
Qed.

Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Inductive nat => int [ "0" "succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))".

Recursive Extraction bfr_gen.

Check bfr_gen.
Check bfr_gen_spec_1.
Check bfr_gen_spec_2.

(** BFN (Breadth-First Numbering) is a particular instance of
    BFR (Breadth-First Reconstruction)   *)


Require Import Omega.
Require Import List.

Require Import StructTact.StructTactics.
Require Import StructTact.FilterMap.
Require Import InfSeqExt.infseq.
Require Import InfSeqExt.classical.
Require Import Chord.InfSeqTactics.
Require Import Chord.Chord.
Require Import Chord.LabeledLemmas.

(** This shouldn't live here but I'm not sure where it should live *)
Lemma nat_strong_ind :
  forall (P : nat -> Prop),
    (forall n, (forall m, m < n -> P m) -> P n) ->
    forall n, P n.
Proof.
  intros P Himp.
  intros.
  (* generalize induction hypothesis *)
  cut (forall m, m < n -> P m); [now auto|].
  induction n.
  - easy.
  - firstorder.
Qed.

Section Measure.

  Variable measure : global_state -> nat.
  Notation "| gst |" := (measure gst) (at level 50).

  Definition measure_bounded (n : nat) : infseq occurrence -> Prop :=
    always (now (fun o => |occ_gst o| <= n)).

  Definition measure_nonincreasing (o o' : occurrence) : Prop :=
    |occ_gst o'| <= |occ_gst o|.

  Definition measure_decreasing (o o' : occurrence) : Prop :=
    |occ_gst o'| < |occ_gst o|.

  Definition measure_zero (o : occurrence) : Prop :=
    |occ_gst o| = 0.

  Definition zero_or_eventually_decreasing : infseq occurrence -> Prop :=
    now measure_zero \/_
    eventually (consecutive measure_decreasing).

  Lemma measure_nonincreasing_stays_zero :
    forall o o',
      measure_nonincreasing o o' ->
      measure_zero o ->
      measure_zero o'.
  Proof.
    unfold measure_nonincreasing, measure_zero.
    intros.
    omega.
  Qed.

  Lemma measure_zero_stays_zero :
    forall ex,
      always (consecutive measure_nonincreasing) ex ->
      now measure_zero ex ->
      always (now measure_zero) ex.
  Proof.
    cofix c.
    intros.
    constructor; auto.
    do 2 destruct ex; simpl in *.
    apply c.
    - eauto using always_invar.
    - inv_prop always.
      unfold consecutive in *.
      simpl.
      eauto using measure_nonincreasing_stays_zero.
  Qed.

  Lemma measure_bounded_hd_elim :
    forall m n ex,
      measure_bounded n ex ->
      |occ_gst (hd ex)| = m ->
      m <= n.
  Proof.
    intros; destruct ex.
    now inv_prop measure_bounded.
  Qed.

  Lemma measure_bounded_monotonic :
    forall m n ex,
      m <= n ->
      measure_bounded m ex ->
      measure_bounded n ex.
  Proof.
    cofix c.
    intros.
    constructor; destruct ex as [o [o' ex]]; simpl in *.
    - inv_prop measure_bounded; simpl in *.
      omega.
    - eapply c; eauto.
      eapply always_invar; eauto.
  Qed.

  (** If the measure never increases and you can bound the measure of the first
      state, you can bound the entire sequence. *)
  Lemma nonincreasing_preserves_bound :
    forall ex,
      always (consecutive measure_nonincreasing) ex ->
      forall n,
        |occ_gst (hd ex)| <= n ->
        measure_bounded n ex.
  Proof.
    cofix c.
    constructor; destruct ex as [o [o' ex]]; simpl in *; [omega|].
    eapply c.
    - eauto using always_invar.
    - inv_prop measure_nonincreasing.
      unfold measure_nonincreasing in *.
      simpl in *.
      omega.
  Qed.

  (** If the measure never increases, you can bound the entire sequence by the
      measure of the first state. *)
  Lemma nonincreasing_global :
    forall ex,
      always (consecutive measure_nonincreasing) ex ->
      forall n,
        |occ_gst (hd ex)| = n ->
        measure_bounded n ex.
  Proof.
    auto using Nat.eq_le_incl, nonincreasing_preserves_bound.
  Qed.

  (** If the measure never increases and drops infinitely often, then it will
      eventually be less than its initial value (provided the initial value is
      nonzero). *)
  Lemma measure_drops :
    forall ex,
      always (consecutive measure_nonincreasing) ex ->
      zero_or_eventually_decreasing ex ->
      forall n,
        |occ_gst (hd ex)| = S n ->
        eventually (now (fun o => |occ_gst o| < S n)) ex.
  Proof.
    intros.
    unfold zero_or_eventually_decreasing in *.
    find_copy_apply_lem_hyp nonincreasing_global; auto.
    invc H0.
    - destruct ex.
      simpl in *.
      congruence.
    - match goal with
      | H : eventually (consecutive measure_decreasing) _ |- _ =>
        induction H
      end.
      + destruct s as [o [o' s]].
        apply E_next; apply E0.
        unfold measure_decreasing in *.
        simpl in *; omega.
      + simpl.
        destruct s as [o s].
        destruct (lt_dec (|occ_gst o|) (|occ_gst x|)).
        * apply E_next; apply E0.
          simpl in *; omega.
        * assert (|occ_gst o| = |occ_gst x|).
          {
            find_apply_lem_hyp not_lt.
            apply Nat.le_antisymm; auto.
            inv_prop (always (consecutive measure_nonincreasing)).
            unfold measure_nonincreasing in *.
            auto.
          }
          apply E_next.
          simpl in *.
          repeat find_rewrite.
          eapply IHeventually; eauto;
            try eapply always_invar; eauto.
  Qed.

  Lemma less_than_Sn_bounded_n :
    forall n ex,
      always (consecutive measure_nonincreasing) ex ->
      now (fun occ => |occ_gst occ| < S n) ex ->
      measure_bounded n ex.
  Proof.
    intros.
    remember (|occ_gst (hd ex)|) as m.
    eapply measure_bounded_monotonic;
      [|eauto using nonincreasing_global].
    destruct ex; simpl in *; omega.
  Qed.

  Lemma measure_bound_drops :
    forall n ex,
      measure_bounded (S n) ex ->
      always (consecutive measure_nonincreasing) ex ->
      zero_or_eventually_decreasing ex ->
      eventually (measure_bounded n) ex.
  Proof.
    intros.
    destruct ex as [o ex].
    destruct (|occ_gst o|) eqn:?H.
    - apply E0.
      eapply measure_bounded_monotonic with (m:=0); [omega|].
      eapply nonincreasing_global; eauto.
    - find_copy_eapply_lem_hyp nonincreasing_global; eauto.
      eapply eventually_monotonic_simple.
      {
        intros; eapply (measure_bounded_monotonic n0 n); eauto.
        apply le_S_n.
        eapply measure_bounded_hd_elim; eauto.
      }
      eapply eventually_monotonic; try eapply less_than_Sn_bounded_n; eauto using always_invar.
      eapply measure_drops; eauto.
  Qed.

  Lemma measure_bounded_zero :
    forall ex,
      measure_bounded 0 ex ->
      always (now measure_zero) ex.
  Proof.
    cofix c.
    intros; constructor.
    - inv_prop measure_bounded.
      destruct ex; simpl in *.
      unfold measure_zero; omega.
    - destruct ex.
      simpl in *.
      apply c.
      eapply always_invar; eauto.
  Qed.

  (** TODO(ryan) move to infseq *)
  Lemma eventually_idempotent :
    forall T (P : infseq T -> Prop) ex,
      eventually (eventually P) ex ->
      eventually P ex.
  Proof.
    intros T P ex H_ee.
    induction H_ee.
    - assumption.
    - now apply E_next.
  Qed.

  (* Lemma decreasing_inf_often_or_zero_invar_when_nonincreasing : *)
    (* forall o ex, *)
      (* always (consecutive measure_nonincreasing) (Cons o ex) -> *)
      (* zero_or_eventually_decreasing (Cons o ex) -> *)
      (* zero_or_eventually_decreasing ex. *)
  (* Proof. *)
    (* unfold zero_or_eventually_decreasing. *)
    (* intros. *)
    (* inv_prop or_tl. *)
    (* - left. *)
      (* find_apply_lem_hyp measure_zero_stays_zero; auto. *)
      (* find_apply_lem_hyp always_invar. *)
      (* now inv_prop always. *)
    (* - right; eapply inf_often_invar; eauto. *)
  (* Qed. *)

  Lemma measure_decreasing_to_zero' :
    forall n ex,
      always (consecutive measure_nonincreasing) ex ->
      always zero_or_eventually_decreasing ex ->
      measure_bounded n ex ->
      eventually (now measure_zero) ex.
  Proof.
    intros n.
    induction n using nat_strong_ind.
    destruct n; subst_max.
    - intros.
      apply E0.
      find_apply_lem_hyp measure_bounded_zero.
      inv_prop always.
      assumption.
    - intros.
      destruct ex.
      find_copy_apply_lem_hyp measure_bound_drops;
        auto;
        try now apply always_now.
      pose proof (H n).
      forwards.
      omega.
      specialize (H4 H5); clear H5.
      eapply eventually_idempotent.
      lift_eventually H4.
      + unfold and_tl; intros; break_and_goal; break_and;
          eauto using always_invar.
      + split; auto.
  Qed.

  Lemma measure_decreasing_to_zero :
    forall ex,
      always zero_or_eventually_decreasing ex ->
      always (consecutive measure_nonincreasing) ex ->
      continuously (now measure_zero) ex.
  Proof.
    intros.
    remember (|occ_gst (hd ex)|) as n.
    find_copy_eapply_lem_hyp nonincreasing_global; auto.
    find_copy_eapply_lem_hyp measure_decreasing_to_zero'; eauto.
    lift_eventually measure_zero_stays_zero.
    eauto using always_invar.
  Qed.

  (* TODO(ryan) move to infseq *)
  Lemma eventually_and_tl_comm :
    forall T (P Q : infseq T -> Prop) s,
      eventually (P /\_ Q) s ->
      eventually (Q /\_ P) s.
  Proof.
    intros until 0.
    apply eventually_monotonic_simple.
    intros.
    now rewrite and_tl_comm.
  Qed.

  (* TODO(ryan) move to infseq *)
  Lemma always_and_tl_comm :
    forall T (P Q : infseq T -> Prop) s,
      always (P /\_ Q) s ->
      always (Q /\_ P) s.
  Proof.
    intros until 0.
    apply always_monotonic.
    intros.
    now rewrite and_tl_comm.
  Qed.

  Definition measure_x x occ := |occ_gst occ| = x.

  Set Bullet Behavior "Strict Subproofs".

  Require Import Classical.
  Lemma always_or_eventually :
    forall T P (s : infseq T),
      always P s \/ eventually (not_tl P) s.
  Proof.
    intros.
    destruct (classic (always P s)); eauto using not_always_eventually_not.
  Qed.

  Lemma eventually_exists :
    forall T A (P : A -> T -> Prop) (s : infseq T),
      eventually (now (fun o => exists x, P x o)) s ->
      exists x,
        eventually (now (fun o => P x o)) s.
  Proof.
    intros.
    induction H.
    - destruct s. simpl in *.
      break_exists_exists.
      apply E0. simpl. auto.
    - break_exists_exists.
      apply E_next. auto.
  Qed.

  Lemma eventually_exists' :
    forall T A (P : A -> infseq T -> Prop) (s : infseq T),
      eventually (fun s => exists x, P x s) s ->
      exists x,
        eventually (P x) s.
  Proof.
    intros.
    induction H.
    - break_exists_exists.
      eauto using E0.
    - break_exists_exists. eauto using E_next.
  Qed.

  Lemma eventually_pure_and :
    forall T (Q : Prop) (P : T -> Prop) (s : infseq T),
      eventually (now (fun o => Q /\ P o)) s ->
      Q /\ eventually (now P) s.
  Proof.
    induction 1.
    - destruct s; simpl in *; intuition.
      eauto using E0.
    - intuition. eauto using E_next.
  Qed.

  Lemma measure_nonincreasing_eventually_stable' :
    forall n ex,
      (now (measure_x n) ex) ->
      always (consecutive measure_nonincreasing) ex ->
      exists x,
        continuously (now (measure_x x)) ex.
  Proof.
    induction n using nat_strong_ind.
    intros.
    destruct (always_or_eventually _ (now (measure_x n)) ex).
    - eauto using always_continuously.
    - find_copy_eapply_lem_hyp nonincreasing_preserves_bound; eauto.
      assert (|occ_gst (hd ex)| = n).
      {
        unfold now in *. break_match; repeat find_rewrite; simpl; auto.
      }
      repeat find_rewrite.
      assert (exists m, m < n /\ eventually (now (measure_x m)) ex).
      {
        unfold measure_bounded in *.
        find_eapply_lem_hyp cumul_eventually_always; eauto.
        assert (eventually (now (fun o => exists m, m < n /\ measure_x m o)) ex).
        {
          eapply eventually_monotonic_simple; [|eauto].
          intros.
          unfold now; break_match. subst.
          exists (|occ_gst o|). unfold measure_x. intuition.
          unfold and_tl,not_tl in *. intuition. simpl in *.
          unfold measure_x in *.
          omega.
        }
        find_apply_lem_hyp eventually_exists.
        break_exists_exists.
        eauto using eventually_pure_and.
      }
      break_exists. intuition.
      match goal with
      | H : eventually (now _) _ |- _ =>
        eapply eventually_monotonic with
            (J := (always (consecutive measure_nonincreasing)))
            (Q := (fun ex => exists x, continuously (now (measure_x x)) ex))
          in H
      end; eauto using always_invar.
      find_apply_lem_hyp eventually_exists'.
      break_exists_exists.
      unfold continuously in *.
      eauto using eventually_idempotent.
  Qed.

  Lemma measure_nonincreasing_eventually_stable :
    forall ex,
      always (consecutive measure_nonincreasing) ex ->
      exists x,
        continuously (now (measure_x x)) ex.
  Proof.
    intros.
    assert (now (measure_x (|occ_gst (hd ex)|)) ex).
    { unfold measure_x. destruct ex; simpl; auto. }
    eauto using measure_nonincreasing_eventually_stable'.
  Qed.

End Measure.

Section LocalMeasure.
  Variable local_measure : addr -> global_state -> nat.
  Notation "| h 'in' gst |" := (local_measure h gst) (at level 50).

  Definition sum (l : list nat) :=
    fold_left Nat.add l 0.

  Definition max (l : list nat) :=
    fold_left Nat.max l 0.

  Lemma fold_left_acc_comm :
    forall a l,
      fold_left Nat.add l a = a + fold_left Nat.add l 0.
  Proof.
    intros.
    generalize a.
    induction l; [auto|].
    simpl.
    intros.
    rewrite IHl; symmetry; rewrite IHl.
    auto with arith.
  Qed.

  Lemma fold_left_max_comm :
    forall a l,
      fold_left Nat.max l a = Nat.max a (fold_left Nat.max l 0).
  Proof.
    intros.
    generalize a.
    induction l; intros.
    - simpl; zify; omega.
    - simpl.
      rewrite IHl; symmetry; rewrite IHl.
      zify; omega.
  Qed.

  Lemma sum_cons :
    forall n l,
      sum (n :: l) = n + sum l.
  Proof.
    unfold sum.
    intros; simpl.
    now rewrite fold_left_acc_comm.
  Qed.

  Lemma max_cons_le :
    forall n l,
      n <= max (n :: l).
  Proof.
    intros. generalize n; clear n.
    induction l; intros; simpl in *; auto.
    unfold max in *. simpl in *.
    eapply le_trans; [eapply Nat.le_max_l|]; eauto.
  Qed.

  Lemma max_cons_cases :
    forall n l,
      max (n :: l) = n /\
      max l <= n \/
      max (n :: l) = max l /\
      n <= max l.
  Proof.
    intros. unfold max.
    repeat (rewrite fold_symmetric; eauto using Max.max_assoc, Max.max_comm).
    simpl.
    match goal with
    | |- context [Nat.max ?n ?m] =>
      destruct (Nat.max_spec n m)
    end; intuition.
  Qed.

  Lemma sum_app :
    forall l l',
      sum (l ++ l') = sum l + sum l'.
  Proof.
    unfold sum.
    intros; simpl.
    now rewrite fold_left_app, fold_left_acc_comm.
  Qed.

  Lemma sum_disjoint :
    forall xs x ys,
      sum (xs ++ x :: ys) = sum xs + x + sum ys.
  Proof.
    intros.
    now rewrite sum_app, sum_cons, Nat.add_assoc.
  Qed.

  Lemma sum_map_mono :
    forall X (f g : X -> nat) l,
      (forall x, In x l -> f x <= g x) ->
      sum (map f l) <= sum (map g l).
  Proof.
    intros.
    induction l; [auto|].
    rewrite !map_cons, !sum_cons.
    apply Nat.add_le_mono; auto with datatypes.
  Qed.

  Lemma max_map_mono :
    forall X (f g : X -> nat) l,
      (forall x, In x l -> f x <= g x) ->
      max (map f l) <= max (map g l).
  Proof.
    intros.
    induction l; [auto|].
    forwards. eauto with datatypes. concludes.
    pose proof (max_cons_le (g a) (map g l)).
    assert (f a <= g a) by eauto with datatypes.
    pose proof (max_cons_cases (f a) (map f l)).
    pose proof (max_cons_cases (g a) (map g l)).

    rewrite !map_cons.
    intuition omega.
  Qed.

  (* TODO(ryan) move to structtact *)
  Theorem list_strong_ind :
    forall A (P : list A -> Prop),
      (forall l, (forall l', length l' < length l -> P l') ->
            P l) ->
      forall l0 : list A, P l0.
  Proof.
    intros.
    apply H.
    induction l0; simpl;
      firstorder using Nat.nlt_0_r, lt_n_Sm_le, lt_le_trans.
  Qed.

  Lemma fold_max_const_is_const :
    forall l c,
      (forall x, In x l -> x = c) ->
      fold_left Nat.max l c = c.
  Proof.
    unfold max.
    induction l; intros.
    - cbn in *; omega.
    - replace a with c; [|symmetry; auto with datatypes].
      simpl.
      rewrite Max.max_idempotent.
      eauto with datatypes.
  Qed.

  Lemma max_nonempty_const_is_const :
    forall l c,
      (forall x, In x l -> x = c) ->
      length l > 0 ->
      max l = c.
  Proof.
    unfold max.
    intros.
    destruct l as [|a l].
    - cbn in *; omega.
    - replace a with c; [|symmetry; auto with datatypes].
      cbn; apply fold_max_const_is_const; auto with datatypes.
  Qed.

  Lemma max_map_bound :
    forall X (f : X -> nat) b l,
      (forall x, In x l -> f x <= b) ->
      max (map f l) <= b.
  Proof.
    intros.
    destruct l as [| h l].
    - auto with arith.
    - replace b with (max (map (fun _ => b) (h :: l)));
        auto using max_map_mono.
      eapply max_nonempty_const_is_const; simpl; auto with arith.
      intros.
      break_or_hyp; [congruence|].
      find_apply_lem_hyp in_map_iff.
      break_exists; break_and; congruence.
  Qed.

  Lemma sum_of_nats_bounds_addends :
    forall l n,
      sum l = n ->
      forall x,
        In x l ->
        x <= n.
  Proof.
    unfold sum.
    intro l.
    induction l using list_strong_ind; destruct l.
    - easy.
    - intros.
      find_apply_lem_hyp in_inv; break_or_hyp.
      + simpl.
        rewrite fold_left_acc_comm.
        omega.
      + simpl. rewrite fold_left_acc_comm.
        assert (x <= fold_left Nat.add l 0).
        { assert (H_len: length l < length (n :: l)) by auto.
          apply (H l H_len); auto.
        }
        omega.
  Qed.

  Lemma sum_of_nats_zero_means_all_zero :
    forall l,
      sum l = 0 ->
      forall x,
        In x l ->
        x = 0.
  Proof.
    intros.
    symmetry.
    apply le_n_0_eq.
    eapply sum_of_nats_bounds_addends; eauto.
  Qed.

  Lemma max_of_nats_bounds_list :
    forall l n,
      max l = n ->
      forall x,
        In x l ->
        x <= n.
  Proof.
    unfold max.
    induction l using list_strong_ind; destruct l as [|a l].
    - easy.
    - intros.
      find_apply_lem_hyp in_inv; break_or_hyp.
      + simpl.
        rewrite fold_left_max_comm.
        zify; omega.
      + assert (x <= fold_left Nat.max l 0)
          by firstorder.
        simpl. rewrite fold_left_max_comm.
        zify; omega.
  Qed.

  Lemma max_of_nats_zero_means_zero :
    forall l,
      max l = 0 ->
      forall x,
        In x l ->
        x = 0.
  Proof.
    intros.
    symmetry.
    apply le_n_0_eq.
    eapply max_of_nats_bounds_list; eauto.
  Qed.

  Lemma sum_of_zeros_is_zero :
    forall l,
      Forall (fun n => n = 0) l ->
      sum l = 0.
  Proof.
    intros.
    induction l; auto.
    inv_prop Forall; auto.
  Qed.

  Lemma sum_nonzero_implies_addend_nonzero :
    forall l,
      sum l > 0 ->
      exists x,
        In x l /\
        x > 0.
  Proof.
    induction l as [|hd rest].
    - cbn.
      intros; omega.
    - intros; rewrite sum_cons in *.
      destruct hd eqn:?H.
      + firstorder.
      + exists hd; firstorder.
  Qed.

  Definition global_measure (gst : global_state) : nat :=
    sum (map (fun h => |h in gst|) (active_nodes gst)).

  Notation "| gst |" := (global_measure gst) (at level 50).

  Definition max_measure (gst : global_state) : nat :=
    max (map (fun h => |h in gst|) (active_nodes gst)).

  Lemma max_measure_bounds_measures :
    forall gst e,
      max_measure gst = e ->
      forall h,
        In h (active_nodes gst) ->
        |h in gst| <= e.
  Proof.
    intros.
    unfold max_measure in *.
    eapply max_of_nats_bounds_list; eauto.
    rewrite in_map_iff.
    eauto.
  Qed.

  Definition max_measure_nonzero_eventually_all_locals_below (ex : infseq occurrence) : Prop :=
    forall err,
      max_measure (occ_gst (hd ex)) = S err ->
      forall h,
        In h (active_nodes (occ_gst (hd ex))) ->
        eventually (now (fun o => |h in occ_gst o| <= err)) ex.

  Definition some_local_measure_drops (ex : infseq occurrence) :=
    exists h,
      In h (active_nodes (occ_gst (hd ex))) /\
      eventually (consecutive (measure_decreasing (local_measure h))) ex.

  Definition local_measure_nonincreasing (h : addr) : infseq occurrence -> Prop :=
    consecutive (measure_nonincreasing (local_measure h)).

  Definition local_measures_nonincreasing (ex : infseq occurrence) : Prop :=
    forall h,
      In h (active_nodes (occ_gst (hd ex))) ->
      local_measure_nonincreasing h ex.

  Lemma map_Forall_comm :
    forall (X Y : Type) (f : X -> Y) P l,
      Forall P (map f l) <-> Forall (fun x => P (f x)) l.
  Proof.
    intros; split; intro;
    induction l; constructor;
      inv_prop Forall;
      eauto.
  Qed.

  Lemma local_all_zero_global_zero :
    forall gst,
      Forall (fun h => |h in gst| = 0) (active_nodes gst) <-> |gst| = 0.
  Proof.
    intros; split; intro.
    - apply sum_of_zeros_is_zero.
      now apply map_Forall_comm.
    - apply Forall_forall.
      intros.
      eapply sum_of_nats_zero_means_all_zero; eauto.
      change (|x in gst|) with ((fun y => |y in gst|) x).
      now apply in_map.
  Qed.

  Lemma measure_mono :
    forall gst gst',
      nodes gst' = nodes gst ->
      failed_nodes gst' = failed_nodes gst ->
      (forall h, In h (active_nodes gst) -> |h in gst| <= |h in gst'|) ->
      |gst| <= |gst'|.
  Proof.
    intros.
    unfold global_measure, active_nodes in *.
    repeat find_rewrite.
    now apply sum_map_mono.
  Qed.

  Lemma local_nonincreasing_causes_global_nonincreasing :
    forall ex,
      lb_execution ex ->
      local_measures_nonincreasing ex ->
      consecutive (measure_nonincreasing global_measure) ex.
  Proof.
    unfold local_measures_nonincreasing, local_measure_nonincreasing, measure_nonincreasing.
    intros.
    destruct ex as [o [o' ex]]; simpl.
    inv_prop lb_execution.
    find_copy_apply_lem_hyp labeled_step_dynamic_preserves_active_nodes.
    eapply measure_mono; repeat find_rewrite;
      eauto using labeled_step_dynamic_preserves_nodes, labeled_step_dynamic_preserves_failed_nodes.
    intros; unfold active_nodes in *.
    repeat find_reverse_rewrite; simpl in *; eauto.
  Qed.

  Lemma max_measure_mono :
    forall gst gst',
      nodes gst' = nodes gst ->
      failed_nodes gst' = failed_nodes gst ->
      (forall h, In h (active_nodes gst) -> |h in gst| <= |h in gst'|) ->
      max_measure gst <= max_measure gst'.
  Proof.
    intros.
    unfold max_measure, active_nodes in *.
    repeat find_rewrite.
    now apply max_map_mono.
  Qed.

  Lemma local_nonincreasing_causes_max_nonincreasing :
    forall ex,
      lb_execution ex ->
      local_measures_nonincreasing ex ->
      consecutive (measure_nonincreasing max_measure) ex.
  Proof.
    unfold local_measures_nonincreasing, local_measure_nonincreasing, measure_nonincreasing.
    intros.
    destruct ex as [o [o' ex]]; simpl.
    inv_prop lb_execution.
    find_copy_apply_lem_hyp labeled_step_dynamic_preserves_active_nodes.
    eapply max_measure_mono; repeat find_rewrite;
      eauto using labeled_step_dynamic_preserves_nodes, labeled_step_dynamic_preserves_failed_nodes.
    intros; unfold active_nodes in *.
    repeat find_reverse_rewrite; simpl in *; eauto.
  Qed.

  Lemma local_always_nonincreasing_causes_max_always_nonincreasing :
    forall ex,
      lb_execution ex ->
      always local_measures_nonincreasing ex ->
      always (consecutive (measure_nonincreasing max_measure)) ex.
  Proof.
    cofix c; intros; constructor; destruct ex.
    - apply local_nonincreasing_causes_max_nonincreasing; eauto.
      apply always_now'; eauto.
    - apply c; eauto using always_invar, lb_execution_invar.
  Qed.

  Lemma local_dropping_makes_global_drop :
    forall h o o',
      active_nodes (occ_gst o) = active_nodes (occ_gst o') ->
      (forall h', In h' (active_nodes (occ_gst o)) ->
             measure_nonincreasing (local_measure h') o o') ->
      In h (active_nodes (occ_gst o)) ->
      measure_decreasing (local_measure h) o o' ->
      measure_decreasing global_measure o o'.
  Proof.
    unfold measure_decreasing, measure_nonincreasing, global_measure.
    intros.
    find_apply_lem_hyp in_split; break_exists.
    repeat find_rewrite.
    rewrite !map_app, !map_cons, !sum_disjoint.
    apply Nat.add_lt_le_mono;
      try apply Nat.add_le_lt_mono;
      assumption || apply sum_map_mono; auto with datatypes.
  Qed.

  Lemma local_dropping_makes_global_drop_ex :
    forall h ex,
      lb_execution ex ->
      always local_measures_nonincreasing ex ->
      In h (active_nodes (occ_gst (hd ex))) ->
      consecutive (measure_decreasing (local_measure h)) ex ->
      consecutive (measure_decreasing global_measure) ex.
  Proof.
    intros.
    destruct ex as [o [o' ex]].
    inv_prop lb_execution.
    inv_prop always.
    eapply local_dropping_makes_global_drop;
      eauto using labeled_step_dynamic_preserves_active_nodes.
  Qed.

  Definition nonzero_error_causes_measure_drop (ex : infseq occurrence) :=
     |occ_gst (hd ex)| > 0 ->
     some_local_measure_drops ex.

  Lemma local_measure_causes_eventual_drop :
    forall ex,
      lb_execution ex ->
      always local_measures_nonincreasing ex ->
      nonzero_error_causes_measure_drop ex ->
      zero_or_eventually_decreasing global_measure ex.
  Proof.
    intros.
    destruct (|occ_gst (hd ex)|) as [| err] eqn:?H;
      [left|right].
    - destruct ex; assumption.
    - pose proof (gt_Sn_O err); repeat find_reverse_rewrite.
      assert (some_local_measure_drops ex) by auto.
      unfold some_local_measure_drops in *; break_exists_name h; break_and.
      lift_eventually (local_dropping_makes_global_drop_ex h);
        firstorder using lb_execution_invar, always_invar.
      inv_prop lb_execution; simpl.
      find_copy_apply_lem_hyp labeled_step_dynamic_preserves_active_nodes.
      now repeat find_reverse_rewrite.
  Qed.

  Lemma local_measure_always_causes_eventual_drop :
    forall ex,
      lb_execution ex ->
      always local_measures_nonincreasing ex ->
      always nonzero_error_causes_measure_drop ex ->
      always (zero_or_eventually_decreasing global_measure) ex.
  Proof.
    intros.
    lift_always local_measure_causes_eventual_drop.
    repeat apply always_and_tl;
      eauto using always_always, always_inv, lb_execution_invar.
  Qed.

  Lemma local_measure_causes_measure_zero :
    forall ex,
      lb_execution ex ->
      always local_measures_nonincreasing ex ->
      always nonzero_error_causes_measure_drop ex ->
      continuously (now (measure_zero global_measure)) ex.
  Proof.
    intros.
    eapply measure_decreasing_to_zero.
    - now apply local_measure_always_causes_eventual_drop.
    - lift_always local_nonincreasing_causes_global_nonincreasing.
      apply always_and_tl; eauto using always_inv, lb_execution_invar.
  Qed.

  (* TODO(ryan) move to infseq *)
  Lemma continuously_forall_list_comm :
    forall (A B : Type) (P : A -> infseq B -> Prop) l ex,
      (forall x, In x l -> (continuously (P x) ex)) ->
      continuously (fun ex' => forall x, In x l -> P x ex') ex.
  Proof.
    induction l as [| a l].
    - intros.
      apply E0.
      eapply always_monotonic; try eapply always_true; intros.
      exfalso; auto.
    - intros.
      pose proof (IHl ex).
      forwards. auto with datatypes. concludes.
      assert (continuously (P a) ex)
        by auto with datatypes.
      cut (continuously ((fun ex' => forall x, In x l -> P x ex') /\_ P a) ex).
      {
        apply continuously_monotonic.
        intros.
        unfold and_tl in *; break_and.
        find_apply_lem_hyp in_inv; break_or_hyp; auto.
      }
      apply continuously_and_tl; eauto.
  Qed.

  Lemma always_forall_list_comm :
    forall (A B : Type) (P : A -> infseq B -> Prop) ex l,
      (forall x, In x l -> (always (P x) ex)) ->
      always (fun ex' => forall x, In x l -> P x ex') ex.
  Proof.
    intros.
    generalize dependent l.
    induction l as [| a l].
    - intros; eapply always_monotonic; try eapply always_true; intros.
      exfalso; auto.
    - intros.
      forward IHl. eauto with datatypes. concludes.
      assert (always (P a) ex)
        by auto with datatypes.
      cut (always ((fun ex' => forall x, In x l -> P x ex') /\_ P a) ex).
      {
        apply always_monotonic.
        intros.
        unfold and_tl in *; break_and.
        find_apply_lem_hyp in_inv; break_or_hyp; auto.
      }
      apply always_and_tl; eauto.
  Qed.

  Lemma measure_eventually_bounded_continuously_bounded :
    forall ex h n,
      always (local_measure_nonincreasing h) ex ->
      eventually (fun ex' => |h in occ_gst (hd ex')| <= n) ex ->
      continuously (fun ex' => |h in occ_gst (hd ex') | <= n) ex.
  Proof.
    intros.
    induction H0.
    - apply E0.
      apply nonincreasing_preserves_bound in H0; eauto.
      unfold measure_bounded in *.
      eapply always_monotonic; eauto.
      intros [o s']; auto.
    - apply E_next.
      unfold continuously in *.
      find_apply_lem_hyp always_Cons; tauto.
  Qed.

  Lemma all_measures_nonincreasing_always_each_nonincreasing :
    forall (ex : infseq occurrence) (h : addr),
      lb_execution ex ->
      In h (active_nodes (occ_gst (hd ex))) ->
      always local_measures_nonincreasing ex ->
      always (consecutive (measure_nonincreasing (local_measure h))) ex.
  Proof.
    cofix c; intros; constructor; destruct ex.
    - find_apply_lem_hyp always_Cons; break_and.
      unfold local_measures_nonincreasing, local_measure_nonincreasing in *.
      auto.
    - simpl. apply c; eauto using lb_execution_invar, always_invar.
      inv_prop lb_execution.
      erewrite <- labeled_step_dynamic_preserves_active_nodes; eauto.
  Qed.

  Lemma local_drops_below_bound :
    forall ex h n,
      lb_execution ex ->
      In h (active_nodes (occ_gst (hd ex))) ->
      always local_measures_nonincreasing ex ->
      |h in (occ_gst (hd ex))| <= S n ->
      eventually (consecutive (measure_decreasing (local_measure h))) ex ->
      continuously (fun ex' => |h in (occ_gst (hd ex'))| <= n) ex.
  Proof.
    intros.
    assert (always (consecutive (measure_nonincreasing (local_measure h))) ex)
      by eauto using all_measures_nonincreasing_always_each_nonincreasing.
    eapply measure_eventually_bounded_continuously_bounded; auto.
    destruct (|h in (occ_gst (hd ex))|) as [|k] eqn:?.
    - fold (measure_zero (local_measure h) (hd ex)) in *.
      destruct ex.
      change (measure_zero (local_measure h) (hd (Cons o ex)))
        with (now (measure_zero (local_measure h)) (Cons o ex)) in *.
      apply E0.
      invcs_prop measure_zero.
      omega.
    - cut (eventually (fun ex' => |h in occ_gst (hd ex')| < S k) ex).
      {
        apply eventually_monotonic_simple.
        intros; omega.
      }
      cut (eventually (measure_bounded (local_measure h) k) ex).
      {
        apply eventually_monotonic_simple.
        unfold measure_bounded.
        intros. destruct s.
        find_apply_lem_hyp always_Cons; break_and.
        cbn in *.
        omega.
      }
      eapply measure_bound_drops; firstorder.
      eapply less_than_Sn_bounded_n; auto.
      destruct ex; simpl in *; omega.
  Qed.

  Lemma always_bound_on_local_measures_bounds_max :
    forall n ex,
      lb_execution ex ->
      always
         (fun ex' =>
            forall h,
              In h (active_nodes (occ_gst (hd ex))) ->
              |h in occ_gst (hd ex')| <= n)
         ex ->
      always (fun ex' => max_measure (occ_gst (hd ex')) <= n) ex.
  Proof.
    intros.
    remember (active_nodes (occ_gst (hd ex))) as l.
    find_copy_apply_lem_hyp (active_nodes_always_identical l ex); eauto.
    generalize dependent ex.
    cofix c. intros.
    constructor; destruct ex.
    - unfold max_measure.
      repeat find_apply_lem_hyp always_Cons; break_and.
      eapply max_map_bound.
      now repeat find_reverse_rewrite.
    - repeat find_apply_lem_hyp always_Cons; break_and.
      apply c; cbn; eauto using lb_execution_invar.
      now find_eapply_lem_hyp always_now'.
  Qed.

  Lemma continuously_bound_on_local_measures_bounds_max :
    forall n ex,
      lb_execution ex ->
      continuously
         (fun ex' =>
            forall h,
              In h (active_nodes (occ_gst (hd ex))) ->
              |h in occ_gst (hd ex')| <= n)
         ex ->
      continuously (fun ex' => max_measure (occ_gst (hd ex')) <= n) ex.
  Proof.
    intros.
    remember (active_nodes (occ_gst (hd ex))) as l.
    find_copy_apply_lem_hyp (active_nodes_always_identical (active_nodes (occ_gst (hd ex))) ex); eauto.
    match goal with
    | H: continuously _ _ |- _ => induction H
    end.
    - apply E0.
      apply always_bound_on_local_measures_bounds_max; eauto.
      now replace (active_nodes (occ_gst (hd s))) with l.
    - apply E_next.
      apply IHeventually; eauto using lb_execution_invar, always_invar, active_nodes_always_identical.
      destruct s.
      repeat (find_apply_lem_hyp always_Cons; break_and).
      cbn in *.
      congruence.
  Qed.

  Lemma continuously_bound_on_local_measures_max_measure_bounded :
    forall n ex,
      lb_execution ex ->
      continuously
         (fun ex' =>
            forall h,
              In h (active_nodes (occ_gst (hd ex))) ->
              |h in occ_gst (hd ex')| <= n)
         ex ->
      eventually (measure_bounded max_measure n) ex.
  Proof.
    intros.
    cut (continuously (fun ex' => max_measure (occ_gst (hd ex')) <= n) ex).
    {
      unfold measure_bounded.
      eapply continuously_monotonic.
      intros.
      destruct s; auto.
    }
    find_apply_lem_hyp continuously_bound_on_local_measures_bounds_max; auto.
  Qed.

  Lemma max_measure_continuously_decreasing_bound :
    forall ex n,
      lb_execution ex ->
      always local_measures_nonincreasing ex ->
      always max_measure_nonzero_eventually_all_locals_below ex ->
      max_measure (occ_gst (hd ex)) = S n ->
      eventually (measure_bounded max_measure n) ex.
  Proof.
    intros.
    apply continuously_bound_on_local_measures_max_measure_bounded; auto.
    apply continuously_forall_list_comm; intros.
    apply measure_eventually_bounded_continuously_bounded;
      eauto using all_measures_nonincreasing_always_each_nonincreasing.
    find_apply_lem_hyp always_now'.
    apply_prop_hyp max_measure_nonzero_eventually_all_locals_below max_measure.
    eauto.
    apply_prop_hyp eventually In.
    eapply eventually_monotonic_simple; eauto.
    intros [o s]; auto.
  Qed.

  Theorem local_measure_causes_max_measure_zero :
    forall ex,
      lb_execution ex ->
      always local_measures_nonincreasing ex ->
      always max_measure_nonzero_eventually_all_locals_below ex ->
      continuously (now (measure_zero max_measure)) ex.
  Proof.
    intros.
    destruct ex.
    remember (max_measure (occ_gst o)) as n eqn:Hmax; symmetry in Hmax.
    generalize dependent o.
    generalize dependent ex.
    induction n using nat_strong_ind; destruct n; intros.
    - apply E0.
      apply measure_zero_stays_zero; eauto using local_always_nonincreasing_causes_max_always_nonincreasing.
    - find_copy_eapply_lem_hyp max_measure_continuously_decreasing_bound; eauto.
      induction 0.
      + destruct s as [o' s].
        remember (max_measure (occ_gst o')) as k eqn:Hk; symmetry in Hk.
        eapply H; try eapply Hk; auto with arith.
        unfold measure_bounded in *.
        find_apply_lem_hyp always_Cons; break_and.
        simpl in *.
        omega.
      + apply E_next, IHeventually;
          eauto using lb_execution_invar, always_invar.
  Qed.

  Lemma and_tl_always_P :
    forall T (P Q : infseq T -> Prop) ex,
      always (P /\_ Q) ex ->
      always P ex.
  Proof.
    intros T P Q.
    cofix c; intros.
    constructor; destruct ex.
    - invc_prop and_tl.
      firstorder.
    - simpl.
      apply c.
      eauto using always_invar.
  Qed.

  Lemma always_and_tl_eq :
    forall T (P Q : infseq T -> Prop) ex,
      always (P /\_ Q) ex <-> (always P /\_ always Q) ex.
  Proof.
    split; intros.
    - split; eapply and_tl_always_P; eauto using always_and_tl_comm.
    - inv_prop and_tl; eapply always_and_tl; eauto.
  Qed.

  Lemma always_continuously_and_tl :
    forall T (P Q : infseq T -> Prop) s,
      continuously (P /\_ Q) s ->
      eventually (always P /\_ always Q) s.
  Proof.
    intros.
    unfold continuously in *.
    eapply eventually_monotonic_simple; [|eauto].
    intros.
    now apply always_and_tl_eq.
  Qed.

  Lemma local_measure_causes_measure_zero_continuosly :
    forall ex,
      lb_execution ex ->
      continuously local_measures_nonincreasing ex ->
      continuously nonzero_error_causes_measure_drop ex ->
      continuously (now (measure_zero global_measure)) ex.
  Proof.
    intros.
    pose proof local_measure_causes_measure_zero.
    prep_always_monotonic.
    apply eventually_idempotent.
    eapply eventually_monotonic_simple; eauto.
    match goal with
    | |- eventually (always ?P /\_ always ?Q /\_ ?R) ex =>
      cut (continuously (P /\_ Q /\_ R) ex)
    end.
    - intros.
      find_apply_lem_hyp always_continuously_and_tl.
      eapply eventually_monotonic_simple; [|eauto].
      firstorder.
      + eapply always_and_tl_eq.
        apply always_and_tl_comm.
        eauto.
      + find_apply_lem_hyp always_and_tl_eq; inv_prop and_tl.
        inv_prop lb_execution; auto.
    - repeat apply continuously_and_tl; auto.
      apply always_continuously.
      apply always_inv;
        eauto using lb_execution_invar.
  Qed.

End LocalMeasure.


Set Implicit Arguments.

Require Import ZArith.

Section TREE.

 Variables (A:Type) (default : A) (eq_def : A -> bool).
 Hypothesis eq_def_spec : forall a, if eq_def a then a = default else a <> default.

 Inductive tree : Type :=
  | Node : A -> tree -> tree -> tree
  | Empty : tree.

 Definition mkNode a l r :=
   if eq_def a then
     match l, r with
     | Empty, Empty => Empty
     | _, _ => Node a l r
     end
   else Node a l r.

 Fixpoint get (t:tree) (k:positive) {struct t} : A :=
  match t with
  | Empty => default
  | Node a tl tr =>
    match k with
    | xH => a
    | xO k => get tl k
    | xI k => get tr k
    end
  end.

    Fixpoint upd (t:tree) (k:positive) (f:A -> A) {struct k} : tree :=
    match k, t with
    | xH, Empty => mkNode (f default) Empty Empty
    | xH, Node a tl tr => mkNode (f a) tl tr
    | xO k, Empty => mkNode default (upd Empty k f) Empty
    | xO k, Node a tl tr => mkNode a (upd tl k f) tr
    | xI k, Empty => mkNode default Empty (upd Empty k f)
    | xI k, Node a tl tr => mkNode a tl (upd tr k f)
    end.

  Lemma get_mkNode : forall k a l r, get (mkNode a l r) k = get (Node a l r) k.
  Proof.
    unfold mkNode; intros.
    generalize (eq_def_spec a); destruct (eq_def a); intros; subst; trivial.
    destruct l; trivial.
    destruct r; trivial.
    destruct k; trivial.
  Qed.

  Lemma get_upd_Empty_diff : forall k1 k2 f, k1 <> k2 -> get (upd Empty k1 f) k2 = default.
  Proof.
   induction k1; destruct k2; intros; simpl; repeat rewrite get_mkNode; simpl; trivial;
   try (apply IHk1; intro; subst; auto; fail).
   elim H; trivial.
  Qed.

  Lemma get_upd_Empty_same : forall k f, get (upd Empty k f) k = f default.
  Proof.
    induction k; intros; simpl; repeat rewrite get_mkNode; simpl; trivial.
  Qed.

  Hint Resolve get_upd_Empty_diff get_upd_Empty_same.

  Lemma get_upd_same : forall t k f, get (upd t k f) k = f (get t k).
  Proof.
   intros t k; generalize k t; clear k t.
   induction k; destruct t; simpl; intros; repeat rewrite get_mkNode; simpl; auto.
  Qed.

  Lemma get_upd_diff : forall t k1 k2 f, k1 <> k2 -> get (upd t k1 f) k2 = get t k2.
  Proof.
    intros t k1; generalize k1 t; clear k1 t.
    induction k1; destruct t; destruct k2; simpl; intros f H; repeat rewrite get_mkNode; simpl; auto;
    (apply IHk1; intro; subst; auto; fail) ||
    (apply get_upd_Empty_diff; intro; subst; auto; fail) ||
    (try (elim H; trivial; fail)).
  Qed.

  Variable (Aeqb : A -> A -> bool).

  Fixpoint is_Empty t : bool :=
   match t with
   | Empty => true
   | Node a tl tr =>
     if Aeqb a default then if is_Empty tl then is_Empty tr else false
     else false
   end.

  Hypothesis Aeqb_def : Aeqb default default = true.
  Hypothesis Aeqb_def_comm : forall a, Aeqb a default = Aeqb default a.

  Lemma is_Empty_spec : forall t, is_Empty t = true <-> forall x, Aeqb (get t x) default = true.
  Proof.
    induction t; simpl; trivial.
    case_eq (Aeqb a default); intros.
    destruct (is_Empty t1).
    rewrite IHt2; split; intros.
    destruct IHt1; destruct x; auto.
    apply (H0 (xI x)).
    split; intros; try discriminate.
    rewrite IHt1; intros x; apply (H0 (xO x)).
    split; intros; try discriminate.
    rewrite <- (H0 xH); symmetry; apply H.
    split; auto.
   Qed.

  Fixpoint eqb (x y : tree) {struct x} : bool :=
    match x, y with
    | Empty, _ => is_Empty y
    | _, Empty => is_Empty x
    | Node a1 xl xr, Node a2 yl yr =>
      if Aeqb a1 a2 then
       if eqb xl yl then eqb xr yr else false
      else false
    end.

  Lemma eqb_get : forall x y,
     eqb x y = true <-> forall k, Aeqb (get x k) (get y k)  = true.
  Proof.
   induction x; intros y.
   destruct y; simpl.
   case_eq (Aeqb a a0); intro; try (intros; discriminate).
   case_eq (eqb x1 y1); intro; try (intros; discriminate).
   split; intros.
   destruct k; auto.
   rewrite IHx2 in H1; auto.
   rewrite IHx1 in H0; auto.
   rewrite IHx2; intros k; apply (H1 (xI k)).
   split; intros; try discriminate.
   assert (eqb x1 y1 = true).
      rewrite IHx1; intros k; apply (H1 (xO k)).
   rewrite <- H0; trivial.
   split; intros; try discriminate.
   rewrite <- H; apply (H0 xH).
   change ( is_Empty (Node a x1 x2) = true <-> forall k, Aeqb (get (Node a x1 x2) k) default = true).
   apply is_Empty_spec.
   change (is_Empty y = true <-> forall k, Aeqb default (get y k) = true).
   rewrite is_Empty_spec.
   split; intros H k; rewrite <- (H k); auto.
  Qed.

  Variable Aeq : A -> A -> Prop.

  Hypothesis Aeq_refl : forall x, Aeq x x.
  Hypothesis Aeq_trans : forall x y z, Aeq x y -> Aeq y z -> Aeq x z.
  Hypothesis Aeq_sym : forall x y, Aeq x y -> Aeq y x.
  Hypothesis Aeqb_spec : forall x y, if Aeqb x y then Aeq x y else ~Aeq x y.

  Definition eq (x y:tree) := forall k, Aeq (get x k) (get y k).

  Lemma eq_refl : forall x, eq x x.
  Proof. unfold eq; intros; apply Aeq_refl. Qed.

  Lemma eq_sym : forall x y, eq x y -> eq y x.
  Proof. unfold eq; intros; apply Aeq_sym; trivial. Qed.

  Lemma eq_trans : forall x y z, eq x y -> eq y z -> eq x z.
  Proof. unfold eq; intros; eapply Aeq_trans; eauto. Qed.

  Lemma eqb_spec : forall x y, if eqb x y then eq x y else ~eq x y.
  Proof.
   intros x y; generalize (eqb_get x y).
   destruct (eqb x y).
   unfold eq; intros.
   assert (W:=Aeqb_spec (get x k) (get y k)).
   destruct H as (H,_); rewrite H in W; trivial.
   intros; intro; assert (false = true).
     rewrite H; intros k; assert (W:= H0 k).
     assert (W1:=Aeqb_spec (get x k) (get y k)).
     destruct (Aeqb (get x k) (get y k)); trivial.
     elim (W1 W).
   discriminate.
  Qed.

  Fixpoint app_pos (x y:positive) {struct x} : positive :=
    match x with
    | xH => y
    | xO x => app_pos x (xO y)
    | xI x => app_pos x (xI y)
    end.

  Variable f : positive -> A -> bool.

  Fixpoint forallb_i_rec (p:positive) (t:tree) {struct t} : bool :=
    match t with
    | Empty => true
    | Node a l r =>
      if f (app_pos p xH) a then
       if forallb_i_rec (xO p) l then forallb_i_rec (xI p) r else false
      else false
    end.

  Hypothesis f_def : forall k, f k default = true.

  Lemma forallb_i_rec_spec :
     forall t p, forallb_i_rec p t = true <-> forall k, f (app_pos p k) (get t k) = true.
  Proof.
   induction t; simpl; intros.
   case_eq ( f (app_pos p 1) a); intros.
    case_eq (forallb_i_rec (xO p) t1); intros.
    rewrite IHt2.
    split; intros.
    destruct k; auto.
    apply (H1 k).
    destruct (IHt1 (xO p)) as (H3,_); exact (H3 H0 k).
    exact (H1 (xI k)).
    split; intros; try discriminate.
    rewrite <- H0; rewrite (IHt1 (xO p)).
    intros k; exact (H1 (xO k)).
    split; intros; try discriminate.
    rewrite <- H; exact (H0 xH).
    split; trivial.
   Qed.

   Definition forallb_i := forallb_i_rec xH.

   Lemma forallb_i_spec :
     forall t, forallb_i t = true <-> forall k, f k (get t k) = true.
   Proof.
    unfold forallb_i; intros; rewrite forallb_i_rec_spec; simpl; tauto.
   Qed.

End TREE.

Section Map.

    Variables (A B:Type) (defA:A) (defB:B) (Beq_def : B -> bool) (f : A -> B) .

    Fixpoint map (t:tree A) : tree B:=
      match t with
      | Empty => Empty _
      | Node o tl tr => mkNode Beq_def (f o) (map tl) (map tr)
      end.
    Hypothesis Beq_def_spec : forall a, if Beq_def a then a = defB else a <> defB.
    Hypothesis f_def : f defA = defB.
    Lemma map_spec : forall t k, get defB (map t) k = f (get defA t k).
    Proof.
     induction t; simpl; intros; trivial; destruct k; repeat rewrite get_mkNode; simpl; auto.
    Qed.

End Map.

Section Filter.

    Variables (A:Type) (defA:A) (eq_def : A -> bool)(f : A -> bool).
    Definition filter_a a := if f a then a else defA.

    Definition filter := map eq_def filter_a.
    Hypothesis Aeq_def_spec : forall a, if eq_def a then a = defA else a <> defA.
    Hypothesis f_def : f defA = true.

    Lemma filter_spec : forall t k, f (get defA (filter t) k) = true.
    Proof.
      unfold filter; intros.
      rewrite (@map_spec A A defA defA eq_def filter_a Aeq_def_spec); unfold filter_a.
      case_eq (f (get defA t k)); trivial.
      rewrite f_def; trivial.
    Qed.

End Filter.

Section Map2.

  Variables (A B C : Type) (dA:A) (dB:B) (dC:C) (Ceq_def:C -> bool) (f : A -> B -> C).

  Fixpoint map2 (ta:tree A) (tb:tree B) {struct ta} : tree C :=
    match ta with
    | Empty => map Ceq_def (f dA) tb
    | Node a tal tar =>
      match tb with
      | Empty =>map Ceq_def (fun a => f a dB) ta
      | Node b tbl tbr => mkNode Ceq_def (f a b) (map2 tal tbl) (map2 tar tbr)
      end
     end.

  Hypothesis Aeq_def_spec : forall a, if Ceq_def a then a = dC else a <> dC.

  Hypothesis f_def : dC = f dA dB.

  Lemma map2_spec : forall ta tb k, get dC (map2 ta tb) k = f (get dA ta k) (get dB tb k).
  Proof.
    induction ta; destruct tb; intros; unfold map2; fold map2; repeat rewrite get_mkNode; simpl; auto;
    destruct k; simpl; auto; rewrite get_mkNode; auto; simpl.
    rewrite (@map_spec A C dA dC Ceq_def); auto.
    rewrite (@map_spec A C dA dC Ceq_def); auto.
    rewrite (@map_spec B C dB dC Ceq_def); auto.
    rewrite (@map_spec B C dB dC Ceq_def); auto.
  Qed.

End Map2.

(*
Section OPTION.
  Variable A:Type.
  Variable (Aeqb : A -> A -> bool).
  Variable Aeq : A -> A -> Prop.

  Hypothesis Aeq_refl : forall x, Aeq x x.
  Hypothesis Aeq_trans : forall x y z, Aeq x y -> Aeq y z -> Aeq x z.
  Hypothesis Aeq_sym : forall x y, Aeq x y -> Aeq y x.
  Hypothesis Aeqb_spec : forall x y, if Aeqb x y then Aeq x y else ~Aeq x y.

  Definition oeq (x y:option A) :=
    match x, y with
    | Some a1, Some a2 => Aeq a1 a2
    | None, None => True
    | _, _ => False
    end.

  Lemma oeq_refl : forall x, oeq x x.
  Proof. destruct x; simpl; auto. Qed.

  Lemma oeq_sym : forall x y, oeq x y -> oeq y x.
  Proof. destruct x; destruct y; simpl; auto. Qed.

  Lemma oeq_trans : forall x y z, oeq x y -> oeq y z -> oeq x z.
  Proof.
   destruct x; destruct y; destruct z; simpl; eauto.
   intros H; elim H.
  Qed.

  Definition oeqb (x y:option A) :=
    match x, y with
    | Some a1, Some a2 => Aeqb a1 a2
    | None, None => true
    | _, _ => false
    end.

  Lemma oeqb_spec : forall x y, if oeqb x y then oeq x y else ~oeq x y.
  Proof.
   destruct x; destruct y; auto; simpl; auto.
   apply Aeqb_spec.
  Qed.

  Variable (M:Type->Type) (K:Type) (get : M A -> K -> option A).

  Definition eq (x y:M A) := forall k, oeq (get x k) (get y k).

  Lemma eq_refl : forall x, eq x x.
  Proof. unfold eq; intros; apply oeq_refl. Qed.

  Lemma eq_sym : forall x y, eq x y -> eq y x.
  Proof. unfold eq; intros; apply oeq_sym; trivial. Qed.

  Lemma eq_trans : forall x y z, eq x y -> eq y z -> eq x z.
  Proof. unfold eq; intros; eapply oeq_trans; eauto. Qed.

  Variables (B:Type) (f : A -> option B).

  Definition f_opt o :=
     match o with
     | Some a => f a
     | None => None
     end.

End OPTION.

Module Type MAP.

  Parameter key : Type.
  Parameter t : Type -> Type.

  Parameter get : forall A, t A -> key -> option A.
  Parameter upd : forall A, t A -> key -> option A -> t A.
  Parameter get_upd_same : forall A (m:t A) k a, get (upd m k a) k = a.
  Parameter get_upd_diff : forall A (m:t A) k1 k2 a, k1 <> k2 -> get (upd m k1 a) k2 = get m k2.

  Parameter empty : forall A, t A.
  Parameter empty_spec : forall A k, get (empty A) k = None.

  Parameter eqb : forall A, (A->A->bool) -> t A -> t A -> bool.

  Parameter eqb_get : forall A (Aeqb:A->A->bool) (x y:t A),
     eqb Aeqb x y = true <-> forall k, oeqb Aeqb (get x k) (get y k)  = true.

  Definition eq A (Aeq:A->A->Prop) (x y:t A) := forall k, oeq Aeq (get x k) (get y k).

  Parameter eqb_spec : forall A (Aeqb : A -> A -> bool) (Aeq : A -> A -> Prop),
    (forall x y, if Aeqb x y then Aeq x y else ~Aeq x y) ->
    forall (x y:t A), if eqb Aeqb x y then eq Aeq x y else ~eq Aeq x y.

  Parameter forallb_i : forall A, (key -> A -> bool) -> t A -> bool.

  Parameter forallb_i_spec :
     forall A f (m:t A), forallb_i f m = true <-> forall k a, get m k = Some a -> f k a = true.

  Parameter map : forall A B, (A -> option B) -> t A -> t B.

  Parameter map_spec : forall A B (f:A->option B) (m:t A) k, get (map f m) k = f_opt f (get m k).

  Parameter map2 : forall A B C, (option A -> option B -> option C) -> t A -> t B -> t C.

  Parameter map2_spec : forall A B C (f:option A -> option B -> option C),
        None = f None None ->
        forall ma mb k, get (map2 f ma mb) k = f (get ma k) (get mb k).

End MAP.

Module Pmap <: MAP with Definition key := positive.

  Definition key : Type := positive.

  Section TREE.

   Variable A:Type.

   Inductive tree : Type :=
    | Node : option A -> tree -> tree -> tree
    | Empty : tree.

   Fixpoint get (t:tree) (k:positive) {struct t} : option A :=
    match t with
    | Empty => None
    | Node a tl tr =>
       match k with
      | xH => a
      | xO k => get tl k
      | xI k => get tr k
      end
    end.

  Fixpoint upd (t:tree) (k:positive) (a:option A) {struct k} : tree :=
    match k, t with
    | xH, Empty => Node a Empty Empty
    | xH, Node _ tl tr => Node a tl tr
    | xO k, Empty => Node None (upd Empty k a) Empty
    | xO k, Node o tl tr => Node o (upd tl k a) tr
    | xI k, Empty => Node None Empty (upd Empty k a)
    | xI k, Node o tl tr => Node o tl (upd tr k a)
    end.

  Lemma get_upd_same : forall t k a, get (upd t k a) k = a.
  Proof.
   intros t k; generalize k t; clear k t.
   induction k; destruct t; simpl; auto.
  Qed.

  Lemma get_upd_Empty : forall k1 k2 a, k1 <> k2 -> get (upd Empty k1 a) k2 = None.
  Proof.
   induction k1; destruct k2; intros; simpl; trivial;
   try (apply IHk1; intro; subst; auto; fail).
   elim H; trivial.
  Qed.

  Lemma get_upd_diff : forall t k1 k2 a, k1 <> k2 -> get (upd t k1 a) k2 = get t k2.
  Proof.
    intros t k1; generalize k1 t; clear k1 t.
    induction k1; destruct t; destruct k2; simpl; intros a H; auto;
    (apply IHk1; intro; subst; auto; fail) ||
    (apply get_upd_Empty; intro; subst; auto; fail) ||
    (elim H; trivial).
  Qed.

  Definition mkNode o t1 t2 :=
    match o, t1, t2 with
    | None, Empty, Empty => Empty
    | _, _, _ => Node o t1 t2
    end.

  Lemma mkNode_spec : forall o t1 t2 k, get (mkNode o t1 t2) k = get (Node o t1 t2) k.
  Proof.
   intros; destruct o; trivial; destruct t1; trivial; destruct t2; trivial.
   destruct k; trivial.
  Qed.

  Definition empty := Empty.

  Lemma empty_spec : forall k, get empty k = None.
  Proof. trivial. Qed.

  Variable (Aeqb : A -> A -> bool).

  Fixpoint is_Empty t : bool :=
   match t with
   | Empty => true
   | Node (Some _) _ _ => false
   | Node _ tl tr => if is_Empty tl then is_Empty tr else false
   end.

  Lemma is_Empty_spec : forall t, is_Empty t = true <-> forall x, get t x = None.
  Proof.
    induction t; simpl; trivial.
    destruct o; intros.
    split.
    intros; discriminate.
    intros H; assert (H1:= H xH); discriminate.
    destruct (is_Empty t1).
    rewrite IHt2; split; intros.
    destruct IHt1; destruct x; auto.
    apply (H  (xI x)).
    split; intros; try discriminate.
    rewrite IHt1; intros x; exact (H (xO x)).
    split; trivial.
  Qed.

  Fixpoint eqb (x y : tree) {struct x} : bool :=
    match x, y with
    | Empty, _ => is_Empty y
    | _, Empty => is_Empty x
    | Node a1 xl xr, Node a2 yl yr =>
      if oeqb Aeqb a1 a2 then
       if eqb xl yl then eqb xr yr else false
      else false
    end.

  Lemma eqb_get : forall x y,
     eqb x y = true <-> forall k, oeqb Aeqb (get x k) (get y k)  = true.
  Proof.
   induction x; intros y.
   destruct y; simpl.
   case_eq (oeqb Aeqb o o0); intro; try (intros; discriminate).
   case_eq (eqb x1 y1); intro; try (intros; discriminate).
   split; intros.
   destruct k; auto.
   rewrite IHx2 in H1; auto.
   rewrite IHx1 in H0; auto.
   rewrite IHx2; intros k; apply (H1 (xI k)).
   split; intros; try discriminate.
   assert (eqb x1 y1 = true).
      rewrite IHx1; intros k; apply (H1 (xO k)).
   rewrite <- H0; trivial.
   split; intros; try discriminate.
   rewrite <- H; apply (H0 xH).
   change (is_Empty (Node o x1 x2) = true <-> forall k, oeqb Aeqb (get (Node o x1 x2) k) None = true).
   rewrite is_Empty_spec; split; intros.
   rewrite H; trivial.
   assert (H1 := H x); destruct (get (Node o x1 x2) x); trivial; discriminate.
   change (eqb Empty y) with (is_Empty y).
   rewrite is_Empty_spec; split; intros.
   rewrite H; trivial.
   assert (H1 := H x); destruct (get y x); trivial; discriminate.
  Qed.

  Variable Aeq : A -> A -> Prop.

  Hypothesis Aeqb_spec : forall x y, if Aeqb x y then Aeq x y else ~Aeq x y.

  Definition eq (x y:tree) := forall k, oeq Aeq (get x k) (get y k).

  Lemma eqb_spec : forall x y, if eqb x y then eq x y else ~eq x y.
  Proof.
   intros x y; generalize (eqb_get x y).
   destruct (eqb x y).
   unfold eq; intros.
   assert (W:=oeqb_spec Aeqb Aeq Aeqb_spec (get x k) (get y k)).
   destruct H as (H,_); rewrite H in W; trivial.
   intros; intro; assert (false = true).
     rewrite H; intros k; assert (W:= H0 k).
     assert (W1:=oeqb_spec Aeqb Aeq Aeqb_spec (get x k) (get y k)).
     destruct (oeqb Aeqb (get x k) (get y k)); trivial.
     elim (W1 W).
   discriminate.
  Qed.

  Fixpoint app_pos (x y:positive) {struct x} : positive :=
    match x with
    | xH => y
    | xO x => app_pos x (xO y)
    | xI x => app_pos x (xI y)
    end.

  Variable f : positive -> A -> bool.

  Fixpoint forallb_i_rec (p:positive) (t:tree) {struct t} : bool :=
    match t with
    | Empty => true
    | Node o l r =>
      let test :=
        match o with
        | Some a => f (app_pos p xH) a
        | None => true
        end in
      if test then
       if forallb_i_rec (xO p) l then forallb_i_rec (xI p) r else false
      else false
    end.

  Lemma forallb_i_rec_spec :
     forall t p, forallb_i_rec p t = true <-> forall k e, get t k = Some e -> f (app_pos p k) e = true.
  Proof.
   induction t; simpl; intros.
   case_eq (match o with
    | Some a => f (app_pos p 1) a
    | None => true
    end); intros.
    case_eq (forallb_i_rec (xO p) t1); intros.
    rewrite IHt2.
    split; intros.
    destruct k.
    simpl in H1; auto.
    destruct (IHt1 (xO p)) as (H3,_); exact (H3 H0 _ _ H2).
    rewrite H2 in H; trivial.
    exact (H1 (xI k) _ H2).
    split; intros; try discriminate.
    rewrite <- H0; rewrite (IHt1 (xO p)).
    intros k e Heq; exact (H1 (xO k) _ Heq).
    split; intros; try discriminate.
    destruct o; try discriminate.
    rewrite <- H; exact (H0 xH a (refl_equal _)).
    split; trivial; intros; discriminate.
   Qed.

   Definition forallb_i := forallb_i_rec xH.

   Lemma forallb_i_spec :
     forall t, forallb_i t = true <-> forall k e, get t k = Some e -> f k e = true.
   Proof.
    unfold forallb_i; intros; rewrite forallb_i_rec_spec; simpl; tauto.
   Qed.

  End TREE.

  Section Map.

    Variables (A B:Type) (f : A -> option B).

    Fixpoint map (t:tree A) : tree B:=
      match t with
      | Empty => Empty _
      | Node o tl tr => mkNode (f_opt f o) (map tl) (map tr)
      end.

    Lemma map_spec : forall t k, get (map t) k = f_opt f (get t k).
    Proof.
     induction t; simpl; intros; trivial; destruct k; rewrite mkNode_spec; simpl; auto.
    Qed.

  End Map.

  Section Map2.

   Variables (A B C : Type) (f : option A -> option B -> option C).

  Fixpoint map2 (ta:tree A) (tb:tree B) {struct ta} : tree C :=
    match ta with
    | Empty => map (fun b => f None (Some b)) tb
    | Node oa tal tar =>
      match tb with
      | Empty =>
         mkNode (f oa None)
                       (map (fun a => f (Some a) None) tal)
                       (map (fun a => f (Some a) None) tar)
      | Node ob tbl tbr =>
        mkNode (f oa ob) (map2 tal tbl) (map2 tar tbr)
      end
     end.

  Hypothesis f_None : None = f None None.

  Lemma map2_spec : forall ta tb k, get (map2 ta tb) k = f (get ta k) (get tb k).
  Proof.
    induction ta; destruct tb; intros; unfold map2; fold map2; try rewrite mkNode_spec; simpl; auto;
    destruct k; simpl; auto.
    rewrite map_spec; destruct (get ta2 k); simpl; auto.
    rewrite map_spec; destruct (get ta1 k); simpl; auto.
    rewrite mkNode_spec; simpl;
    rewrite map_spec; destruct (get tb2 k); simpl; auto.
    rewrite mkNode_spec; simpl; rewrite map_spec; destruct (get tb1 k); simpl; auto.
    rewrite mkNode_spec; simpl; destruct o; simpl; auto.
  Qed.

  End Map2.

 Definition t := tree.

End Pmap.

*)


Require Import init.

Require Import linear_free.
Require Import linear_grade.
Require Import module_category.
Require Import algebra_category.
Require Import nat.
Require Import set.
Require Import unordered_list.
Require Import linear_grade_sum.

Section Polynomial.

Context (F : CRingObj).
Let U := cring_U F.
Let UP := cring_plus F.
Let UZ := cring_zero F.
Let UN := cring_neg F.
Let UPA := cring_plus_assoc F.
Let UPC := cring_plus_comm F.
Let UPZ := cring_plus_lid F.
Let UPN := cring_plus_linv F.
Let UM := cring_mult F.
Let UO := cring_one F.
Let UMA := cring_mult_assoc F.
Let UMC := cring_mult_comm F.
Let UMO := cring_mult_lid F.
Let UMD := cring_ldist F.
Existing Instances UP UZ UN UPA UPC UPZ UPN UM UO UMA UMC UMO UMD.
Context `{
    UML : @MultLcancel U UZ UM,
    UMR : @MultRcancel U UZ UM,
    UD : Div U,
    UMDL : @MultLinv U UZ UM UO UD,
    UMDR : @MultRinv U UZ UM UO UD,
    @NotTrivial U
}.

Definition polynomial_module := free_linear F nat.
Definition polynomial := module_V polynomial_module : Type.
Definition polynomial_plus := module_plus polynomial_module : Plus polynomial.
Definition polynomial_zero := module_zero polynomial_module : Zero polynomial.
Definition polynomial_neg := module_neg polynomial_module : Neg polynomial.
Definition polynomial_plus_comm := module_plus_comm polynomial_module : PlusComm polynomial.
Definition polynomial_plus_assoc := module_plus_assoc polynomial_module : PlusAssoc polynomial.
Definition polynomial_plus_lid := module_plus_lid polynomial_module : PlusLid polynomial.
Definition polynomial_plus_linv := module_plus_linv polynomial_module : PlusLinv polynomial.
Definition polynomial_scalar := module_scalar polynomial_module : ScalarMult U polynomial.
Definition polynomial_scalar_id := module_scalar_id polynomial_module : ScalarId U polynomial.
Definition polynomial_scalar_ldist := module_scalar_ldist polynomial_module : ScalarLdist U polynomial.
Definition polynomial_scalar_rdist := module_scalar_rdist polynomial_module : ScalarRdist U polynomial.
Definition polynomial_scalar_comp := module_scalar_comp polynomial_module : ScalarComp U polynomial.
Definition polynomial_grade := free_grade F nat : GradedSpace U polynomial.
Local Existing Instances polynomial_plus polynomial_zero polynomial_neg
    polynomial_plus_comm polynomial_plus_assoc polynomial_plus_lid
    polynomial_plus_linv polynomial_scalar polynomial_scalar_id
    polynomial_scalar_ldist polynomial_scalar_rdist polynomial_scalar_comp
    polynomial_grade.

Definition polynomial_xn (n : nat) := to_free F nat n.

Theorem polynomial_xn_ex : ∀ (n : nat) (f : polynomial),
    of_grade n f → ∃ α, f = α · polynomial_xn n.
Proof.
    intros n f fn.
    apply to_free_ex in fn as [α eq]; subst f.
    exists α.
    unfold polynomial_xn.
    reflexivity.
Qed.

Local Instance polynomial_mult : Mult polynomial := {
    mult := free_bilinear F nat (λ m n, polynomial_xn (m + n));
}.

Theorem polynomial_xn_mult : ∀ m n,
    polynomial_xn m * polynomial_xn n = polynomial_xn (m + n).
Proof.
    intros m n.
    unfold mult; cbn.
    rewrite (free_bilinear_free F nat).
    reflexivity.
Qed.

Local Program Instance polynomial_ldist : Ldist polynomial.
Next Obligation.
    apply (free_bilinear_ldist F nat).
Qed.
Local Program Instance polynomial_mult_assoc : MultAssoc polynomial.
Next Obligation.
    unfold mult; cbn.

    rewrite (grade_decomposition_eq a).
    remember (grade_decomposition a) as l; clear Heql.
    induction l as [|v l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 3 rewrite (free_bilinear_lanni F nat).
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    do 3 rewrite (free_bilinear_rdist F nat).
    rewrite IHl; clear IHl.
    apply rplus; clear l.
    destruct v as [v [i vi]]; cbn.
    apply polynomial_xn_ex in vi as [α v_eq]; subst v.
    do 3 rewrite (free_bilinear_lscalar F nat).
    apply f_equal; clear α.

    rewrite (grade_decomposition_eq b).
    remember (grade_decomposition b) as l; clear Heql.
    induction l as [|v l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite (free_bilinear_lanni F nat).
        do 2 rewrite (free_bilinear_ranni F nat).
        rewrite (free_bilinear_lanni F nat).
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    rewrite (free_bilinear_rdist F nat).
    do 2 rewrite (free_bilinear_ldist F nat).
    rewrite (free_bilinear_rdist F nat).
    rewrite IHl; clear IHl.
    apply rplus; clear l.
    destruct v as [v [j vj]]; cbn.
    apply polynomial_xn_ex in vj as [α v_eq]; subst v.
    rewrite (free_bilinear_lscalar F nat).
    do 2 rewrite (free_bilinear_rscalar F nat).
    rewrite (free_bilinear_lscalar F nat).
    apply f_equal; clear α.

    rewrite (grade_decomposition_eq c).
    remember (grade_decomposition c) as l; clear Heql.
    induction l as [|v l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 3 rewrite (free_bilinear_ranni F nat).
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    do 3 rewrite (free_bilinear_ldist F nat).
    rewrite IHl; clear IHl.
    apply rplus; clear l.
    destruct v as [v [k vk]]; cbn.
    apply polynomial_xn_ex in vk as [α v_eq]; subst v.
    do 3 rewrite (free_bilinear_rscalar F nat).
    apply f_equal; clear α.

    do 4 rewrite (free_bilinear_free F nat).
    rewrite plus_assoc.
    reflexivity.
Qed.
Local Program Instance polynomial_mult_comm : MultComm polynomial.
Next Obligation.
    unfold mult; cbn.

    rewrite (grade_decomposition_eq a).
    remember (grade_decomposition a) as l; clear Heql.
    induction l as [|v l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite (free_bilinear_lanni F nat).
        rewrite (free_bilinear_ranni F nat).
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    rewrite (free_bilinear_ldist F nat).
    rewrite (free_bilinear_rdist F nat).
    rewrite IHl; clear IHl.
    apply rplus; clear l.
    destruct v as [v [i vi]]; cbn.
    apply polynomial_xn_ex in vi as [α v_eq]; subst v.
    rewrite (free_bilinear_lscalar F nat).
    rewrite (free_bilinear_rscalar F nat).
    apply f_equal; clear α.

    rewrite (grade_decomposition_eq b).
    remember (grade_decomposition b) as l; clear Heql.
    induction l as [|v l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite (free_bilinear_lanni F nat).
        rewrite (free_bilinear_ranni F nat).
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    rewrite (free_bilinear_ldist F nat).
    rewrite (free_bilinear_rdist F nat).
    rewrite IHl; clear IHl.
    apply rplus; clear l.
    destruct v as [v [j vj]]; cbn.
    apply polynomial_xn_ex in vj as [α v_eq]; subst v.
    rewrite (free_bilinear_lscalar F nat).
    rewrite (free_bilinear_rscalar F nat).
    apply f_equal; clear α.
    do 2 rewrite (free_bilinear_free F nat).
    rewrite plus_comm.
    reflexivity.
Qed.
Local Instance polynomial_one : One polynomial := {
    one := polynomial_xn 0
}.
Local Program Instance polynomial_mult_lid : MultLid polynomial.
Next Obligation.
    rewrite mult_comm.
    unfold mult, one; cbn.
    rewrite (grade_decomposition_eq a).
    remember (grade_decomposition a) as l; clear Heql.
    induction l as [|v l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        apply (free_bilinear_lanni F nat).
    }
    rewrite ulist_image_add, ulist_sum_add.
    rewrite (free_bilinear_rdist F nat).
    rewrite IHl; clear IHl.
    apply rplus; clear l.
    destruct v as [v [i vi]]; cbn.
    apply polynomial_xn_ex in vi as [α v_eq]; subst v.
    rewrite (free_bilinear_lscalar F nat).
    apply f_equal.
    rewrite (free_bilinear_free F nat).
    rewrite plus_rid.
    reflexivity.
Qed.
Local Program Instance polynomial_scalar_lmult : ScalarLMult U polynomial.
Next Obligation.
    apply (free_bilinear_lscalar F nat).
Qed.
Local Program Instance polynomial_scalar_rmult : ScalarRMult U polynomial.
Next Obligation.
    apply (free_bilinear_rscalar F nat).
Qed.

Definition to_polynomial (a : U) := a · 1.
Definition polynomial_x := polynomial_xn 1.

Theorem to_polynomial_eq : ∀ a b, to_polynomial a = to_polynomial b → a = b.
Proof.
    intros a b eq.
    unfold to_polynomial in eq.
    apply scalar_rcancel in eq.
    1: exact eq.
    intros contr.
    unfold one in contr; cbn in contr.
    unfold polynomial_xn, to_free in contr.
    rewrite <- (single_to_grade_sum_zero nat _ 0) in contr.
    apply single_to_grade_sum_eq in contr.
    apply not_trivial_one.
    exact contr.
Qed.

Theorem to_polynomial_plus : ∀ a b,
    to_polynomial (a + b) = to_polynomial a + to_polynomial b.
Proof.
    intros a b.
    unfold to_polynomial.
    apply scalar_rdist.
Qed.

Theorem to_polynomial_neg : ∀ a, to_polynomial (-a) = -to_polynomial a.
Proof.
    intros a.
    unfold to_polynomial.
    apply scalar_lneg.
Qed.

Theorem to_polynomial_mult : ∀ a b,
    to_polynomial (a * b) = to_polynomial a * to_polynomial b.
Proof.
    intros a b.
    unfold to_polynomial.
    rewrite scalar_lmult, scalar_rmult.
    rewrite scalar_comp.
    unfold mult at 3; cbn.
    rewrite (free_bilinear_free F nat).
    rewrite plus_rid.
    reflexivity.
Qed.

Theorem to_polynomial_zero : to_polynomial 0 = 0.
Proof.
    unfold to_polynomial; cbn.
    apply scalar_lanni.
Qed.

Theorem to_polynomial_one : to_polynomial 1 = 1.
Proof.
    unfold to_polynomial; cbn.
    rewrite scalar_id.
    unfold one; cbn.
    reflexivity.
Qed.

Theorem to_polynomial_scalar : ∀ a f, to_polynomial a * f = a · f.
Proof.
    intros a f.
    unfold to_polynomial.
    rewrite scalar_lmult.
    rewrite mult_lid.
    reflexivity.
Qed.

Theorem to_polynomial_comm : ∀ a f, to_polynomial a * f = f * to_polynomial a.
Proof.
    intros a f.
    unfold to_polynomial.
    rewrite scalar_lmult, scalar_rmult.
    rewrite mult_lid, mult_rid.
    reflexivity.
Qed.

Theorem polynomial_xn_grade : ∀ n : nat, of_grade n (polynomial_xn n).
Proof.
    intros n.
    unfold polynomial_xn.
    unfold to_free.
    unfold of_grade; cbn.
    unfold grade_sum_subspace_set.
    exists 1.
    reflexivity.
Qed.

Theorem to_polynomial_grade : ∀ a, of_grade 0 (to_polynomial a).
Proof.
    intros a.
    unfold to_polynomial.
    apply of_grade_scalar.
    unfold one; cbn.
    apply polynomial_xn_grade.
Qed.

Let USM := module_scalar (cring_module F).
Let USML := module_scalar_ldist (cring_module F).
Let USMR := module_scalar_rdist (cring_module F).
Let USMC := module_scalar_comp (cring_module F).
Let USMO := module_scalar_id (cring_module F).

Local Existing Instances USM USML USMR USMC USMO.

Definition polynomial_eval (f : polynomial) (x : U)
    := free_extend F nat (nat_pow x) f : U.

Theorem polynomial_eval_constant :
    ∀ a x : U, polynomial_eval (to_polynomial a) x = a.
Proof.
    intros a x.
    unfold polynomial_eval, to_polynomial.
    rewrite (free_extend_scalar F nat).
    rewrite (free_extend_free F nat).
    unfold zero; cbn.
    unfold scalar_mult; cbn.
    apply mult_rid.
Qed.

Theorem polynomial_eval_zero : ∀ x, polynomial_eval 0 x = 0.
Proof.
    intros x.
    rewrite <- to_polynomial_zero.
    apply polynomial_eval_constant.
Qed.

Theorem polynomial_eval_xn : ∀ x n,
    polynomial_eval (polynomial_xn n) x = (x^n)%nat.
Proof.
    intros x n.
    unfold polynomial_eval, polynomial_xn.
    rewrite (free_extend_free F nat).
    reflexivity.
Qed.

Theorem polynomial_eval_x : ∀ x : U, polynomial_eval polynomial_x x = x.
Proof.
    intros x.
    unfold polynomial_x.
    rewrite polynomial_eval_xn.
    apply nat_pow_one.
Qed.

Theorem polynomial_eval_plus : ∀ f g x,
    polynomial_eval (f + g) x = polynomial_eval f x + polynomial_eval g x.
Proof.
    intros f g x.
    unfold polynomial_eval.
    apply (free_extend_plus F nat).
Qed.

Theorem polynomial_eval_neg : ∀ f x,
    polynomial_eval (-f) x = -polynomial_eval f x.
Proof.
    intros f x.
    unfold polynomial_eval.
    apply (free_extend_neg F nat).
Qed.

Theorem polynomial_eval_scalar : ∀ f a x,
    polynomial_eval (a · f) x = a * polynomial_eval f x.
Proof.
    intros f a x.
    unfold polynomial_eval.
    rewrite (free_extend_scalar F nat).
    unfold scalar_mult; cbn.
    reflexivity.
Qed.

Theorem polynomial_eval_mult : ∀ f g x,
    polynomial_eval (f * g) x = polynomial_eval f x * polynomial_eval g x.
Proof.
    intros f g x.
    induction f as [|f f' m fm f'm IHf] using grade_induction.
    {
        rewrite mult_lanni.
        rewrite <- to_polynomial_zero.
        rewrite (polynomial_eval_constant 0 x).
        rewrite mult_lanni.
        reflexivity.
    }
    rewrite rdist.
    do 2 rewrite polynomial_eval_plus.
    rewrite IHf.
    rewrite rdist.
    apply rplus.
    clear f' f'm IHf.
    induction g as [|g g' n gn g'n IHg] using grade_induction.
    {
        rewrite mult_ranni.
        rewrite <- to_polynomial_zero.
        rewrite (polynomial_eval_constant 0 x).
        rewrite mult_ranni.
        reflexivity.
    }
    rewrite ldist.
    do 2 rewrite polynomial_eval_plus.
    rewrite IHg.
    rewrite ldist.
    apply rplus.
    clear g' g'n IHg.
    apply polynomial_xn_ex in fm as [a f_eq].
    apply polynomial_xn_ex in gn as [b g_eq].
    subst f g.
    rewrite scalar_lmult, scalar_rmult.
    do 4 rewrite polynomial_eval_scalar.
    rewrite <- mult_assoc.
    do 2 rewrite (mult_assoc _ b).
    rewrite (mult_comm (_ _ _) b).
    do 2 rewrite mult_assoc.
    rewrite <- (mult_assoc (a * b)).
    apply f_equal.
    unfold mult at 1; cbn.
    rewrite (free_bilinear_free F nat).
    unfold polynomial_eval.
    do 3 rewrite (free_extend_free F nat).
    rewrite <- nat_pow_plus.
    reflexivity.
Qed.

Definition polynomial_rng := make_rng polynomial polynomial_plus polynomial_zero
    polynomial_neg polynomial_mult polynomial_plus_assoc polynomial_plus_comm
    polynomial_plus_lid
    polynomial_plus_linv
    polynomial_mult_assoc
    polynomial_ldist
    ldist_rdist.
Definition polynomial_ring := make_ring polynomial_rng polynomial_one
    polynomial_mult_lid mult_lid_rid.
Definition polynomial_cring := make_cring polynomial_ring polynomial_mult_comm.
Definition polynomial_algebra := make_algebra F polynomial_module
    polynomial_mult polynomial_ldist ldist_rdist polynomial_mult_assoc
    polynomial_one polynomial_mult_lid mult_lid_rid polynomial_scalar_lmult
    polynomial_scalar_rmult.

End Polynomial.

Arguments polynomial_eval {F}.
Arguments polynomial : simpl never.
Arguments polynomial_plus : simpl never.
Arguments polynomial_zero : simpl never.
Arguments polynomial_neg : simpl never.
Arguments polynomial_plus_comm : simpl never.
Arguments polynomial_plus_assoc : simpl never.
Arguments polynomial_plus_lid : simpl never.
Arguments polynomial_plus_linv : simpl never.
Arguments polynomial_scalar : simpl never.
Arguments polynomial_scalar_id : simpl never.
Arguments polynomial_scalar_ldist : simpl never.
Arguments polynomial_scalar_rdist : simpl never.
Arguments polynomial_scalar_comp : simpl never.
Arguments polynomial_grade : simpl never.
Arguments polynomial_mult : simpl never.
Arguments polynomial_ldist : simpl never.
Arguments polynomial_mult_assoc : simpl never.
Arguments polynomial_mult_comm : simpl never.
Arguments polynomial_one : simpl never.
Arguments polynomial_mult_lid : simpl never.
Arguments polynomial_scalar_lmult : simpl never.
Arguments polynomial_scalar_rmult : simpl never.


Require Import Coq.Bool.Bool.
Require Import SfLib.
Require Import Maps.
Require Import Stlc.
Require Import LibTactics.

Module STLCCHECKER.

Import STLC.

Fixpoint beq_ty (T1 T2: ty) : bool :=
    match T1, T2 with
        | TBool, TBool => true
        | TArrow t1 t2, TArrow t3 t4 => andb (beq_ty t1 t3) (beq_ty t2 t4)
        | _, _ => false
    end.

Lemma beq_ty_refl : forall t,
    beq_ty t t = true.
    induction t;cbn; eauto.
    rewrite IHt1; rewrite IHt2; eauto.
Qed.

Lemma beq_ty__eq :
    forall t1 t2,
        beq_ty t1 t2 = true -> t1 = t2.

    intro t1. induction t1; intros t2; induction t2;
    try (eauto; fail);
    try (intros h1; inversion h1; fail).
    intros. inversion H.
    destruct (beq_ty t1_1 t2_1) eqn: hh1; destruct (beq_ty t1_2 t2_2) eqn:hh2; subst; inversion H1.
    pose (IHt1_1 _ hh1); pose (IHt1_2 _ hh2). rewrite e in *; rewrite e0 in *.
    auto.
Qed.

Print tm.

Fixpoint type_check (G : context) (t : tm) : option ty :=
    match t with
        | tvar x => G x
        | tabs x T v => match (type_check (update G x T) v) with
                            | Some U => Some (TArrow T U)
                            | None => None
                        end
        | tapp abs arg =>
            match (type_check G abs) with
                | Some (TArrow U V) => match (type_check G arg) with
                                        | Some Q => if(beq_ty U Q) then Some V else None
                                        | _ => None
                                        end
                | _ => None
                end
        | ttrue => Some TBool
        | tfalse => Some TBool
        | tif t t0 t1 =>
            match type_check G t with
                | Some TBool =>
            match type_check G t0, type_check G t1 with
                | Some a, Some b => if(beq_ty a b) then Some a else None
                | _, _ => None
            end
                | _ => None
            end
    end.

Theorem type_check_sound :
    forall G t T,
        type_check G t = Some T ->
        has_type G t T.

    intros G t; gen G.
    induction t; cbn in *.
    intros. eapply T_Var; eauto.
    intros.
    destruct (type_check G t1) eqn:h1.
    destruct t eqn:h2;
    destruct (type_check G t2) eqn:h3; eauto; try discriminate.
    destruct (beq_ty t0_1 t0) eqn:h4; eauto; try discriminate.
    eapply T_App; eauto. eapply IHt1; eauto. inversion H; subst.
    pose (beq_ty__eq _ _ h4); rewrite h1. rewrite e. auto.
    inversion H.

    intros. destruct (type_check (update G i t) t0) eqn:h1; try eauto; try discriminate.
    inversion H; subst; eauto.
    intros G T h1; inversion h1; subst; eauto.
    intros G T h1; inversion h1; subst; eauto.
    intros G T h;
    destruct (type_check G t1) eqn:h1;
    destruct (type_check G t2) eqn:h2;
    destruct (type_check G t3) eqn:h3;
    eauto; try discriminate.

    destruct t eqn:h4; try discriminate; eauto.
    destruct (beq_ty t0 t4) eqn: h5; try discriminate; eauto.
    generalize (beq_ty__eq _ _ h5); intro;
    inversion h; subst. eapply T_If; eauto.
    destruct t eqn:h5; try discriminate; eauto.
    destruct t eqn:h5; try discriminate; eauto.
    destruct t eqn:h5; try discriminate; eauto.
Qed.

End STLCCHECKER.