Require Import Coq.ZArith.ZArith Coq.Strings.String Coq.Strings.Ascii.
Require Import Coq.Structures.OrderedType.
Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Export Coq.micromega.Lia.

Lemma nat_compare_eq_refl : forall x, Nat.compare x x = Eq.
  intros; apply Nat.compare_eq_iff; trivial.
Qed.

Hint Rewrite <- nat_compare_lt : nat_comp_hints.
Hint Rewrite <- nat_compare_gt : nat_comp_hints.
Hint Rewrite    Nat.compare_eq_iff : nat_comp_hints.
Hint Rewrite <- Nat.compare_eq_iff : nat_comp_hints.
Hint Rewrite    nat_compare_eq_refl : nat_comp_hints.

Ltac autorewrite_nat_compare :=
  autorewrite with nat_comp_hints in *.

Lemma nat_compare_consistent :
  forall n0 n1,
    { Nat.compare n0 n1 = Lt /\ Nat.compare n1 n0 = Gt }
    + { Nat.compare n0 n1 = Eq /\ Nat.compare n1 n0 = Eq }
    + { Nat.compare n0 n1 = Gt /\ Nat.compare n1 n0 = Lt }.
Proof.
  intros n0 n1;
  destruct (lt_eq_lt_dec n0 n1) as [ [_lt | _eq] | _lt ];
  [ constructor 1; constructor 1  | constructor 1; constructor 2 | constructor 2 ];
  split;
  autorewrite_nat_compare;
  intuition.
Qed.

Module String_as_OT <: OrderedType.
  Definition t := string.

  Fixpoint string_compare str1 str2 :=
    match str1, str2 with
      | EmptyString, EmptyString => Eq
      | EmptyString, _           => Lt
      | _, EmptyString           => Gt
      | String char1 tail1, String char2 tail2 =>
        match Nat.compare (nat_of_ascii char1) (nat_of_ascii char2) with
          | Eq => string_compare tail1 tail2
          | Lt => Lt
          | Gt => Gt
        end
    end.

  Lemma string_compare_eq_refl : forall x, string_compare x x = Eq.
    intro x;
    induction x;
      simpl; trivial;
      autorewrite_nat_compare.
      trivial.
  Qed.

  Ltac comparisons_minicrush :=
    autorewrite_nat_compare;
    match goal with
      | [ |- context [Nat.compare ?a ?b] ] =>
        let H := fresh in
        first [
            assert (Nat.compare a b = Eq) as H by (autorewrite_nat_compare; lia) |
            assert (Nat.compare a b = Lt) as H by (autorewrite_nat_compare; lia) |
            assert (Nat.compare a b = Gt) as H by (autorewrite_nat_compare; lia)
        ]; rewrite H; intuition
    end.

  Ltac destruct_comparisons :=
    repeat match goal with
             | [ H: match ?pred ?a ?b with
                      | Lt => _ | Gt => _ | Eq => _ end = _
                 |- _] =>
               let H := fresh in
               destruct (pred a b) eqn:H;
                 try discriminate
           end.

  Ltac exfalso_from_equalities :=
    match goal with
      | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => assert (b = c) by congruence; discriminate
    end.

  Definition eq := @eq string.

  #[export]
  Hint Resolve string_compare_eq_refl : core.

  Lemma eq_Eq : forall x y, x = y -> string_compare x y = Eq.
  Proof.
    intros; subst; auto.
  Qed.

  Lemma nat_of_ascii_injective :
    forall a b, nat_of_ascii a = nat_of_ascii b <-> a = b.
  Proof.
    intros a b; split; intro H;
    [ apply (f_equal ascii_of_nat) in H;
      repeat rewrite ascii_nat_embedding in H
    | apply (f_equal nat_of_ascii) in H ]; trivial.
  Qed.

  Lemma Eq_eq : forall x y, string_compare x y = Eq -> x = y.
  Proof.
    induction x;
      destruct y;
      simpl;
      first [ discriminate
            | intros;
              f_equal;
              destruct_comparisons;
              autorewrite_nat_compare;
              rewrite nat_of_ascii_injective in *
            | idtac ];
      intuition.
  Qed.

  Lemma Eq_eq_iff : forall x y, x = y <-> string_compare x y = Eq.
  Proof.
    intros; split; eauto using eq_Eq, Eq_eq.
  Qed.

  Definition eq_refl := @eq_refl string.

  Definition eq_sym := @eq_sym string.

  Definition eq_trans := @eq_trans string.

  Definition lt x y :=
    string_compare x y = Lt.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    intros x y z;
    generalize x z;
    clear x z;

    induction y;
    destruct x;
    destruct z;
      intros;
      unfold lt in *;
      simpl in *;
      first [ discriminate
            | destruct_comparisons; comparisons_minicrush
            | trivial ]; intuition.
  Qed.

  Lemma lt_not_eq : forall x y, lt x y -> ~ eq x y.
  Proof.
    unfold lt, not in *;
    intros;
    rewrite Eq_eq_iff in *;
    exfalso_from_equalities.
  Qed.

  Lemma Lt_Gt : forall x y, string_compare x y = Gt <-> string_compare y x = Lt.
  Proof.
    intros x;
    induction x as [ | x0 x' Hind ];
      intros y;
      destruct y as [ | y0 y' ];

      simpl;
      split;
      first [ discriminate | trivial ];

      destruct (nat_compare_consistent
                  (nat_of_ascii x0)
                  (nat_of_ascii y0))
          as [ [ (H1, H2) | (H1, H2) ] | (H1, H2) ];
        rewrite H1, H2;
        try rewrite Hind;
        auto.
  Qed.

  Definition compare x y : OrderedType.Compare lt eq x y.
  Proof.
    destruct (string_compare x y) eqn:comp;
      unfold lt;
      [ constructor 2; apply Eq_eq
      | constructor 1
      | constructor 3; apply Lt_Gt];
      trivial.
  Defined.

  Definition eq_dec : forall (x y: string), { x = y } + { x <> y } := string_dec.

End String_as_OT.

(* Usage example:
Require Import FMapAVL.
Require Import Coq.Structures.OrderedTypeEx.

Module StringIndexedMap := FMapAVL.Make(String_as_OT).
Definition String2Nat := StringIndexedMap.t nat.

Definition find key (map: String2Nat) := StringIndexedMap.find key map.

Definition bind (pair: string * nat) (map: String2Nat) := StringIndexedMap.add (fst pair) (snd pair) map.

Notation "k >> v" := (pair k v) (at level 100).
Notation "[[ b1 , .. , bn ]]" := (bind b1 .. (bind bn (StringIndexedMap.empty nat)) .. ).

Open Scope string_scope.

Definition population_in_millions :=
 [[ "china" >> 1364, "india" >> 1243, "united states" >> 318, "indonesia" >> 247, "brazil" >> 201, "pakistan" >> 186, "nigeria" >> 174, "bangladesh" >> 153, "russia" >> 144, "japan" >> 127, "mexico" >> 120, "philippines" >> 99, "vietnam" >> 90, "ethiopia" >> 87, "egypt" >> 86, "germany" >> 81, "iran" >> 77, "turkey" >> 77, "democratic republic of the congo" >> 68, "france" >> 66 ]].

Eval compute in (find "france" population_in_millions).
*)


Require Import Setoid.
Require Import Morphisms.
Require Import Coq.Program.Basics.

Unset Printing Records.

From Ordinal Require Import Defs.
From Ordinal Require Import Operators.
From Ordinal Require Import Arith.
From Ordinal Require Import Fixpoints.
From Ordinal Require Import VeblenDefs.

(** We say that a function is Scott continuous if it
    preserves all nonempty directed suprema of complete ordinals. *)
Definition scott_continuous (s:Ord -> Ord) :=
  forall A (f:A -> Ord) (a0:A),
    directed A f ->
    (forall a, complete (f a)) ->
    s (supOrd f) ≤ supOrd (fun i:A => s (f i)).

Record normal_function (f:Ord -> Ord) :=
  NormalFunction
  { normal_monotone   : forall x y, x ≤ y -> f x ≤ f y
  ; normal_increasing : forall x y, complete y -> x < y -> f x < f y
  ; normal_continuous : scott_continuous f
  ; normal_complete   : forall x, complete x -> complete (f x)
  ; normal_nonzero    : forall x, 0 < f x
  }.

Lemma normal_inflationary (f:Ord -> Ord) :
  normal_function f ->
  forall x, complete x -> x <= f x.
Proof.
  intro H.
  induction x as [X g Hx]. intro Hc.
  rewrite ord_le_unfold; intro x; simpl.
  rewrite (Hx x).
  * apply normal_increasing; auto.
    apply (limit_lt (ord X g)).
  * apply Hc.
Qed.

Lemma lim_normal_complete : forall (x:Ord) (f:Ord -> Ord),
    normal_function f ->
    complete x ->
    complete (@limOrd x f).
Proof.
  intros.
  apply lim_complete.
  intros; apply normal_complete; auto.
  apply complete_subord; auto.
  intros; apply directed_monotone; auto.
  intros; apply normal_monotone; auto.
  destruct x as [X g]; simpl in *; intuition.
Qed.

(* We say a function f enumerates a class of ordinals P if
   f x is the least element of P that is strictly above
   all f y for y < x. *)
Record enumerates (f:Ord -> Ord) (P:Ord -> Prop) : Prop :=
  Enumerates
    { enumerates_included   : forall x, complete x -> P (f x);
      enumerates_monotone   : forall x y, x ≤ y -> f x ≤ f y;
      enumerates_increasing : forall x y, complete y -> x < y -> f x < f y;
      enumerates_least      : forall x z, complete x -> complete z ->
                                          P z -> (forall y, y < x -> f y < z) -> f x ≤ z
    }.

(* We say x is a critical ordinal for β when
   x is a fixpoint for (veblen α) whenever α < β.
 *)
Definition critical_ordinal f (β:Ord) (x:Ord) : Prop :=
  forall α, complete α -> α < β -> x ≈ veblen f α x.

Definition strongly_critical_ordinal f (β:Ord) : Prop :=
  β > 0 /\ complete β /\ critical_ordinal f β β.

(** * Fixpoints of normal functions *)
Section normal_fixpoints.
  Variable f : Ord -> Ord.

  Lemma fixOrd_continuous :
    (forall x y, x <= y -> f x <= f y) ->
    (forall x, complete x -> complete (f x)) ->
    scott_continuous f ->
    scott_continuous (fixOrd f).
  Proof.
    red; simpl; intros Hf1 Hf2 Hf3 A g a0 Hd Hg.
    unfold fixOrd at 1.
    apply sup_least. intro i.
    apply ord_le_trans with (supOrd (fun a => iter_f f (g a) i)).
    - induction i.
      + simpl. reflexivity.
      + simpl.
        eapply ord_le_trans.
        * apply Hf1. apply IHi.
        * apply Hf3; auto.
          intros a1 a2.
          destruct (Hd a1 a2) as [a' [Ha1 Ha2]].
          exists a'. split; apply iter_f_monotone; auto.
          intros. apply iter_f_complete; auto.
    - apply sup_least. intro a.
      rewrite <- (sup_le _ _ a).
      unfold fixOrd.
      apply sup_le.
  Qed.

  Lemma directed_iter_f base :
    (forall x, complete x -> x <= f x) ->
    (forall x y, x <= y -> f x <= f y) ->
    (forall x, complete x -> complete (f x)) ->
    complete base ->
    directed nat (iter_f f base).
  Proof.
    intros. intros i j. exists (Nat.max i j).
    split; apply iter_f_index_monotone; auto.
    + apply PeanoNat.Nat.le_max_l.
    + apply PeanoNat.Nat.le_max_r.
  Qed.

  Lemma normal_fix_complete base :
    complete base ->
    (forall x, complete x -> x <= f x) ->
    (forall x y, x <= y -> f x <= f y) ->
    (forall x, complete x -> complete (f x)) ->
    complete (fixOrd f base).
  Proof.
    intros Hbase Hf1 Hf2 Hf3.
    unfold fixOrd.
    apply sup_complete; auto.
    - intros; apply iter_f_complete; auto.
    - apply directed_iter_f; auto.
    - assert (Hc' : complete (f base)).
      { apply Hf3; auto. }
      destruct (complete_zeroDec base Hbase).
      + destruct (complete_zeroDec (f base) Hc').
        * right. intro i.
          revert H H0. clear -Hf1 Hf2 Hbase. revert base Hbase.
          induction i; simpl; intros; auto.
          transitivity (f base); auto.
          apply Hf2; auto.
          rewrite IHi; auto.
          apply zero_least.
        * left.
          exists 1%nat. simpl.
          auto.
      + left.
        exists 0%nat. simpl. auto.
  Qed.

  Hypothesis Hnormal : normal_function f.

  Lemma normal_prefixpoint : forall base, complete base -> f (fixOrd f base) ≤ fixOrd f base.
  Proof.
    intros.
    apply ord_le_trans with (supOrd (fun i => f (iter_f f base i))).
    - apply (normal_continuous _ Hnormal nat (iter_f f base) 0%nat).
      apply directed_iter_f; auto.
      apply normal_inflationary; auto.
      apply normal_monotone; auto.
      apply normal_complete; auto.
      intro i; apply iter_f_complete; auto.
      apply normal_complete; auto.
    - apply sup_least. intro i.
      unfold fixOrd.
      apply (sup_le _ (iter_f f base) (S i)).
  Qed.

  Lemma normal_fixpoint : forall base, complete base -> fixOrd f base ≈ f (fixOrd f base).
  Proof.
    intros; split.
    - apply normal_inflationary; auto.
      apply normal_fix_complete; auto.
      + apply normal_inflationary; auto.
      + apply normal_monotone; auto.
      + apply normal_complete; auto.
    - apply normal_prefixpoint; auto.
  Qed.

  Lemma normal_fix_least : forall base z, complete z -> base ≤ z -> f z ≤ z -> fixOrd f base ≤ z.
  Proof.
    intros.
    unfold fixOrd.
    apply sup_least.
    intro i; induction i; simpl; auto.
    apply ord_le_trans with (f z); auto.
    apply normal_monotone; auto.
  Qed.

End normal_fixpoints.

Add Parametric Morphism f (Hf:normal_function f) : (fixOrd f)
  with signature ord_le ++> ord_le as normal_fix_le_mor.
Proof.
  apply fixOrd_monotone; auto.
  apply normal_monotone; auto.
Qed.

Add Parametric Morphism f (Hf:normal_function f) : (fixOrd f)
  with signature ord_eq ==> ord_eq as normal_fix_eq_mor.
Proof.
  unfold ord_eq; intuition; apply fixOrd_monotone; auto;
      apply normal_monotone; auto.
Qed.

Lemma powOmega_normal : normal_function powOmega.
Proof.
  apply NormalFunction.
  + apply expOrd_monotone.
  + intros; apply powOmega_increasing; auto.
  + red; intros A f a0 Hd Hc; apply (expOrd_continuous ω A f a0).
  + unfold powOmega. intros; apply expOrd_complete; auto.
    * apply (index_lt ω 0%nat).
    * apply omega_complete.
  + unfold powOmega. intros.
    apply expOrd_nonzero.
Qed.

Lemma enum_are_fixpoints f :
  normal_function f ->
  forall x, complete x -> enum_fixpoints f x ≈ f (enum_fixpoints f x).
Proof.
  intros Hf x Hc.
  destruct x as [X g]; simpl.
  apply normal_fixpoint; auto.
  apply lim_complete.
  - intros. apply enum_fixpoints_complete; auto.
    + apply normal_inflationary; auto.
    + apply normal_monotone; auto.
    + apply normal_complete; auto.
    + apply Hc.
  - intros b1 b2. destruct (complete_directed _ Hc b1 b2) as [b' [Hb1 HB2]].
    exists b'. split; apply enum_fixpoints_monotone; auto.
    apply normal_monotone; auto.
    apply normal_monotone; auto.
  - apply Hc.
Qed.

Lemma enum_fixpoints_zero f :
  normal_function f ->
  enum_fixpoints f zeroOrd ≈ fixOrd f zeroOrd.
Proof.
  simpl.
  split; apply fixOrd_monotone; auto.
  - apply normal_monotone; auto.
  - rewrite ord_le_unfold; simpl; intuition.
  - apply normal_monotone; auto.
  - rewrite ord_le_unfold; simpl; intuition.
Qed.

Lemma enum_fixpoints_succ f x :
  enum_fixpoints f (succOrd x) ≈ fixOrd f (succOrd (enum_fixpoints f x)).
Proof.
  simpl; intros. reflexivity.
Qed.

Lemma enum_fixpoints_cont f :
  normal_function f ->
  scott_continuous (enum_fixpoints f).
Proof.
  intros Hf A g a0 Hd Hc.
  simpl.
  apply normal_fix_least; auto.
  - apply sup_complete.
    + intros; apply enum_fixpoints_complete; auto.
      * apply normal_inflationary; auto.
      * apply normal_monotone; auto.
      * apply normal_complete; auto.
    + intros a1 a2. destruct (Hd a1 a2) as [a' [Ha1 Ha2]].
      exists a'.
      split; apply enum_fixpoints_monotone; auto.
      apply normal_monotone; auto.
      apply normal_monotone; auto.
    + left. exists a0.
      rewrite enum_are_fixpoints; auto.
      apply normal_nonzero; auto.
  - rewrite ord_le_unfold.
    simpl.
    intros [a i]. simpl.
    rewrite <- (sup_le _ _ a).
    apply enum_fixpoints_increasing; auto with ord.
    apply normal_monotone; auto.
  - rewrite (normal_continuous f Hf A (fun i => enum_fixpoints f (g i)) a0).
    + apply sup_least. simpl; intros.
      rewrite <- enum_are_fixpoints; auto.
      rewrite <- (sup_le _ _ a).
      auto with ord.
    + intros a1 a2. destruct (Hd a1 a2) as [a' [??]].
      exists a'. split; apply enum_fixpoints_monotone; auto.
      apply normal_monotone; auto.
      apply normal_monotone; auto.
    + intro; apply enum_fixpoints_complete; auto.
      * apply normal_inflationary; auto.
      * apply normal_monotone; auto.
      * apply normal_complete; auto.
Qed.

Lemma enum_fixpoints_normal f :
  normal_function f ->
  normal_function (enum_fixpoints f).
Proof.
  intros; constructor.
  - apply enum_fixpoints_monotone; auto.
    apply normal_monotone; auto.
  - intros; apply enum_fixpoints_increasing; auto.
    apply normal_monotone; auto.
  - apply enum_fixpoints_cont; auto.
  - apply enum_fixpoints_complete; auto.
    + apply normal_inflationary; auto.
    + apply normal_monotone; auto.
    + apply normal_complete; auto.
  - intros.
    destruct x as [X g].
    simpl.
    unfold fixOrd.
    rewrite <- (sup_le _ _ 1%nat).
    simpl.
    apply normal_nonzero; auto.
Qed.

Lemma enum_least f :
  normal_function f ->
  forall (x z:Ord),
    complete z ->
    f z ≤ z ->
    (forall x', x' < x -> enum_fixpoints f x' < z) ->
    enum_fixpoints f x ≤ z.
Proof.
  intro Hf.
  induction x as [B g Hx]. simpl; intros.
  apply normal_fix_least; auto.
  rewrite ord_le_unfold; simpl; intros.
  apply H1.
  apply limit_lt.
Qed.

Lemma enum_fixpoints_func_mono f g
      (Hf: normal_function f)
      (Hg: normal_function g) :
  (forall x, complete x -> f x ≤ g x) ->
  (forall x, complete x -> enum_fixpoints f x ≤ enum_fixpoints g x).
Proof.
  intros.
  induction x as [A q Hx]; simpl.
  unfold fixOrd.
  apply sup_ord_le_morphism. intro i.
  transitivity (iter_f f (ord A (fun b : A => enum_fixpoints g (q b))) i).
  - apply iter_f_monotone; auto.
    apply normal_monotone; auto.
    rewrite ord_le_unfold; simpl; intro a.
    rewrite ord_lt_unfold; simpl; exists a.
    apply Hx. apply H0.
  - induction i; simpl; auto with ord.
    etransitivity.
    apply normal_monotone; [ auto | apply IHi ].
    apply H.
    apply iter_f_complete; auto.
    simpl; intuition.
    + hnf; intros.
      destruct (complete_directed _ H0 a1 a2) as [a' [??]].
      exists a'.
      split; apply enum_fixpoints_monotone; auto.
      apply normal_monotone; auto.
      apply normal_monotone; auto.
    + simpl in H0; intuition.
    + apply enum_fixpoints_complete; auto.
      intros; apply normal_inflationary; auto.
      intros; apply normal_monotone; auto.
      intros; apply normal_complete; auto.
      apply H0.
    + apply normal_complete; auto.
Qed.

Lemma enum_fixpoints_func_mono' f g
      (Hf: normal_function f)
      (Hg: normal_function g) :
  (forall x, complete x -> fixOrd f x ≤ fixOrd g x) ->
  (forall x, complete x -> enum_fixpoints f x ≤ enum_fixpoints g x).
Proof.
  intros.
  induction x as [A q Hx]; simpl.
  rewrite H; auto with ord.
  apply fixOrd_monotone; auto with ord.
  apply normal_monotone; auto.
  rewrite ord_le_unfold; simpl; intro a.
  rewrite ord_lt_unfold; simpl. exists a.
  apply Hx; auto.
  apply H0.
  apply (lim_normal_complete (ord A q)); auto.
  apply enum_fixpoints_normal; auto.
Qed.

Add Parametric Morphism f (Hf:normal_function f) : (enum_fixpoints f)
  with signature ord_le ++> ord_le  as enum_fixpoint_le_mor.
Proof.
  apply enum_fixpoints_monotone; auto.
  apply normal_monotone. auto.
Qed.

Add Parametric Morphism f (Hf:normal_function f) : (enum_fixpoints f)
  with signature ord_eq ==> ord_eq  as enum_fixpoint_eq_mor.
Proof.
  unfold ord_eq; intuition; apply enum_fixpoints_monotone; auto.
  apply normal_monotone. auto.
  apply normal_monotone. auto.
Qed.

Section veblen.
  Variable f : Ord -> Ord.
  Hypothesis f_normal : normal_function f.

  Lemma veblen_nonzero (β:Ord) (y:Ord) :
    0 < veblen f β y.
  Proof.
    rewrite veblen_unroll.
    rewrite <- lub_le1.
    apply normal_nonzero; auto.
  Qed.

  Lemma veblen_unroll_nonzero (β:Ord) (y:Ord) : complete y ->
    zeroOrd < β -> veblen f β y ≈ boundedSup β (fun α => fixOrd (veblen f α) (limOrd (fun x => veblen f β (y x)))).
  Proof.
    destruct β as [B g].
    intros Hc H; split.
    rewrite ord_lt_unfold in H.
    destruct H as [b Hb]. simpl in *.
    - rewrite veblen_unroll.
      apply lub_least.
      + simpl.
        rewrite <- (sup_le _ _ b).
        unfold fixOrd.
        rewrite <- (sup_le _ _ 1%nat).
        simpl.
        rewrite veblen_unroll.
        rewrite <- lub_le1.
        apply normal_monotone; auto.
        destruct y as [Y h]. simpl.
        rewrite ord_le_unfold.
        simpl; intro q.
        rewrite ord_lt_unfold. simpl.
        exists q.
        rewrite veblen_unroll.
        rewrite <- lub_le1.
        apply normal_inflationary; auto.
        apply Hc.
      + reflexivity.
    - rewrite veblen_unroll.
      apply lub_le2.
  Qed.

  Lemma veblen_inflationary (β:Ord) : forall x, complete x -> x ≤ veblen f β x.
  Proof.
    intro x.
    rewrite veblen_unroll.
    rewrite <- lub_le1.
    apply normal_inflationary. auto.
  Qed.

  Lemma veblen_complete :
    (forall x, complete x -> complete (f x)) ->
    forall β, complete β -> forall x, complete x -> complete (veblen f β x).
  Proof.
    intro Hf.
    induction β as [B g Hβ]; intro Hc1.
    induction x as [X h Hx]; intro Hc2.
    rewrite veblen_unroll.
    unfold boundedSup.
    assert (Hsup : complete (supOrd
         (fun i : B =>
          fixOrd (veblen f (g i))
            (limOrd (fun x : ord X h => veblen f (ord B g) (ord X h x)))))).
    { destruct Hc2 as [H1 [H2 H3]].
      apply sup_complete.
      - intro b. apply normal_fix_complete.
        + simpl. repeat split; auto.
          intros x1 x2. destruct (H1 x1 x2) as [x' [Hx'1 Hx'2]].
          exists x'. split; apply veblen_monotone; auto.
          apply normal_monotone; auto.
          apply normal_monotone; auto.
        + intros; apply veblen_inflationary; auto.
        + apply veblen_monotone.
          apply normal_monotone; auto.
        + simpl; intros.
          apply Hβ; auto.
          apply Hc1.
      - intros b1 b2.
        destruct Hc1 as [Hc1 [Hc2 Hc3]].
        destruct (Hc1 b1 b2) as [b' [Hb1 Hb2]].
        exists b'; simpl.
        split; unfold fixOrd; apply sup_ord_le_morphism; intro i;
          apply iter_f_monotone_func; auto.
        + intros; apply veblen_monotone_first; auto.
          apply normal_monotone; auto.
        + intros; apply veblen_monotone; auto.
          apply normal_monotone; auto.
        + intros; apply veblen_monotone_first; auto.
          apply normal_monotone; auto.
        + intros; apply veblen_monotone; auto.
          apply normal_monotone; auto.
      - destruct Hc1 as [Hc1 [Hc2 Hc3]].
        destruct Hc2 as [[b]|Hc2].
        + left. exists b.
          unfold fixOrd.
          rewrite <- (sup_le _ _ 1%nat); simpl.
          rewrite veblen_unroll.
          rewrite <- lub_le1.
          apply ord_lt_le_trans with (f 0); auto.
          apply normal_nonzero; auto.
          apply normal_monotone; auto.
          apply zero_least.
        + right. intro b. elim Hc2. exact (inhabits b).
    }
    destruct (complete_zeroDec _ Hc1).
    - apply lub_complete1; auto.
      apply sup_least; intro b.
      destruct (ord_le_subord _ _ H b) as [[] _].
    - apply lub_complete2; auto.
      rewrite ord_lt_unfold in H.
      destruct H as [b _].
      rewrite <- (sup_le _ _ b).
      unfold fixOrd.
      rewrite <- (sup_le _ _ 1%nat); simpl.
      rewrite veblen_unroll.
      rewrite <- lub_le1.
      apply normal_monotone; auto.
      rewrite ord_le_unfold; intro x; simpl.
      rewrite ord_lt_unfold; exists x. simpl.
      apply veblen_inflationary.
      apply Hc2.
  Qed.

  Lemma veblen_increasing0 : forall x y, complete y -> x < y -> veblen f 0 x < veblen f 0 y.
  Proof.
    intros.
    apply ord_le_lt_trans with (f x).
    { rewrite veblen_unroll.
      apply lub_least; auto with ord.
      apply boundedSup_least. simpl; intros.
      elim (ord_lt_irreflexive zeroOrd).
      apply ord_le_lt_trans with x0; auto.
      apply zero_least. }
    apply ord_lt_le_trans with (f y).
    apply normal_increasing; auto.
    rewrite veblen_unroll.
    apply lub_le1.
  Qed.

  Lemma veblen_increasing_nonzero (β:Ord) : 0 < β -> forall x y, x < y -> veblen f β x < veblen f β y.
  Proof.
    intros.
    rewrite (veblen_unroll f β y).
    rewrite <- lub_le2.
    rewrite ord_lt_unfold in H.
    destruct H as [b Hb].
    destruct β as [B g]. simpl.
    rewrite <- (sup_le _ _ b).
    unfold fixOrd.
    rewrite <- (sup_le _ _ 0%nat).
    simpl.
    rewrite ord_lt_unfold in H0.
    destruct H0 as [q Hq].
    rewrite ord_lt_unfold. simpl.
    exists q.
    apply veblen_monotone; auto.
    apply normal_monotone; auto.
  Qed.

  Lemma veblen_increasing (β:Ord) :
    complete β ->
    forall x y, complete y -> x < y -> veblen f β x < veblen f β y.
  Proof.
    intro Hβ.
    destruct (complete_zeroDec β); auto.
    - intros.
      apply ord_le_lt_trans with (veblen f 0 x).
      apply veblen_monotone_first; auto.
      apply normal_monotone; auto.
      apply ord_lt_le_trans with (veblen f 0 y).
      apply veblen_increasing0; auto.
      apply veblen_monotone_first; auto.
      apply normal_monotone; auto.
      apply zero_least.
    - intros. apply veblen_increasing_nonzero; auto.
  Qed.

  Lemma veblen_lt_lemma β : zeroOrd < β -> forall x q,
     complete x ->
     q < veblen f β x ->
     exists a, a < β /\ exists n,
         q < iter_f (veblen f a) (limOrd (fun i => veblen f β (x i))) n.
  Proof.
    intros Hb x q Hc H.
    rewrite veblen_unroll_nonzero in H; auto.
    destruct β as [B g]. simpl in H.
    rewrite ord_lt_unfold in H.
    simpl in H.
    destruct H as [[b [n z]] Hq].
    simpl in *.
    exists (g b). split; [ apply (index_lt (ord B g)) | ].
    exists n.
    rewrite ord_lt_unfold. simpl. exists z. auto.
  Qed.

  Lemma veblen_fixpoints_aux (β:Ord) (Hcomplete : complete β) :
      (forall y, y < β -> complete y -> scott_continuous (veblen f y)) ->
      forall α x, α < β -> complete α -> complete x -> veblen f α (veblen f β x) ≤ veblen f β x.
  Proof.
    intros Hcont a x H Hac Hxc.
    rewrite (veblen_unroll f a).
    apply lub_least.
    - transitivity (f (boundedSup β (fun α => fixOrd (veblen f α) (limOrd (fun i => veblen f β (x i)))))).
      + apply normal_monotone; auto.
        rewrite (veblen_unroll_nonzero); auto. reflexivity.
        apply ord_le_lt_trans with a; auto. apply zero_least.
      + rewrite (veblen_unroll_nonzero); auto.
        2: { apply ord_le_lt_trans with a; auto. apply zero_least. }
        destruct β as [B g]. simpl.
        rewrite ord_lt_unfold in H.
        destruct H as [b Hb].
        rewrite (normal_continuous f f_normal B _ b).
        * apply sup_least; intro i.
          rewrite <- (sup_le _ _ i).
          transitivity (veblen f (g i)
                               (fixOrd (veblen f (g i))
                                           (limOrd (fun i0 : x => veblen f (ord B g) (x i0))))).
          rewrite (veblen_unroll f (g i)).
          apply lub_le1.
          apply normal_prefixpoint.
          { constructor.
            + apply veblen_monotone.
              apply normal_monotone; auto.
            + apply veblen_increasing. apply Hcomplete.
            + apply Hcont. apply (index_lt (ord B g)).
              destruct Hcomplete as [?[??]]; auto.
            + intros; apply veblen_complete; auto.
              apply normal_complete; auto.
              apply Hcomplete.
            + intro; apply veblen_nonzero.
          }
          apply lim_complete.
          ** intro; apply veblen_complete; auto.
             apply normal_complete; auto.
             apply complete_subord; auto.
          ** intros x1 x2. destruct (complete_directed _ Hxc x1 x2) as [x' [Hx1 Hx2]].
             exists x'.
             split; apply veblen_monotone; auto.
             apply normal_monotone; auto.
             apply normal_monotone; auto.
          ** destruct x; apply Hxc.

        * intros b1 b2. destruct (complete_directed _ Hcomplete b1 b2) as [b' [Hb1 Hb2]].
          exists b'. split.
          ** unfold fixOrd. apply sup_ord_le_morphism.
             intro i. apply iter_f_monotone_func.
             *** intros; apply veblen_monotone_first; auto.
                 apply normal_monotone; auto.
             *** intros; apply veblen_monotone; auto.
                 apply normal_monotone; auto.
          ** unfold fixOrd. apply sup_ord_le_morphism.
             intro i. apply iter_f_monotone_func.
             *** intros; apply veblen_monotone_first; auto.
                 apply normal_monotone; auto.
             *** intros; apply veblen_monotone; auto.
                 apply normal_monotone; auto.
        * intro. apply normal_fix_complete; auto.
          ** apply lim_complete.
             *** intros; apply veblen_complete; auto.
                 apply normal_complete; auto.
                 apply complete_subord; auto.
             *** intros x1 x2. destruct (complete_directed _ Hxc x1 x2) as [x' [Hx1 Hx2]].
                 exists x'.
                 split; apply veblen_monotone; auto.
                 apply normal_monotone; auto.
                 apply normal_monotone; auto.
             *** destruct x; apply Hxc.
          ** apply veblen_inflationary.
          ** apply veblen_monotone; auto.
             apply normal_monotone; auto.
          ** intros; apply veblen_complete; auto.
             apply normal_complete; auto.
             apply Hcomplete.

    - destruct a as [A g]. simpl.
      apply sup_least. intro y.
      rewrite (veblen_unroll f β) at 2.
      rewrite <- lub_le2.
      unfold fixOrd.
      apply sup_least.
      intro i.
      simpl.
      induction i; simpl.
      + apply limit_least. intro q.
        destruct (veblen_lt_lemma β) with x q as [a' [Ha' [n Hn]]]; auto.
        * apply ord_le_lt_trans with (ord A g); auto. apply zero_least.
        * apply index_lt.
        * assert (exists a2, a2 < β /\ ord A g <= a2 /\ a' <= a2).
          { destruct β as [B h].
            rewrite ord_lt_unfold in H.
            destruct H as [b1 Hb1].
            rewrite ord_lt_unfold in Ha'.
            destruct Ha' as [b2 Hb2].
            destruct (complete_directed _ Hcomplete b1 b2) as [b' [??]].
            exists (h b').
            split.
            apply (index_lt (ord B h)).
            split.
            simpl in *.
            transitivity (h b1); auto.
            transitivity (h b2); auto.
          }
          destruct H0 as [a2 [?[??]]].
          apply ord_lt_le_trans with (iter_f (veblen f a2) (limOrd (fun i => veblen f β (x i))) (S n)).
          ** simpl.
             apply ord_lt_le_trans with (veblen f (ord A g) (iter_f (veblen f a2) (limOrd (fun i => veblen f β (x i))) n)).
             *** apply veblen_increasing_nonzero; auto.
                 **** apply ord_le_lt_trans with (g y); [ apply zero_least | apply (index_lt (ord A g)) ].
                 **** eapply ord_lt_le_trans; [ apply Hn | ].
                      apply iter_f_monotone_func; intros;
                        [ apply veblen_monotone_first; auto
                        | apply veblen_monotone; auto ].
                 apply normal_monotone; auto.
                 apply normal_monotone; auto.
             *** apply veblen_monotone_first; auto.
                 apply normal_monotone; auto.
          ** transitivity (supOrd (iter_f (veblen f a2) (limOrd (fun x0 : x => veblen f β (x x0))))).
             *** apply sup_le.
             *** rewrite <- boundedSup_le.
                 **** reflexivity.
                 **** intros.
                      apply sup_ord_le_morphism.
                      hnf; simpl; intros.
                      { apply iter_f_monotone_func; intros.
                        - apply veblen_monotone_first; auto.
                          apply normal_monotone; auto.
                        - apply veblen_monotone; auto.
                          apply normal_monotone; auto.
                      }
                 **** auto.
      + transitivity
          (veblen f (g y) (boundedSup β
            (fun α : Ord =>
             supOrd
               (iter_f (veblen f α) (limOrd (fun x0 : x => veblen f β (x x0))))))).
        { apply veblen_monotone; auto. apply normal_monotone; auto. }
        destruct β as [B h].
        simpl.
        rewrite ord_lt_unfold in H.
        destruct H as [b Hb].
        simpl in *.
        assert (Hy' : g y < ord B h).
        { transitivity (ord A g) ; auto.
          apply (index_lt (ord A g)).
          rewrite ord_lt_unfold. exists b. auto.
        }
        assert (Hcy: complete (g y)).
        { destruct Hac as [?[??]]; auto. }
        rewrite (Hcont (g y) Hy' Hcy B _ b).
        * apply sup_least.
          intro b'.
          assert (exists b2, h b <= h b2 /\ h b' <= h b2).
          { destruct Hcomplete as [Hc ?].
            destruct (Hc b b'); auto.
          }
          destruct H as [b2 [??]].
          rewrite <- (sup_le _ _ b2).
          rewrite (Hcont (g y) Hy' Hcy nat _ 0%nat).
          ** apply sup_least.
             simpl; intro j.
             rewrite <- (sup_le _ _ (S j)).
             simpl.
             transitivity (veblen f (g y) (iter_f (veblen f (h b2)) (limOrd (fun x0 : x => veblen f (ord B h) (x x0))) j)).
             *** apply veblen_monotone.
                 apply normal_monotone; auto.
                 apply iter_f_monotone_func; intros.
                 **** apply veblen_monotone_first; auto.
                      apply normal_monotone; auto.
                 **** apply veblen_monotone; auto.
                      apply normal_monotone; auto.
             *** apply veblen_monotone_first.
                 apply normal_monotone; auto.
                 transitivity (ord A g); auto with ord.
                 transitivity (h b); auto.
          ** apply directed_iter_f.
             *** intros; apply veblen_inflationary; auto.
             *** intros; apply veblen_monotone; auto.
                 apply normal_monotone; auto.
             *** intros; apply veblen_complete; auto.
                 apply normal_complete; auto.
                 apply Hcomplete.
             *** apply lim_complete.
                 **** intros; apply veblen_complete; auto.
                      apply normal_complete; auto.
                      apply complete_subord; auto.
                 **** intros x1 x2. destruct (complete_directed _ Hxc x1 x2) as [x' [Hx1 Hx2]].
                      exists x'.
                      split; apply veblen_monotone; auto.
                      apply normal_monotone; auto.
                      apply normal_monotone; auto.
                 **** destruct x; apply Hxc.
          ** intro j. apply iter_f_complete; auto.
             *** apply lim_complete.
                 **** intros; apply veblen_complete; auto.
                      apply normal_complete; auto.
                      apply complete_subord; auto.
                 **** intros x1 x2. destruct (complete_directed _ Hxc x1 x2) as [x' [Hx1 Hx2]].
                      exists x'.
                      split; apply veblen_monotone; auto.
                      apply normal_monotone; auto.
                      apply normal_monotone; auto.
                 **** destruct x; apply Hxc.
             *** intros; apply veblen_complete; auto.
                 apply normal_complete; auto.
                 apply Hcomplete.

        * intros b1 b2. destruct (complete_directed (ord B h) Hcomplete b1 b2) as [b' [Hb1 Hb2]].
          simpl in *.
          exists b'. split.
          ** apply sup_ord_le_morphism. intro j.
             apply iter_f_monotone_func.
             *** intros; apply veblen_monotone_first; auto.
                 apply normal_monotone; auto.
             *** intros; apply veblen_monotone; auto.
                 apply normal_monotone; auto.
          ** apply sup_ord_le_morphism. intro j.
             apply iter_f_monotone_func.
             *** intros; apply veblen_monotone_first; auto.
                 apply normal_monotone; auto.
             *** intros; apply veblen_monotone; auto.
                 apply normal_monotone; auto.
        * intro b'.
          apply sup_complete.
          ** intro j.
             apply iter_f_complete; auto.
             *** apply lim_complete.
                 **** intro; apply veblen_complete; auto.
                      apply normal_complete; auto.
                      apply complete_subord; auto.
                 **** intros x1 x2. destruct (complete_directed _ Hxc x1 x2) as [x' [Hx1 Hx2]].
                      exists x'.
                      split; apply veblen_monotone; auto.
                      apply normal_monotone; auto.
                      apply normal_monotone; auto.
                 **** destruct x; apply Hxc.
             *** intros; apply veblen_complete; auto.
                 apply normal_complete; auto.
                 apply Hcomplete.
          ** apply directed_iter_f.
             *** intros; apply veblen_inflationary; auto.
             *** apply veblen_monotone; auto.
                 apply normal_monotone; auto.
             *** apply veblen_complete; auto.
                 apply normal_complete; auto.
                 apply Hcomplete.
             *** apply lim_complete.
                 **** intro; apply veblen_complete; auto.
                      apply normal_complete; auto.
                      apply complete_subord; auto.
                 **** intros x1 x2. destruct (complete_directed _ Hxc x1 x2) as [x' [Hx1 Hx2]].
                      exists x'.
                      split; apply veblen_monotone; auto.
                      apply normal_monotone; auto.
                      apply normal_monotone; auto.
                 **** destruct x; apply Hxc.
          ** left. exists 1%nat. simpl.
             apply veblen_nonzero.
  Qed.

  Lemma veblen_continuous (β:Ord) : complete β -> scott_continuous (veblen f β).
  Proof.
    induction β as [β Hind] using ordinal_induction.
    intro Hc.
    destruct β as [A g]; simpl.
    hnf; intros X h x Hd Hh.
    rewrite veblen_unroll.
    apply lub_least.
    - rewrite (normal_continuous f f_normal X h x); auto.
      apply sup_ord_le_morphism.
      hnf; simpl; intros.
      rewrite veblen_unroll.
      rewrite <- lub_le1.
      reflexivity.
    - apply sup_least. intro a.
      apply normal_fix_least.
      + constructor.
        * apply veblen_monotone.
          apply normal_monotone; auto.
        * apply veblen_increasing. apply Hc.
        * apply Hind. apply (index_lt (ord A g)).
          apply Hc.
        * apply veblen_complete; auto.
          apply normal_complete; auto.
          apply Hc.
        * apply veblen_nonzero.
      + apply sup_complete.
        * intros; apply veblen_complete; auto.
          apply normal_complete; auto.
        * intros x1 x2. destruct (Hd x1 x2) as [x' [Hx1 Hx2]].
          exists x'. split; apply veblen_monotone; auto.
          apply normal_monotone; auto.
          apply normal_monotone; auto.
        * left. exists x.
          apply veblen_nonzero.
      + rewrite ord_le_unfold.
        rewrite sup_unfold. simpl.
        intros [x' y]. simpl.
        rewrite <- (sup_le _ _ x').
        apply veblen_increasing_nonzero.
        * rewrite ord_lt_unfold. exists a. apply zero_least.
        * apply index_lt.
      + assert (Hc' : complete (g a)).
        { apply Hc. }
        rewrite (Hind (g a) (index_lt (ord A g) a) Hc' X (fun i => veblen f (ord A g) (h i)) x).
        * apply sup_ord_le_morphism. hnf; simpl. intro x'.
          apply veblen_fixpoints_aux; auto.
          apply (index_lt (ord A g)).
        * intros x1 x2.
          destruct (Hd x1 x2) as [x' [??]].
          exists x'.
          split; apply veblen_monotone; auto.
          apply normal_monotone; auto.
          apply normal_monotone; auto.
        * intros; apply veblen_complete; auto.
          apply normal_complete; auto.
  Qed.

  Lemma veblen_fixpoints :
    forall α β x,
      complete α ->
      complete β ->
      complete x ->
      α < β ->
      veblen f α (veblen f β x) ≈ veblen f β x.
  Proof.
    intros; split.
    - apply veblen_fixpoints_aux; auto.
      intros. apply veblen_continuous; auto.
    - apply veblen_inflationary.
      apply veblen_complete; auto.
      apply normal_complete; auto.
  Qed.

  Lemma veblen_continuous_first : strongly_continuous (fun β => veblen f β 0).
  Proof.
    hnf; intros A g a.
    rewrite veblen_unroll.
    apply lub_least.
    - rewrite <- (sup_le _ _ a).
      rewrite veblen_unroll.
      apply lub_le1.
    - simpl.
      apply sup_least. intros [a' z]. simpl.
      rewrite <- (sup_le A (fun i => veblen f (g i) 0) a').
      rewrite veblen_unroll.
      rewrite <- lub_le2.
      destruct (g a') as [Q q]. simpl in *.
      rewrite <- (sup_le Q _ z).
      apply fixOrd_monotone; auto.
      apply veblen_monotone.
      apply normal_monotone; auto.
      rewrite ord_le_unfold.
      simpl; intros. elim a0.
  Qed.

  Lemma veblen_normal (β:Ord) : complete β -> normal_function (veblen f β).
  Proof.
    constructor.
    - apply veblen_monotone.
      apply normal_monotone; auto.
    - apply veblen_increasing; auto.
    - apply veblen_continuous; auto.
    - intros; apply veblen_complete; auto.
      apply normal_complete; auto.
    - apply veblen_nonzero.
  Qed.

  Lemma veblen_increasing_first :
    forall a β, complete β -> a < β -> veblen f a 0 < veblen f β 0.
  Proof.
    intros a β Hβ H.
    rewrite (veblen_unroll f β).
    rewrite <- lub_le2.
    destruct β as [B g].
    rewrite ord_lt_unfold in H.
    destruct H as [b Hb].
    simpl.
    rewrite <- (sup_le _ _ b).
    apply ord_le_lt_trans with (veblen f (g b) zeroOrd).
    apply veblen_monotone_first; auto.
    apply normal_monotone; auto.
    unfold fixOrd.
    rewrite <- (sup_le _ _ 2%nat). simpl.
    apply veblen_increasing.
    - apply Hβ.
    - apply veblen_complete; auto.
      + apply normal_complete; auto.
      + apply Hβ.
      + apply lim_complete.
        * intros [].
        * intros [].
        * right; intros [[]].
    - apply veblen_nonzero.
  Qed.

  Lemma veblen_first_normal :
    normal_function (fun β => veblen f β 0).
  Proof.
    constructor.
    - intros; apply veblen_monotone_first; auto.
      apply normal_monotone; auto.
    - intros; apply veblen_increasing_first; auto.
    - hnf; intros.
      apply veblen_continuous_first; auto.
    - intros; apply veblen_complete; auto.
      apply normal_complete; auto.
      apply zero_complete.
    - intro; apply veblen_nonzero; auto.
  Qed.

  Lemma veblen_zero : forall x,
    veblen f 0 x ≈ f x.
  Proof.
    intro x.
    rewrite veblen_unroll. simpl.
    split.
    - apply lub_least; auto with ord.
      apply sup_least; simpl; intros.
      exfalso; auto.
    - apply lub_le1.
  Qed.

  Lemma veblen_succ : forall a x, complete a ->
    veblen f (succOrd a) x ≈ enum_fixpoints (veblen f a) x.
  Proof.
    intros a x Ha; induction x as [X g Hind].
    simpl.
    rewrite veblen_unroll.
    split.
    - simpl.
      apply lub_least.
      + unfold  fixOrd.
        rewrite <- (sup_le _ _ 1%nat). simpl.
        rewrite veblen_unroll.
        rewrite <- lub_le1.
        apply normal_monotone; auto.
        rewrite ord_le_unfold; simpl; intro x.
        rewrite ord_lt_unfold; simpl; exists x.
        apply increasing_inflationary.
        apply enum_fixpoints_increasing.
        apply veblen_normal; auto.
      + apply sup_least. intro.
        apply fixOrd_monotone.
        intros; apply veblen_monotone; auto.
        apply normal_monotone; auto.
        unfold limOrd.
        rewrite ord_le_unfold; simpl; intro x.
        rewrite ord_lt_unfold; simpl; exists x.
        apply Hind.
    - rewrite <- lub_le2.
      simpl.
      rewrite <- (sup_le _ _ tt).
      apply fixOrd_monotone.
      apply veblen_monotone.
      apply normal_monotone; auto.
      rewrite ord_le_unfold; simpl; intro x.
      rewrite ord_lt_unfold; simpl; exists x.
      apply Hind.
  Qed.

  Lemma veblen_limit_zero :
    forall β, limitOrdinal β -> complete β ->
      veblen f β 0 ≈ boundedSup β (fun a => veblen f a 0).
  Proof.
    intros.
    rewrite (veblen_unroll f β).
    split.
    - apply lub_least.
      + transitivity (veblen f zeroOrd zeroOrd).
        rewrite veblen_zero.
        reflexivity.
        destruct β as [B g]; simpl in *.
        destruct H as [[b] _].
        rewrite <- (sup_le _ _ b).
        apply veblen_monotone_first.
        apply normal_monotone; auto.
        apply zero_least.
      + destruct β as [B g]; simpl in *.
        apply sup_least; simpl; intro b.
        destruct H as [_ H].
        destruct (H b) as [b' Hb'].
        rewrite <- (sup_le _ _ b').
        unfold fixOrd.
        apply sup_least.
        intro i; induction i; simpl.
        * rewrite ord_le_unfold; simpl; intuition.
        * rewrite <- (veblen_fixpoints (g b) (g b')); auto.
          apply veblen_monotone; auto.
          apply normal_monotone; auto.
          destruct H0 as [?[??]]; auto.
          destruct H0 as [?[??]]; auto.
          apply zero_complete.
    - rewrite <- lub_le2.
      destruct β as [B g]; simpl in *.
      apply sup_least; simpl; intro i.
      rewrite <- (sup_le _ _ i).
      unfold fixOrd.
      rewrite <- (sup_le _ _ 1%nat).
      simpl.
      apply veblen_monotone.
      apply normal_monotone; auto.
      apply zero_least.
  Qed.

  Lemma veblen_limit_succ :
    forall β x, limitOrdinal β -> complete β -> complete x ->
      veblen f β (succOrd x) ≈ boundedSup β (fun a => veblen f a (succOrd (veblen f β x))).
  Proof.
    intros β x Hlim Hβ Hx.
    rewrite veblen_unroll.
    split.
    - apply lub_least.
      + destruct β as [B g]; simpl.
        destruct Hlim as [[b] _].
        rewrite <- (sup_le _ _ b).
        rewrite (veblen_unroll f (g b)).
        rewrite <- lub_le1.
        apply normal_monotone; auto.
        apply succ_monotone.
        apply veblen_inflationary; auto.
      + destruct β as [B g]; simpl.
        apply sup_least; simpl; intro b.
        destruct Hlim as [_ H].
        destruct (H b) as [b' Hb'].
        rewrite <- (sup_le _ _ b').
        unfold fixOrd. apply sup_least.
        intro i; simpl.
        induction i; simpl.
        * rewrite ord_le_unfold; simpl; intro.
          apply ord_lt_le_trans with (succOrd (veblen f (ord B g) x)).
          rewrite ord_lt_unfold. exists tt; simpl.
          reflexivity.
          apply veblen_inflationary; auto.
          apply succ_complete.
          apply veblen_complete; auto.
          apply normal_complete; auto.

        * rewrite <- (veblen_fixpoints (g b) (g b')); auto.
          ** apply veblen_monotone; auto.
             apply normal_monotone; auto.
          ** apply Hβ.
          ** apply Hβ.
          ** apply succ_complete.
             apply veblen_complete; auto.
             apply normal_complete; auto.

    - destruct β as [B g]; simpl.
      apply sup_least; intro b.
      rewrite <- lub_le2.
      rewrite <- (sup_le _ _ b).
      unfold fixOrd.
      rewrite <- (sup_le _ _ 1%nat).
      simpl.
      apply veblen_monotone.
      apply normal_monotone; auto.
      apply succ_least.
      rewrite ord_lt_unfold; exists tt. simpl.
      reflexivity.
  Qed.

  Lemma veblen_limit_limit :
    forall β x, limitOrdinal β -> limitOrdinal x -> complete β -> complete x ->
      veblen f β x ≈ boundedSup β (fun a => veblen f a (boundedSup x (fun y => veblen f β y))).
  Proof.
    intros β x Hlimβ Hlimx Hβ Hx.
    destruct β as [B g].
    destruct x as [X h]. simpl.
    rewrite veblen_unroll. simpl.
    split.
    - apply lub_least.
      + destruct Hlimβ as [[b] H].
        rewrite <- (sup_le _ _ b).
        rewrite veblen_unroll.
        rewrite <- lub_le1.
        apply normal_monotone; auto.
        rewrite ord_le_unfold; simpl; intro x.
        destruct Hlimx as [_ H0].
        destruct (H0 x) as [x' Hx'].
        rewrite <- (sup_le _ _ x').
        apply ord_lt_le_trans with (h x'); auto.
        apply veblen_inflationary.
        apply Hx.
      + apply sup_least; intro b.
        destruct Hlimβ as [_ H].
        destruct (H b) as [b' Hb'].
        rewrite <- (sup_le _ _ b').
        unfold fixOrd.
        apply sup_least.
        simpl; intro i.
        induction i; simpl.
        * rewrite ord_le_unfold; simpl; intro x.
          rewrite <- (veblen_inflationary (g b')).
          ** destruct Hlimx as [_ H0].
             destruct (H0 x) as [x' Hx'].
             rewrite <- (sup_le _ _ x').
             apply veblen_increasing_nonzero; auto.
             apply ord_le_lt_trans with (g b'); auto.
             apply zero_least.
             apply (index_lt (ord B g)).
          ** apply sup_complete.
             *** intros; apply veblen_complete; auto.
                 apply normal_complete; auto.
                 apply Hx.
             *** intros x1 x2. destruct (complete_directed (ord X h) Hx x1 x2) as [x' [Hx1 Hx2]].
                 exists x'; split; apply veblen_monotone; auto.
                 apply normal_monotone; auto.
                 apply normal_monotone; auto.
             *** left. exists x. apply veblen_nonzero.
        * rewrite <- (veblen_fixpoints (g b) (g b')); auto.
          ** apply veblen_monotone; auto.
             apply normal_monotone; auto.
          ** apply Hβ.
          ** apply Hβ.
          ** apply sup_complete.
             *** intros; apply veblen_complete; auto.
                 apply normal_complete; auto.
                 apply Hx.
             *** intros x1 x2. destruct (complete_directed (ord X h) Hx x1 x2) as [x' [Hx1 Hx2]].
                 exists x'; split; apply veblen_monotone; auto.
                 apply normal_monotone; auto.
                 apply normal_monotone; auto.
             *** destruct Hx as [Hx1 [Hx2 Hx3]].
                 destruct Hx2 as [[x]|Hx2].
                 **** left. exists x. apply veblen_nonzero.
                 **** right. intro x. elim Hx2. exact (inhabits x).
    - rewrite <- lub_le2.
      apply sup_least; intro b.
      rewrite <- (sup_le _ _ b).
      unfold fixOrd.
      rewrite <- (sup_le _ _ 1%nat); simpl.
      apply veblen_monotone.
      apply normal_monotone; auto.
      apply sup_least. intro x.
      apply ord_lt_le.
      rewrite ord_lt_unfold. simpl. exists x.
      reflexivity.
  Qed.

  Theorem veblen_enumerates_critical β :
    β > 0 -> complete β ->
    enumerates (veblen f β) (critical_ordinal f β).
  Proof.
    intros Hβ Hc.
    constructor.
    - intros x Hx. unfold critical_ordinal.
      intros. symmetry. apply veblen_fixpoints; auto.
    - intros; apply veblen_monotone; auto.
      apply normal_monotone; auto.
    - intros; apply veblen_increasing; auto.
    - intros x z Hx Hz Hz1 Hz2.
      rewrite veblen_unroll.
      apply lub_least.
      + generalize (Hz1 0 zero_complete Hβ).
        rewrite veblen_zero.
        intro.
        rewrite H.
        apply normal_monotone; auto.
        rewrite ord_le_unfold. intro a.
        apply ord_le_lt_trans with (veblen f β (x a)); auto.
        apply veblen_inflationary.
        apply complete_subord. auto.
        apply Hz2. apply index_lt.
      + destruct β as [B g]. simpl.
        apply sup_least; intro i.
        apply fixOrd_least.
        * apply veblen_monotone; auto.
          apply normal_monotone; auto.
        * rewrite ord_le_unfold; simpl.
          intro a.
          apply Hz2.
          apply index_lt.
        * apply Hz1. apply Hc.
          apply (index_lt (ord B g)); auto.
  Qed.

  Theorem strongly_critical_fixpoint β (Hc:complete β) :
    strongly_critical_ordinal f β <-> veblen f β 0 ≈ β.
  Proof.
    split; intro H.
    - destruct H as [Hβ [_ H]].
      split.
      + rewrite veblen_unroll.
        apply lub_least.
        * generalize (H 0 zero_complete Hβ).
          rewrite veblen_zero. intro.
          rewrite H0.
          apply normal_monotone; auto with ord.
        * destruct β as [B g]; simpl.
          apply sup_least. simpl; intro.
          apply fixOrd_least; auto.
          ** apply veblen_monotone; auto.
             apply normal_monotone; auto.
          ** rewrite ord_le_unfold. simpl; intro.
             elim a0.
          ** apply H.
             apply Hc.
             apply (index_lt (ord B g) a).
      + apply (normal_inflationary (fun x => veblen f x 0)); auto.
        apply veblen_first_normal; auto.
    - hnf. split; [ | split]; auto.
      + rewrite <- H. apply veblen_nonzero.
      + intros α Hca Hα.
        rewrite <- H at 1.
        transitivity (veblen f α (veblen f β 0)).
        symmetry. apply veblen_fixpoints; auto.
        apply zero_complete.
        split; apply veblen_monotone.
        apply normal_monotone; auto.
        apply H.
        apply normal_monotone; auto.
        apply H.
  Qed.

End veblen.

Lemma enumerates_equiv_pred f P P' :
  normal_function f ->
  (forall x, complete x -> P x <-> P' x) ->
  enumerates f P ->
  enumerates f P'.
Proof.
  intros Hn Hp Hf.
  constructor.
  - intros. apply Hp.
    apply normal_complete; auto.
    apply enumerates_included; auto.
  - eapply enumerates_monotone; eauto.
  - eapply enumerates_increasing; eauto.
  - intros x z Hx Hz1 Hz2.
    apply (enumerates_least f P Hf); auto.
    apply Hp; auto.
Qed.

Theorem enum_fixpoints_enumerates f:
  (forall x, complete x -> x ≤ f x) ->
  (forall x y, x ≤ y -> f x ≤ f y) ->
  normal_function f ->
  enumerates (enum_fixpoints f) (fun x => x ≈ f x).
Proof.
  intros Hinf Hmono Hcont.
  hnf; intros.
  constructor; auto.
  - apply enum_are_fixpoints; auto.
  - intros; apply enum_fixpoints_monotone; auto.
  - intros; apply enum_fixpoints_increasing; auto.
  - intros x z Hx Hz Hz1 Hz2.
    destruct x as [A g]. simpl.
    apply fixOrd_least; auto.
    + rewrite ord_le_unfold. simpl; intros.
      apply Hz2. apply (index_lt (ord A g) a).
    + apply Hz1.
Qed.

Definition Γ a := enum_fixpoints (fun b => veblen powOmega b 0) a.

Theorem Γ_fixpoints : forall a, complete a -> Γ a ≈ veblen powOmega (Γ a) 0.
Proof.
  intros a Ha. unfold Γ.
  apply enum_are_fixpoints; auto.
  apply veblen_first_normal.
  apply powOmega_normal.
Qed.

Theorem Γ_normal : normal_function Γ.
Proof.
  unfold Γ.
  apply enum_fixpoints_normal.
  apply veblen_first_normal.
  apply powOmega_normal.
Qed.

Theorem Γ₀_least : forall x, veblen powOmega x 0 ≈ x -> Γ 0 ≤ x.
Proof.
  intros.
  unfold Γ.
  rewrite enum_fixpoints_zero.
  apply fixOrd_least.
  intros; apply veblen_monotone_first; auto.
  apply powOmega_monotone; auto.
  apply zero_least.
  apply H.
  apply veblen_first_normal.
  apply powOmega_normal; auto.
Qed.

Theorem Γ_enumerates : enumerates Γ (strongly_critical_ordinal powOmega).
Proof.
  cut (enumerates Γ (fun x => x ≈ veblen powOmega x 0)).
  { apply enumerates_equiv_pred.
    apply Γ_normal.
    intros. rewrite strongly_critical_fixpoint; auto.
    split; apply ord_eq_sym.
    apply powOmega_normal. }

  apply enum_fixpoints_enumerates.
  - intros.
    apply (normal_inflationary (fun x => veblen powOmega x 0)); auto.
    apply veblen_first_normal.
    apply powOmega_normal.
  - intros; apply veblen_monotone_first; auto.
    apply powOmega_monotone.
  - apply veblen_first_normal.
    apply powOmega_normal.
Qed.

Definition Ξ a := enum_fixpoints (fun b => veblen Γ b 0) a.

Theorem Ξ_fixpoints : forall a, complete a -> Ξ a ≈ veblen Γ (Ξ a) 0.
Proof.
  intros a Ha. unfold Ξ.
  apply enum_are_fixpoints; auto.
  apply veblen_first_normal.
  apply Γ_normal.
Qed.

Theorem Ξ_normal : normal_function Ξ.
Proof.
  unfold Ξ.
  apply enum_fixpoints_normal.
  apply veblen_first_normal.
  apply Γ_normal.
Qed.

Theorem Ξ_enumerates : enumerates Ξ (strongly_critical_ordinal Γ).
Proof.
  cut (enumerates Ξ (fun x => x ≈ veblen Γ x 0)).
  { apply enumerates_equiv_pred.
    apply Ξ_normal.
    intros. rewrite strongly_critical_fixpoint; auto.
    split; apply ord_eq_sym.
    apply Γ_normal. }

  apply enum_fixpoints_enumerates.
  - intros.
    apply (normal_inflationary (fun x => veblen Γ x 0)); auto.
    apply veblen_first_normal.
    apply Γ_normal.
  - intros; apply veblen_monotone_first; auto.
    apply normal_monotone.
    apply Γ_normal.
  - apply veblen_first_normal.
    apply Γ_normal.
Qed.


Inductive day : Type :=
| sun : day
| mon : day
| tue : day
| wed : day
| thu : day
| fri : day
| sat : day.

Definition prev_day d :=
  match d with
  | sun => sat
  | mon => sun
  | tue => mon
  | wed => tue
  | thu => wed
  | fri => thu
  | sat => fri
  end.

Theorem wed_after_tue : prev_day thu = wed.
Proof.
  auto.
Qed.

Theorem day_never_repeats : forall x : day, prev_day x <> x.
Proof.
  intros d. destruct d.
  all: discriminate.
Qed.

Theorem day_never_repeats2 : forall x : day, prev_day x <> x.
Proof.
  (* Intros introduces variable for a day. Destruct does a case by
     case analysis. Semicolon applies tactic on ALL subgoals generated
     by tactics before. *)
  intros d. destruct d; discriminate.
Qed.

Theorem wed_after_tues : forall x : day,
    prev_day x = tue -> x = wed.
Proof.
  intros d.
  intros H.
  (* intros H introduces the assumption that prev_day d = tue. *)
  destruct d.
  (* destruct d considers all possible values of d for the consequent d = wed. Each of these
     subgoals has the assumption H. The first subgoal would be: assuming prev_day sun = tue, sun = wed.
     Since H is false, the implication is true. For subgoals such as these, discriminate will prove it,
     for the only subgoal where H is true, trivial will solve that:*)
  all: discriminate || trivial.
Qed.


Inductive bool : Type :=
  | true
  | false.

Definition negb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b_1 : bool) (b_2 : bool) : bool :=
  match b_1 with
  | true => b_2
  | false => false
  end.

Definition orb (b_1 : bool) (b_2 : bool) : bool :=
  match b_1 with
  | true => true
  | false => b_2
  end.

Notation "~ x" := (negb x) (at level 75, right associativity).

Notation "x && y" := (andb x y) (at level 40, left associativity).

Notation "x || y" := (orb x y) (at level 50, left associativity).


(** * Project Summary

The original purpose of this project was to explore optimizations to
probabilistic programs. That is, fixing inputs, probablistic expressions can be
seen as encoding a particular distributions and we might like to
replace some expressions with easier to query representations of the same
distribution.

** Goals

- term language and semantics based on measurable functions
  - measure space
  - measure
  - measurable function
  - probability space
  - initialization terms
  - measure function terms
  - product space
  - push forward
- proof of commutative function composition under some restrictions
  - no progress

In what follows, any [Lemma] without an accompanying [Admitted] has a proof.
There are about 800 lines of proof code.

*)

Require Import List.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Powerset.
Require Import Utheory.

(** * Basic Definitions

** Measurable Space

First we define a space using [Coq.Sets.Ensembles]. The unfolded definition of
an enemble is a function of type [A -> Prop] and forms a "filter" on the carrier
type [A].

 *)
Definition Space (A : Set) := Ensemble A.

(**

Notably this definition of the space isn't really something we can compute with
so instead we a fairly standard approach of making a list of the elements of our
set and then building an Ensemble from that.

*)
(* https://stackoverflow.com/questions/22353508/how-to-create-ensemble-in-coq#22354969 *)
Fixpoint list_to_ensemble {A:Type} (l : list A) {struct l}: Ensemble A :=
  match l with
    | nil => Empty_set A
    | hd::tl => Add A (list_to_ensemble tl) hd
  end.

(**

This particular encoding of sets and measurable spaces turned out to be fairly
effort intensive to work with. The idea was that the lemmas and facilities in
[Coq.Sets.Powerset] which is built on Ensembles would make it easier to do
proofs regarding the sigma algebra for a measurable space (which we assume to be
a powerset of the space for simplicity's sake).

*)
Definition SigAlg (A : Set) := Ensemble (Ensemble A).

Arguments In [U].
Arguments Included [U].
Arguments Power_set [U].
Arguments Same_set [U].
Arguments Union [U].
Arguments Disjoint [U].

(**

Finally we encode a measurable set with a list (reads: subset) of elements of
type [A]. We further require, for technical reasons, that there are no
duplications in the list and that the list is not empty. Again we assume for
simplicity's sake that the sigma algebra of the measurable space is the powerset
of its space derived from [list_to_ensemble] applied to the argument list.

*)

Record MS {A : Set} (l : list A): Type :=
  mkMS {
    carrier := A;
    enum := l;
    uniq : NoDup l;
    not_empty : l <> nil;
    space := list_to_ensemble l;
    sigalg := Power_set space
  }.

Arguments mkMS [A l].
Arguments uniq [A l].
Arguments space [A l].
Arguments sigalg [A l].

(** ** Measurable Function

We encode a measurable function as a function between the carrier types [A] and
[B] of two measurable spaces [s1] and [s2]. Along with the function we require
the preimage constraint encoded as first order logic. Namely, for every set in
the sigma algebra of [s2] there exists a set in the sigma algebra in [s1] such
that the elements of the second set can be used with the function to generate
the elements of the first set.

Of interest here (we will explain more later) the computational content of
the proof object for the preimage constraint (a dependently typed function) can
be used to build a generic [push_forward] function.

*)

Record MF {A B: Set} {l1 l2} (s1 : @MS A l1) (s2 : @MS B l2) :=
  mkMF {
    mf_func : A -> B;
    msa := s1;
    msb := s2;
    preimage:
      forall E2,
        In (sigalg msb) E2
        -> sig (fun E1 =>
            (forall x, In E2 (mf_func x) <-> In E1 x) /\
            In (sigalg msa) E1)
    }.

(* Literals 0 and 1 need to be from U not nat *)
Open Local Scope U_scope.

(** ** Helper Lemmas

There are a lot of helper lemmas. Most of them are involved with converting
facts about lists without duplicates to facts about ensembles. This is the
downside of the encoding. There are also some basic set theoretic concepts
derived from the facts in the standard library for ensembles.

*** Sigma Algebra Facts

For example, [space_in_sigalg] is all normally a requirement of the definition of sigma
algebra but since we already know it's a powerset we can just do the proof and
use it so that we can more easily use the probability space definition.

*)
Lemma space_in_sigalg :
  forall { A : Set } {l : list A} ms, In (@sigalg A l ms) (space ms).
Proof.
  intros A l ms.
  apply Definition_of_Power_set.
  unfold Included.
  auto.
Qed.

Lemma elem_sigalg_subset_space :
  forall (A : Set) l ms E,
    In (@sigalg A l ms) E -> Included E (space ms).
Proof.
  intros A l ms E Hin.
  unfold sigalg in Hin.
  inversion Hin.
  assumption.
Qed.

Lemma subset_sigalg_in_space :
  forall (A : Set) l ms E,
    Included E (space ms) -> In (@sigalg A l ms) E.
Proof.
  intros A l ms E Hincl.
  apply Definition_of_Power_set; auto.
Qed.

Lemma union_in_sigalg :
  forall { A : Set } { l : list A } ms { E1 E2 : Ensemble A },
    In (@sigalg A l ms) E1
    -> In (sigalg ms) E2
    -> In (sigalg ms) (Union E1 E2).
Proof.
  intros A l ms E1 E2 Hin1 Hin2.
  apply Definition_of_Power_set.
  apply Union_minimal; apply elem_sigalg_subset_space; auto.
Qed.

Lemma empty_in_sigalg :
  forall A l ms, In (@sigalg A l ms) (Empty_set A).
Proof.
  intros.
  apply Definition_of_Power_set.
  unfold Included.
  intros.
  unfold In in H.
  contradiction.
Qed.

Lemma empty_bot : forall C x, In (Empty_set C) x -> False.
Proof.
  intros.
  unfold In in H.
  contradiction.
Qed.

Lemma union_empty :
  forall A E, Same_set (Union (Empty_set A) E) E.
Proof.
  unfold Same_set.
  intros.
  unfold Included.
  split.
  unfold In.
  intros.
  inversion H.
  apply empty_bot in H0.
  exfalso.
  auto.
  assumption.
  unfold In.
  intros.
  apply Union_intror.
  assumption.
Qed.

Lemma union_add_left_commute :
  forall A E1 E2 a, Same_set (Union (Add A E1 a) E2) (Add A (Union E1 E2) a).
Proof.
  intros.
  unfold Same_set.
  unfold Included.
  unfold In.
  split.
  - intros.
    unfold Add.
    unfold Add in H.
    inversion H.
    unfold In in H0.
    inversion H0.
    apply Union_introl.
    unfold In.
    apply Union_introl.
    assumption.
    apply Union_intror.
    assumption.
    apply Union_introl.
    apply Union_intror.
    assumption.
  - intros.
    unfold Add.
    unfold Add in H.
    inversion H.
    unfold In in H0.
    inversion H0.
    apply Union_introl.
    unfold In.
    apply Union_introl.
    assumption.
    apply Union_intror.
    assumption.
    apply Union_introl.
    apply Union_intror.
    assumption.
Qed.

Lemma subset_empty : forall A E, Included (Empty_set A) E.
Proof.
  intros.
  unfold Included.
  intros.
  apply empty_bot in H.
  exfalso.
  auto.
Qed.

(** *** Basic [list_to_ensemble] Facts

The following lemmas provide useful facts about the ensembles generated from
lists and how they releated to the sigma algebras.

For example, [tail_in_sigalg] says that if a an ensemble generated from a list
with [a] as its head and [l1] as its tail is in the sigma algebra for some
measurable space [ms] then the ensembel generated from the tail [l1] is too.

*)

Lemma tail_in_sigalg :
  forall { A : Set } { l l1 : list A } ms a,
    In (@sigalg A l ms) (list_to_ensemble (a::l1))
    -> In (sigalg ms) (list_to_ensemble l1).
Proof.
  unfold sigalg.
  intros.
  simpl in H.
  inversion H.
  apply Definition_of_Power_set.
  Check Inclusion_is_transitive.
  apply (Inclusion_is_transitive A (list_to_ensemble l1) (Add A (list_to_ensemble l1) a)); auto.
  unfold Add.
  unfold Included.
  intros.
  apply Union_introl; auto.
Qed.

(**

[concat_in_sigalg] says that if two ensembles generated by the lists [l1] and
[l1] are in the sigma algebra from some measurable space [ms] then the ensemble
generated by their concatenation is too. Note that this is true in spite of
possible duplicated elements because the conversion to an ensemble is the
conversion to set-like behavior where duplicates are ingored.

*)

Lemma concat_in_sigalg :
  forall { A : Set } { l : list A } ms { l1 l2 : list A },
    In (@sigalg A l ms) (list_to_ensemble l1)
    -> In (sigalg ms) (list_to_ensemble l2)
    -> In (sigalg ms) (list_to_ensemble (l1 ++ l2)).
Proof.
  intros A l ms l1 l2 Hin1 Hin2.
  assert ((list_to_ensemble (l1 ++ l2)) = (Union (list_to_ensemble l1) (list_to_ensemble l2))).

  induction l1.
  simpl.

  assert (Same_set (Union (Empty_set A) (list_to_ensemble l2)) (list_to_ensemble l2)).
  apply union_empty.
  apply Extensionality_Ensembles in H.
  rewrite -> H.
  reflexivity.

  simpl.
  assert (Same_set
            (Union (Add A (list_to_ensemble l1) a) (list_to_ensemble l2))
            (Add A (Union (list_to_ensemble l1) (list_to_ensemble l2)) a)).
  apply union_add_left_commute.
  apply Extensionality_Ensembles in H.
  rewrite -> H.

  assert (In (sigalg ms) (list_to_ensemble l1)).
  apply (tail_in_sigalg ms a); auto.
  apply IHl1 in H0.
  rewrite -> H0.
  auto.

  rewrite -> H.
  apply union_in_sigalg; auto.
Qed.

(** ** Probability Measure

We encode a probability measure as a dependent function that takes a list [l']
and a proof that it belongs to the sigma algebra of the measureable space [ms]
and produces a value on the unit interval [U] which we have borrowed from the
ALEA library (1). We also require proofs that the function returns 0 for the
empty list, 1 for the space of the measurable space, and that the function it
satisfies the additive union property. Note that this is not the full countable
additive union property expected of a measure but it seems one should be able to
derive that property from this one using an induction argument.

*)

Record Measure {A : Set} { l : list A } (ms : MS l) :=
  mkMeasure {
    m_func : forall { l' }, In (sigalg ms) (list_to_ensemble l') -> U;
    empty: @m_func nil == 0;
    full: m_func (space_in_sigalg ms) == 1;
    (* TODO the following is only supposed to be true in the case of disjoint l1 l2 *)
    addcount:
      forall l1 l2 pl1 pl2,
        @m_func l1 pl1 + @m_func l2 pl2 == m_func (concat_in_sigalg ms pl1 pl2)
  }.

(** ** Probability Space

Finally we can define a probability space as the combination of a measurable
space and a (probability) measure for that space.

 *)
Record PS { A : Set } (l : list A) :=
  mkPS {
    ms : MS l;
    mu : Measure ms
  }.

Arguments mkPS [A l].
Arguments ms [A l].
Arguments mu [A l].

(**

** Product Space Lemmas

The following is a large sequence of lemmas used in making progress on the proof
that one can construct a probability space as the produce of two existing
probability spaces.

For example [nodup_disj_dis]
*)

Lemma nodup_disj_dist :
  forall A l1 l2 d1,
    (forall a:A, List.In a l1 -> ~ List.In a l2)
    -> nodup d1 (l1 ++ l2) = nodup d1 l1 ++ nodup d1 l2.
Proof.
  intros.
  induction l1.
  simpl.
  reflexivity.

  simpl.

  case (in_dec d1 a l1).
  intros.
  assert (List.In a (l1 ++ l2)).
  apply in_or_app. left. auto.
  simpl.
  Check (in_dec d1 a (l1 ++ l2)).
  case (in_dec d1 a (l1 ++ l2)).
  intros.
  apply IHl1.
  intros.
  apply H.
  apply in_cons. auto.
  intros.
  contradiction.
  intros.
  case (in_dec d1 a (l1 ++ l2)).
  Focus 2.
  intros.
  assert ((a :: nodup d1 l1) ++ nodup d1 l2 =  (a :: (nodup d1 l1 ++ nodup d1 l2))).
  apply app_comm_cons; assumption.
  rewrite -> H0.
  assert (nodup d1 (l1 ++ l2) = nodup d1 l1 ++ nodup d1 l2).
  apply IHl1.
  intros.
  apply H.
  apply in_cons. auto.
  rewrite -> H1.
  reflexivity.
  intros.

  apply in_app_or in i.
  case i.
  intros. contradiction.
  intros.
  assert (~List.In a l2).
  apply H.
  apply in_eq.
  contradiction.
Qed.

Lemma in_map_fst_singleton_eq :
  forall A B a1 a2 (l : list B),
    List.In (a1 : A) (map fst (map (fun y : B => (a2, y)) l))
    -> a1 = a2.
Proof.
  intros.
  induction l.
  simpl in H. contradiction.
  simpl in H.
  case H; auto.
Qed.

Lemma not_in_not_in_fst_prod:
  forall A B (l1 : list A) (l2 : list B) a,
    ~ List.In a l1 ->
    ~ List.In a (map fst (list_prod l1 l2)).
Proof.
  intros.
  induction l1.
  simpl. auto.
  simpl.

  assert (map fst (map (fun y : B => (a0, y)) l2 ++ list_prod l1 l2) =
          map fst (map (fun y : B => (a0, y)) l2) ++ (map fst (list_prod l1 l2))).
  apply map_app.
  rewrite -> H0.
  unfold not.
  intros.

  apply in_app_or in H1.
  apply not_in_cons in H.
  case H1.
  intros.
  assert (a = a0).
  destruct H; auto.
  apply (in_map_fst_singleton_eq A B a a0 l2); assumption.
  destruct H; auto.
  intro.
  destruct H.
  apply IHl1 in H3.
  contradiction.
Qed.

Lemma map_fst_in_list_not_empty :
  forall A B (a : A) l, List.In a (map fst (map (fun y : B => (a, y)) l)) -> l <> nil.
Proof.
  intros.
  induction l.
  contradiction.
  discriminate.
Qed.

Lemma map_fst_no_in_list_empty :
  forall A B (a : A) l, (~ List.In a (map fst (map (fun y : B => (a, y)) l))) -> l = nil.
Proof.
  intros.
  induction l.
  reflexivity.
  simpl in H.
  unfold not in H.
  exfalso.
  apply H.
  left.
  auto.
Qed.

Lemma nodup_singleton_prod_singleton :
  forall A B (a : A) (l : list B) d,
    l <> nil
    -> nodup d (map fst (map (fun y : B => (a, y)) l)) = a::nil.
Proof.
  intros.
  induction l.
  contradiction.
  simpl.
  case (in_dec d a (map fst (map (fun y : B => (a, y)) l))).
  intros.

  assert (List.In a (map fst (map (fun y : B => (a, y)) l)) -> l <> nil).
  apply map_fst_in_list_not_empty.
  apply H0 in i.
  apply IHl in i.
  assumption.

  intros.

  assert (~List.In a (map fst (map (fun y : B => (a, y)) l)) -> l = nil).
  apply map_fst_no_in_list_empty.
  apply H0 in n.
  rewrite -> n.
  simpl.
  reflexivity.
Qed.

Lemma map_fst_inverse_list_prod :
  forall A B (l1:list A) (l2:list B) d,
    l2 <> nil
    -> NoDup l1
    -> nodup d (map fst (list_prod l1 l2)) = l1.
  intros A B l1 l2 Hdecide Hl2notempty Hnodup.
  induction l1; auto.

  simpl.
  assert ((map fst (map (fun y : B => (a, y)) l2 ++ list_prod l1 l2)) =
          (map fst (map (fun y : B => (a, y)) l2)) ++ (map fst (list_prod l1 l2))) as Hmapdist.
  apply map_app.
  rewrite -> Hmapdist.

  assert (nodup Hdecide (map fst (map (fun y : B => (a, y)) l2) ++ map fst (list_prod l1 l2)) =
          nodup Hdecide (map fst (map (fun y : B => (a, y)) l2)) ++ nodup Hdecide (map fst (list_prod l1 l2))).

  apply nodup_disj_dist.
  intros.

  assert (a0 = a).
  apply (in_map_fst_singleton_eq A B a0 a l2); assumption.

  rewrite -> H0 in H.
  inversion Hnodup.
  rewrite -> H0.

  assert (forall A B (l1 : list A) (l2 : list B) a, ~ List.In a l1 ->  ~ List.In a (map fst (list_prod l1 l2))).
  apply not_in_not_in_fst_prod.

  apply H5. assumption.
  rewrite -> H.

  assert (nodup Hdecide (map fst (map (fun y : B => (a, y)) l2)) = a::nil) as Hfactor.
  apply nodup_singleton_prod_singleton.
  assumption.

  rewrite -> Hfactor.

  assert (NoDup l1).

  assert (NoDup (a::l1) -> ~ List.In a l1 /\ NoDup l1).
  apply NoDup_cons_iff.
  apply H0 in Hnodup.
  destruct Hnodup. auto.

  apply IHl1 in H0.
  rewrite -> H0.
  auto.
Qed.

Lemma map_snd_inverse_list_prod :
  forall A B (l1:list A) (l2:list B) d,
    NoDup l2
    -> nodup d (map snd (list_prod l1 l2)) = l2.
  intros A B l1 l2 Hnodup Hdecide.
  Admitted.

Lemma empty_pair_fst_empty_nodup :
  forall A B (l : list A) d, nodup d (map fst (list_prod l (nil : list B))) = nil.
Proof.
  intros.
  induction l.
  simpl.
  auto.

  simpl.
  rewrite -> IHl.
  auto.
Qed.

Lemma prod_fst_in_space :
  forall A B l1 (l2 : list B) (ps : @PS A l1) da,
    NoDup l1
    -> In (sigalg (ms ps)) (list_to_ensemble (nodup da (map fst (list_prod l1 l2)))).
Proof.
  intros A B l1 l2 ps Hdecide Hnodupl1.
  induction l2.
  assert ((nodup Hdecide (map fst (list_prod l1 (nil : list B)))) = nil).
  apply empty_pair_fst_empty_nodup.
  rewrite -> H.
  simpl.
  apply empty_in_sigalg.

  assert (nodup Hdecide (map fst (list_prod l1 (a::l2))) = l1).
  apply (map_fst_inverse_list_prod).
  discriminate.
  assumption.
  rewrite -> H.
  apply space_in_sigalg.
Qed.

Lemma prod_fst_same_space :
  forall (A : Set) B (l1 : list A) (l2 : list B) (ms : MS l1) da,
    NoDup l1
    -> l2 <> nil
    -> Same_set (list_to_ensemble (nodup da (map fst (list_prod l1 l2)))) (space ms).
Proof.
  intros A B l1 l2 ps Hdecide Hnodupl1 Hnotempty.
  assert (nodup Hdecide (map fst (list_prod l1 l2)) = l1).
  apply (map_fst_inverse_list_prod). intro. contradiction. assumption.
  rewrite -> H.
  unfold space.
  unfold Same_set.
  unfold Included.
  auto.
Qed.

Lemma prod_snd_in_space :
  forall A B (l1 : list A) l2 (ps : @PS B l2) db,
    NoDup l2
    -> In (sigalg (ms ps)) (list_to_ensemble (nodup db (map snd (list_prod l1 l2)))).
Proof.
  intros A B l1 l2 ps Hdecide Hnodupl1.
  assert (nodup Hdecide (map snd (list_prod l1 l2)) = l2).
  apply (map_snd_inverse_list_prod). assumption.
  rewrite -> H.
  apply space_in_sigalg.
Qed.

Lemma prod_snd_same_space :
  forall A (B : Set) (l1 : list A) (l2 : list B) (ms : MS l2) db,
    NoDup l2
    -> Same_set (list_to_ensemble (nodup db (map snd (list_prod l1 l2)))) (space ms) .
Proof.
  intros A B l1 l2 ps Hdecide Hnodupl1.
  assert (nodup Hdecide (map snd (list_prod l1 l2)) = l2).
  apply (map_snd_inverse_list_prod). assumption.
  rewrite -> H.
  unfold space.
  unfold Same_set.
  unfold Included.
  auto.
Qed.

Lemma prod_subset_fst_subset :
      forall { A B : Set} l la lb msab da,
        In (@sigalg (prod A B) (list_prod la lb) msab) (list_to_ensemble l)
        -> Included (list_to_ensemble (nodup da (map fst l)))
                   (list_to_ensemble (nodup da (map fst (list_prod la lb)))).
Proof.
  intros A B l la lb msab da Hinspace.
  induction l.
  simpl.
  apply subset_empty.
Admitted.

Lemma prod_subset_snd_subset :
      forall { A B : Set} l la lb msab db,
        In (@sigalg (prod A B) (list_prod la lb) msab) (list_to_ensemble l)
        -> Included (list_to_ensemble (nodup db (map snd l)))
                   (list_to_ensemble (nodup db (map snd (list_prod la lb)))).
Proof.
  intros A B l la lb msab db Hinspace.
  induction l.
  simpl.
  apply subset_empty.
Admitted.

Lemma in_prod_fst_in_space :
  forall { A B : Set} l la lb msab msa da,
    lb <> nil
    -> In (@sigalg (prod A B) (list_prod la lb) msab) (list_to_ensemble l)
    ->  In (@sigalg A la msa) (list_to_ensemble (nodup da (map fst l))).
Proof.
  intros A B l la lb msab msa Hda Hlbnotempty Hinab.
  apply elem_sigalg_subset_space in Hinab.
  unfold space in Hinab.
  assert (Same_set (list_to_ensemble (nodup Hda (map fst (list_prod la lb)))) (space msa)).
  apply (prod_fst_same_space A B la lb msa).
  exact (uniq msa).
  assumption.
  apply Extensionality_Ensembles in H.

  assert (Included (list_to_ensemble (nodup Hda (map fst l))) (list_to_ensemble (nodup Hda (map fst (list_prod la lb))))).
  apply (prod_subset_fst_subset l la lb msab Hda).
  apply subset_sigalg_in_space.
  assumption.

  assert (Included (list_to_ensemble (nodup Hda (map fst l))) (list_to_ensemble la)).
  apply (elem_sigalg_subset_space A la msa).
  rewrite -> H in H0.
  apply Definition_of_Power_set.
  assumption.
  rewrite -> H in H0.
  apply Definition_of_Power_set.
  assumption.
Qed.

Lemma in_prod_snd_in_space :
  forall { A B : Set} l la lb msab msb db,
    la <> nil
    -> In (@sigalg (prod A B) (list_prod la lb) msab) (list_to_ensemble l)
    ->  In (@sigalg B lb msb) (list_to_ensemble (nodup db (map snd l))).
Proof.
  intros A B l la lb msab msb Hdb Hlbnotempty Hinab.
  apply elem_sigalg_subset_space in Hinab.
  unfold space in Hinab.
  assert (Same_set (list_to_ensemble (nodup Hdb (map snd (list_prod la lb)))) (space msb)).
  apply (prod_snd_same_space A B la lb msb).
  exact (uniq msb).

  apply Extensionality_Ensembles in H.

  assert (Included (list_to_ensemble (nodup Hdb (map snd l))) (list_to_ensemble (nodup Hdb (map snd (list_prod la lb))))).
  apply (prod_subset_snd_subset l la lb msab Hdb).
  apply subset_sigalg_in_space.
  assumption.

  assert (Included (list_to_ensemble (nodup Hdb (map snd l))) (list_to_ensemble lb)).
  apply (elem_sigalg_subset_space B lb msb).
  rewrite -> H in H0.
  apply Definition_of_Power_set.
  assumption.
  rewrite -> H in H0.
  apply Definition_of_Power_set.
  assumption.
Qed.

Definition dec (A : Set) := forall x y : A, {x = y} + {x <> y}.

Lemma dec_prod:
  forall A B,
    dec A
    -> dec B
    -> dec (prod A B).
Proof.
  unfold dec.
  intros A B Hdeca Hdecb.
  intros x y.
  assert ({(fst x) = (fst y)} + {(fst x) <> (fst y)}) as Hdecas.
  apply (Hdeca (fst x) (fst y)).
  assert ({(snd x) = (snd y)} + {(snd x) <> (snd y)}) as Hdecbs.
  apply (Hdecb (snd x) (snd y)).

  case Hdecas.
  case Hdecbs.
  intros.
  left.
  apply injective_projections; auto.

  intros.
  right.
  unfold not.
  intros.
  assert (x = (fst x, snd x)). apply surjective_pairing.
  assert (y = (fst y, snd y)). apply surjective_pairing.
  rewrite -> H0 in H.
  rewrite -> H1 in H.
  inversion H.
  contradiction.

  case Hdecbs.
  intros.
  intros.
  right.
  unfold not.
  intros.
  assert (x = (fst x, snd x)). apply surjective_pairing.
  assert (y = (fst y, snd y)). apply surjective_pairing.
  rewrite -> H0 in H.
  rewrite -> H1 in H.
  inversion H.
  contradiction.

  intros.
  intros.
  intros.
  right.
  unfold not.
  intros.
  assert (x = (fst x, snd x)). apply surjective_pairing.
  assert (y = (fst y, snd y)). apply surjective_pairing.
  rewrite -> H0 in H.
  rewrite -> H1 in H.
  inversion H.
  contradiction.
Qed.

Lemma nodup_prod :
  forall A B (l1 : list A) (l2 : list B),
    NoDup l1
    -> NoDup l2
    -> NoDup (list_prod l1 l2).
Proof.
  intros A B l1 l2 Hnodup1 Hnodup2.
  induction l1; simpl.
  constructor.
Admitted.

Lemma not_empty_prod :
  forall A B (l1 : list A) (l2 : list B),
    l1 <> nil
    -> l2 <> nil
    -> (list_prod l1 l2) <> nil.
Proof.
  intros A B l1 l2 Hnoemp1 Hnoemp2.
  induction l1; simpl.
Admitted.

Definition prod_space {A B : Set} {l1 l2} (da : dec A) (db : dec B) (psa : @PS A l1) (psb : @PS B l2) : @PS (prod A B) (list_prod l1 l2).
  refine (
      let decprod := (dec_prod A B da db) in
      let l := (list_prod l1 l2) in
      let msab := (@mkMS (prod A B) l _ _) in
      let mua := @m_func A l1 (ms psa) (mu psa) in
      let mub := @m_func B l2 (ms psb) (mu psb) in
      let measure :=
          fun l' inab =>
            let fstlist := nodup da (map fst l') in
            let sndlist := nodup db (map snd l') in
            let las : In (sigalg (ms psa)) (list_to_ensemble fstlist) :=
                _
                (* prod_fst_in_space A B l1 l2 psa da (uniq (ms psa)) *)
            in
            let lbs : In (sigalg (ms psb)) (list_to_ensemble sndlist) :=
                _
                (* prod_snd_in_space A B l1 l2 psb db (uniq (ms psb)) *)
            in
            (mua fstlist las) * (mub sndlist lbs)
      in
      mkPS msab (mkMeasure (prod A B) l msab measure _ _ _)
    ).
  Unshelve.
  Focus 4.
  apply nodup_prod.
  exact (uniq (ms psa)).
  exact (uniq (ms psb)).
  Focus 4.
  apply not_empty_prod.
  Check not_empty.
  exact (not_empty l1 (ms psa)).
  exact (not_empty l2 (ms psb)).

  Focus 4.
  apply (in_prod_fst_in_space l' l1 l2 msab (ms psa) da).
  exact (not_empty l2 (ms psb)).
  assumption.

  Focus 4.
  apply (in_prod_snd_in_space l' l1 l2 msab (ms psb) db).
  exact (not_empty l1 (ms psa)).
  assumption.

  simpl.

  unfold measure.
  simpl.
  unfold mua.
  simpl.

  Admitted.

(** push forward, f : (E -> [0,1]) -> (E' -> [0,1]) *)
Definition push_forward {A B} {l1 l2} (psa : @PS A l1) (msb : @MS B l2) (mf : MF (ms psa) msb) : @PS B l2.
  refine (mkPS msb _).
  refine (_ (mu psa)).
  intros HmuA.

  assert (
      (forall E1,
        In (sigalg msb) E1
        -> sig (fun E2 =>
                 (forall x, In E1 ((mf_func (ms psa) msb mf) x) <-> In E2 x) /\
                 In (sigalg (ms psa)) E2))
      ->

      (forall E1,
        In (sigalg msb) E1
        -> sig (fun E2 => In (sigalg (ms psa)) E2 /\
                      (Same_set E1 (Empty_set B) -> Same_set E2 (Empty_set A)) /\
                      (Same_set E1 (space msb) -> Same_set E2 (space (ms psa)))))

    ) as convertpreimg.

  intros Hpreimg E1 Hinb.
  apply (Hpreimg E1) in Hinb.
  elim Hinb.
  intros E2 Hprefacts.
  destruct Hprefacts as [Hsame Hsiga].
  exists E2.
  split.
  assumption.
  split.
  intro Hempte1.
  apply Extensionality_Ensembles in Hempte1.
  rewrite -> Hempte1 in Hsame.

  unfold Same_set.
  unfold Included.

  split.

  Focus 2.

  intros.
  exfalso.
  apply (empty_bot A) in H; assumption.

  intros.
  destruct (Hsame x).
  apply H1 in H.
  exfalso.
  apply (empty_bot B (mf_func (ms psa) msb mf x)) in H.
  assumption.

  admit.

  assert (
      forall E1,
        In (sigalg msb) E1
        -> sig (fun E2 => In (sigalg (ms psa)) E2 /\
                       (Same_set E1 (Empty_set B) -> Same_set E2 (Empty_set A)) /\
                       (Same_set E1 (space msb) -> Same_set E2 (space (ms psa))))
    ).

  intros.
  apply ((convertpreimg (preimage (ms psa) msb mf) E1)). auto.
  Admitted.
  (* assert (forall E, In (Ensemble B) (sigalg B msb) E -> In (Ensemble B) (sigalg B msb) E) as bfunc. *)

  (* assert (forall E, In (Ensemble B) (sigalg B msb) E -> U) as bfunc. *)
  (* intros E Heinsig. *)
  (* assert (sig (fun E1 => *)
  (*                (forall x, In B E ((mf_func (ms A psa) msb mf) x) <-> In A E1 x) /\ *)
  (*                In (Ensemble A) (sigalg A (ms A psa)) E1)) as Hpre. *)
  (* apply ((preimage (ms A psa) msb mf) E). auto. *)
  (* destruct Hpre as [E1 Hfacts]. *)
  (* apply ((@m_func A (ms A psa) HmuA) E1). *)
  (* destruct Hfacts. *)
  (* assumption. *)

  (* refine (mkMeasure B msb bfunc _ _ _). *)
(* Defined. *)

(**
    - syntax
    - denotational semantics
      - init statements -> cartesian space
      - composed measurable functions -> single measurable function
      - notation/sugar
    - theorem
      - if <assumptions> then compose f g = compose g f
        - iterate on assumptions
        -
 *)

Inductive init_term : Type :=
(** x <- flip U *)
| init_flip : nat -> U -> init_term
(** x <- unif n1 n2 *)
| init_unif : nat -> nat -> nat -> init_term.

Require Import Coq.Bool.Bool.
Require Import Uprop.

Definition bool_space := false::true::nil.

Fixpoint bool_measure_func (u : U) (l : list bool) : U :=
  match l with
  | nil => 0
  | false::l' => [1-]u + bool_measure_func u l'
  | true::l' => u + bool_measure_func u l'
  end.

Definition bool_ms : MS bool_space.
  refine (mkMS (NoDup_nodup bool_dec (nodup bool_dec bool_space)) _).
  unfold bool_space.
  simpl.
  discriminate.
Qed.

(** TODO the content of this proof is suspect since it doesn't rely on the disjointness
    of the lists
*)
Definition bool_measure (u : U) : Measure bool_ms.
  intros.
  refine (
      let measure := fun list Plistinspace => bool_measure_func u list in
      mkMeasure bool bool_space bool_ms measure _ _ _
    ).
  unfold measure.
  unfold bool_measure_func.
  auto.
  unfold bool_space.
  unfold measure.
  simpl.
  Usimpl.
  apply Uinv_opp_left.
  intros.
  induction l1.
  unfold measure.
  unfold bool_measure_func.
  simpl.
  Usimpl.
  reflexivity.
  simpl.
  unfold measure.
  case a.
  - simpl.
    unfold measure in IHl1.
    assert ((u + (bool_measure_func u l1 + bool_measure_func u l2)) == (u + bool_measure_func u l1 + bool_measure_func u l2)).
    apply Uplus_assoc.
    rewrite <- H.
    apply Uplus_eq_compat_right.
    assert (In (sigalg bool_ms) (list_to_ensemble l1)).
    apply (tail_in_sigalg bool_ms a); assumption.
    apply (IHl1 H0).
  - simpl.
    unfold measure in IHl1.
    assert (([1-]u + (bool_measure_func u l1 + bool_measure_func u l2)) == ([1-]u + bool_measure_func u l1 + bool_measure_func u l2)).
    apply Uplus_assoc.
    rewrite <- H.
    apply Uplus_eq_compat_right.
    assert (In (sigalg bool_ms) (list_to_ensemble l1)).
    apply (tail_in_sigalg bool_ms a); assumption.
    apply (IHl1 H0).
Qed.

Definition bool_ps (u : U) :=
  mkPS bool_ms (bool_measure u).

Inductive term : Type :=
| term_and : nat -> nat -> nat -> term.

Record prog :=
  mkProg {
    init : list init_term;
    statements : list term
    }.

Require Import FSets.FMapList.
Require Import Structures.OrderedTypeEx.
Require Import OrderedType.
Require Import Decidable.

Module Import VarMap := FMapList.Make Nat_as_OT.

Definition spaces := VarMap.t (@PS bool bool_space).

Notation "k |-> v" := (pair k v) (at level 60).

Definition update_space (p: nat * (@PS bool bool_space)) (m: spaces) :=
  VarMap.add (fst p) (snd p) m.
Notation "[ ]init" := (VarMap.empty (@PS bool bool_space)).
Notation "[ p1 , .. , pn ]init" :=
  (update_space p1 .. (update_space pn (VarMap.empty (@PS bool bool_space))) .. ).

Fixpoint init_prog ( l : list init_term ) : spaces :=
  match l with
  | nil => []init
  | (init_flip n u) :: ini => update_space (n, bool_ps u) (init_prog ini)
  (* TODO handle uniform distr *)
  | _ => []init
  end.

Definition compose_mf (p : prog) (s : spaces) : spaces.
  refine (
      match (statements p) with
      | term_and nvar n1 n2 :: nil =>
        let optspacen1 := VarMap.find n1 s in
        let optspacen2 := VarMap.find n2 s in
        match (optspacen1, optspacen2) with
        | (Some spacen1, Some spacen2) =>
          if eq_nat_dec n1 n2 then
            update_space (nvar, spacen1) s
          else
            let truen1 := (m_func (ms spacen1) (mu spacen1)) _ in
            let truen2 := (m_func (ms spacen2) (mu spacen2)) _ in
            let newspace := bool_ps (truen1 * truen2) in
            update_space (nvar, newspace) s
        | _ => s
        end
      | _ => s
      end
    ).
  Unshelve.
  Focus 2.
  exact (true::nil).
  Focus 3.
  exact (true::nil).
  apply (tail_in_sigalg bool_ms false).
  unfold space.
  assert (list_to_ensemble (nodup bool_dec bool_space) = list_to_ensemble (false::true::nil)).
  simpl. auto.
  rewrite <- H.
  apply space_in_sigalg.
  apply (tail_in_sigalg bool_ms false).
  unfold space.
  assert (list_to_ensemble (nodup bool_dec bool_space) = list_to_ensemble (false::true::nil)).
  simpl. auto.
  rewrite <- H.
  apply space_in_sigalg.
Qed.

Definition eval (p : prog) : spaces := compose_mf p (init_prog (init p)).

(**

1. https://www.lri.fr/~paulin/ALEA/

*)


Require Import Lia.

Definition least p n k := n <= k /\ p k /\ forall i, n <= i -> p i -> k <= i.

Section WO.

  Variable f: nat -> bool.

  (* Guardedness predicate *)
  Inductive G (n: nat) : Prop :=
  | GI : (f n = false -> G (S n)) -> G n.

  Lemma G_sig n :
    G n -> { k | least (fun k => f k = true) n k }.
  Proof.
    induction 1 as [n _ IH].
    destruct (f n) eqn:H.
    - exists n. repeat split; eauto.
    - destruct (IH eq_refl) as (k & Hle & Hk & Hleast).
      exists k. repeat split.
      + lia.
      + exact Hk.
      + intros i Hi. inversion Hi.
        * congruence.
        * eapply Hleast; eauto. lia.
  Defined.

  Lemma G_zero n :
    G n -> G 0.
  Proof.
    induction n as [|n IH].
    - intros H. exact H.
    - intros H. apply IH. constructor. intros _. exact H.
  Defined.

  Theorem mu_nat :
    (exists n, f n = true) -> { n | least (fun n => f n = true) 0 n }.
  Proof.
    intros H. apply (G_sig 0).
    destruct H as [n H].
    apply (G_zero n).
    constructor. rewrite H. discriminate.
  Defined.

End WO.

Definition mu_nat_dep : forall P : nat -> Prop,
(forall n : nat, {P n} + {~ P n}) -> (exists n : nat, P n) -> {n : nat | P n}.
Proof.
  intros P d Hn.
  edestruct (mu_nat (fun n => if d n then true else false)) as [n H].
  - abstract (destruct Hn as [n H]; exists n; destruct d; firstorder).
  - exists n. abstract (destruct H as (_ & H & _),  (d n); congruence).
Defined.

Definition mu_nat_dep_least : forall P : nat -> Prop,
(forall n : nat, {P n} + {~ P n}) -> (exists n : nat, P n) -> {n : nat | least P 0 n}.
Proof.
  intros P d Hn.
  edestruct (mu_nat (fun n => if d n then true else false)) as [n H].
  - abstract (destruct Hn as [n H]; exists n; destruct d; firstorder).
  - exists n. destruct H as (? & ? & H1),  (d n); try congruence.
    firstorder try congruence. eapply H1. 2: destruct (d); firstorder. lia.
Defined.

Lemma mu_nat_dep_min P d H : forall m, m < proj1_sig (@mu_nat_dep P d H) -> ~ P m.
Proof.
  intros. unfold mu_nat_dep in *. destruct mu_nat as [n (H1 & H2 & H3)].
  cbn in H0. intros Hm.
  specialize (H3 m ltac:(lia)). destruct (d m); firstorder lia.
Qed.

Lemma mu_nat_dep_irrel P d H1 H2 :
  proj1_sig (mu_nat_dep P d H1) = proj1_sig (mu_nat_dep P d H2).
Proof.
  match goal with [ |- ?L = ?R ] =>
    (assert (L < R \/ L = R \/ L > R) as [H | [H | H]] by lia)
  end.
  - eapply mu_nat_dep_min in H. repeat destruct mu_nat_dep; cbn in *; tauto.
  - eauto.
  - eapply mu_nat_dep_min in H. repeat destruct mu_nat_dep; cbn in *; tauto.
Qed.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__betweennotequal.
Require Export logic.
Definition lemma__lessthannotequal : forall A B C D, (euclidean__defs.Lt A B C D) -> ((euclidean__axioms.neq A B) /\ (euclidean__axioms.neq C D)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (exists E, (euclidean__axioms.BetS C E D) /\ (euclidean__axioms.Cong C E A B)) as H0 by exact H.
destruct H0 as [E H1].
destruct H1 as [H2 H3].
assert (* Cut *) (euclidean__axioms.neq C E) as H4.
- assert (* Cut *) ((euclidean__axioms.neq E D) /\ ((euclidean__axioms.neq C E) /\ (euclidean__axioms.neq C D))) as H4.
-- apply (@lemma__betweennotequal.lemma__betweennotequal C E D H2).
-- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
exact H7.
- assert (* Cut *) (euclidean__axioms.neq A B) as H5.
-- apply (@euclidean__axioms.axiom__nocollapse C E A B H4 H3).
-- assert (* Cut *) (euclidean__axioms.neq C D) as H6.
--- assert (* Cut *) ((euclidean__axioms.neq E D) /\ ((euclidean__axioms.neq C E) /\ (euclidean__axioms.neq C D))) as H6.
---- apply (@lemma__betweennotequal.lemma__betweennotequal C E D H2).
---- destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
exact H10.
--- split.
---- exact H5.
---- exact H6.
Qed.


From mathcomp.ssreflect Require Import ssreflect ssrbool eqtype.
From Coq.Strings Require Import Ascii String.

Scheme Equality for string.
Lemma ascii_beq_refl a: ascii_beq a a = true.
Proof. by case a; case; case; case; case; case; case; case; case; vm_compute. Qed.

Theorem ascii_eqP: Equality.axiom ascii_beq.
Proof.
  rewrite /Equality.axiom.
  move=> x y.
  case  (ascii_beq x y) eqn: H;  constructor.
  move: x y H.
  case; move=> q w e r t y u i.
  case; move=> q' w' e' r' t' y' u' i'.
  move: q q' w w' e e' r r' t t' y y' u u' i i'.
  do 8! [case; case => //= ].
  rewrite /not.
  move=> Heq. move: Heq H => ->. by rewrite ascii_beq_refl.
Qed.

Canonical ascii_eqMixin := EqMixin ascii_eqP.
Canonical ascii_eqType := EqType ascii ascii_eqMixin.

Lemma string_beq_refl x: string_beq x x = true.
Proof.
  elim x =>//. move=> a s H /=. by rewrite ascii_beq_refl.
Qed.

Lemma string_eqP: Equality.axiom string_beq.
Proof.
  rewrite /Equality.axiom.
  elim; first by case; constructor.
  move=> a s H []; first by constructor.
  move=> b t.
  simpl.
  case (ascii_beq a b) eqn: Heq; move /eqP in Heq.
  rewrite Heq.
  case (H t).
  -  by move=> ->; constructor.
  -  by move=> *; constructor; case.
  constructor. by case.
Qed.

Canonical string_eqMixin := EqMixin string_eqP.
Canonical string_eqType := EqType string string_eqMixin.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * boolean: Booleans as a lattice, and as a monoid *)

Require Import monoid prop sups.

(** * Booleans as a lattice *)

Canonical Structure bool_lattice_ops: lattice.ops := {|
  leq := le_bool;
  weq := eq;
  cup := orb;
  cap := andb;
  neg := negb;
  bot := false;
  top := true
|}.

(** [is_true] is a bounded distributive lattice homomorphism from [bool] to [Prop].
   (Actually a Boolean lattice homomorphism, but we don't need it here.) *)
Instance mm_bool_Prop: morphism BDL is_true.
Proof.
  constructor; simpl.
  apply le_bool_spec.
  intros ? ?. now rewrite eq_bool_iff.
  intros _ [|] [|]; firstorder.
  intros _ [|] [|]; firstorder.
  intros _. firstorder.
  tauto.
  intros _ [|]; firstorder.
Qed.

(* Instance mm_negb l: morphism l bool_lops (dual_ops bool_ops) negb. *)

(** we get most lattice laws by the faithful embedding into [Prop]  *)
Instance bool_lattice_laws: lattice.laws (BL+STR+CNV+DIV) bool_lattice_ops.
Proof.
  assert(H: lattice.laws BDL bool_lattice_ops).
   apply (laws_of_injective_morphism is_true mm_bool_Prop).
   intros x y. apply le_bool_spec.
   intros x y. apply eq_bool_iff.
  constructor; try apply H; (try now left); intros _ [|]; reflexivity.
Qed.

(** simple characterisation of finite sups and infs in [bool] *)

Lemma is_true_sup I J (f: I -> bool): \sup_(i\in J) f i <-> (exists i, List.In i J /\ f i).
Proof.
  unfold is_true. induction J; simpl. firstorder; discriminate.
  rewrite Bool.orb_true_iff. firstorder congruence.
Qed.

Lemma is_true_inf I J (f: I -> bool): \inf_(i\in J) f i <-> (forall i, List.In i J -> f i).
Proof.
  unfold is_true. induction J; simpl. firstorder.
  rewrite Bool.andb_true_iff. firstorder congruence.
Qed.

(** * Boolean as a (flat) monoid
   this is useful:
   - to construct boolean matrices,
   - to consider regex.epsilon as a functor) *)

(** this monoid is flat: this is a one object category.
   We use the following singleton type to avoid confusion with the
   singleton types of other flat structures *)
CoInductive bool_unit := bool_tt.

(** note that the trivial type information is simply ignored *)
Canonical Structure bool_ops: monoid.ops := {|
  ob := bool_unit;
  mor n m := bool_lattice_ops;
  dot n m p := andb;
  one n := true;
  itr n x := x;
  str n x := true;
  cnv n m x := x;
  ldv n m p x y := !x \cup y;
  rdv n m p x y := !x \cup y
|}.

(** shorthand for [bool], when a morphism is expected *)
Notation bool' := (bool_ops bool_tt bool_tt).

(** we actually have all laws on [bool] *)
Instance bool_laws: laws (BL+STR+CNV+DIV) bool_ops.
Proof.
  constructor; (try now left);repeat right; intros.
   apply bool_lattice_laws.
   apply capA.
   apply captx.
   apply weq_leq. simpl. apply capC.
   reflexivity.
   now intros ? ? ?.
   reflexivity.
   case x; reflexivity.
   simpl. reflexivity.
   case x; reflexivity.
   case x; reflexivity.
   case x; case z; reflexivity.
   case x; case z; reflexivity.
Qed.

(** * properties of the [ofbool] injection *)

Section ofbool.

Open Scope bool_scope.
Implicit Types a b c: bool.
Context {X: ops} {l} {L: laws l X} {n: ob X}.
Notation ofbool := (@ofbool X n).

Lemma andb_dot `{BOT<<l} a b: ofbool (a&&b) == ofbool a * ofbool b.
Proof.
  symmetry. case a. apply dot1x.
  apply antisym. now apply weq_leq, dot0x. apply leq_bx.
Qed.

Lemma orb_pls `{CUP+BOT<<l} a b: ofbool (a||b) == ofbool a + ofbool b.
Proof. symmetry. case a; simpl. case b; simpl; lattice. lattice. Qed.

Global Instance ofbool_leq `{BOT<<l}: Proper (leq ==> leq) ofbool.
Proof. intros [|] b E; simpl. now rewrite E. apply leq_bx. Qed.

Lemma dot_ofboolx `{BOT<<l} b (x: X n n): ofbool b*x == x*ofbool b.
Proof. case b; simpl. now rewrite dot1x, dotx1. now rewrite dot0x, dotx0. Qed.

End ofbool.

(** [is_true] is also monotone *)
Instance is_true_leq: Proper (leq ==> leq) is_true.
Proof. intros [|] b E; simpl. now rewrite E. discriminate. Qed.