(** Authors: Christian Doczkal and Jan-Oliver Kaiser *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype path fingraph finfun finset generic_quotient.
From RegLang Require Import misc languages dfa.

Set Implicit Arguments.
Unset Printing Implicit Defensive.
Unset Strict Implicit.

Local Open Scope quotient_scope.

(** * DFA Minimization *)

Section Minimization.
Variable (char : finType).
Local Notation word := (word char).
Local Notation dfa := (dfa char).

Definition coll (A : dfa) x y := forall w, (delta x w \in dfa_fin A) = (delta y w \in dfa_fin A).

Definition connected (A : dfa) := surjective (delta_s A).
Definition collapsed (A : dfa) := forall x y: A, coll x y <-> x = y.
Definition minimal (A : dfa) := forall B, dfa_lang A =i dfa_lang B -> #|A| <= #|B|.

(** ** Uniqueness of connected and collapsed automata *)

Definition dfa_iso (A1 A2 : dfa) :=
  exists i: A1 -> A2,
    [/\ bijective i,
        forall x a, i (dfa_trans x a) = dfa_trans (i x) a,
        forall x, i (x) \in dfa_fin A2 = (x \in dfa_fin A1) &
        i (dfa_s A1) = dfa_s A2 ].

Section Isomopism.
  Variables (A B : dfa).
  Hypothesis L_AB : dfa_lang A =i dfa_lang B.

  Hypothesis (A_coll: collapsed A) (B_coll: collapsed B).
  Hypothesis (A_conn : connected A) (B_conn : connected B).

  Definition iso := delta_s B \o cr A_conn.
  Definition iso_inv := delta_s A \o cr B_conn.

  Lemma delta_iso w x : delta (iso x) w \in dfa_fin B = (delta x w \in dfa_fin A).
  Proof. by rewrite -{2}[x](crK (Sf := A_conn)) -!delta_cat !delta_lang L_AB. Qed.

  Lemma delta_iso_inv w x : delta (iso_inv x) w \in dfa_fin A = (delta x w \in dfa_fin B).
  Proof. by rewrite -{2}[x](crK (Sf := B_conn)) -!delta_cat !delta_lang L_AB. Qed.

  Lemma can_iso : cancel iso_inv iso.
  Proof. move => x. apply/B_coll => w. by rewrite delta_iso delta_iso_inv. Qed.

  Lemma can_iso_inv : cancel iso iso_inv.
  Proof. move => x. apply/A_coll => w. by rewrite delta_iso_inv delta_iso. Qed.

  Lemma coll_iso : dfa_iso A B.
  Proof.
    exists iso. split.
    - exact: Bijective can_iso_inv can_iso.
    - move => x a. apply/B_coll => w. rewrite -[_ (iso x) a]/(delta (iso x) [::a]).
      by rewrite -delta_cat -!delta_iso_inv !can_iso_inv.
    - move => x. by rewrite -[iso x]/(delta _ [::]) delta_iso.
    - apply/B_coll => w. by rewrite delta_iso !delta_lang.
  Qed.

  Lemma dfa_iso_size : dfa_iso A B -> #|A| = #|B|.
  Proof. move => [iso [H _ _ _]]. exact (bij_card H). Qed.
End Isomopism.

Lemma abstract_minimization A f :
  (forall B, dfa_lang (f B) =i dfa_lang B /\ #|f B| <= #|B| /\ connected (f B) /\ collapsed (f B))
  -> minimal (f A).
Proof.
  move => H B L_AB. apply: (@leq_trans #|f B|); last by firstorder. apply: eq_leq.
  apply: dfa_iso_size. (apply: coll_iso; try apply H) => w. rewrite L_AB. by case (H B) => ->.
Qed.

(** ** Construction of the Connected Sub-Automaton *)

Section Prune.
  Variable A : dfa.

  Definition reachable  (q:A) := exseq_dec (@delta_rc _ A) (pred1 q).
  Definition connectedb := [forall x: A, reachable x].

  Lemma connectedP : reflect (connected A) (connectedb).
  Proof.
    apply: (iffP forallP) => H y; first by move/dec_eq: (H y).
    apply/dec_eq. case (H y) => x Hx. by exists x.
  Qed.

  Definition reachable_type := { x:A | reachable x }.

  Lemma reachable_trans_proof (x : reachable_type) a : reachable (dfa_trans (val x) a).
  Proof.
    apply/dec_eq. case/dec_eq : (svalP x) =>  /= y /eqP <-.
    exists (y++[::a]). by rewrite delta_cat.
  Qed.

  Definition reachable_trans (x : reachable_type) a : reachable_type :=
    Sub (dfa_trans (val x) a) (reachable_trans_proof x a).

  Lemma reachabe_s_proof : reachable (dfa_s A).
  Proof. apply/dec_eq. exists nil. exact: eqxx. Qed.

  Definition reachable_s : reachable_type := Sub (dfa_s A) reachabe_s_proof.

  Definition dfa_prune := {|
      dfa_s := reachable_s;
      dfa_fin := [set x | val x \in dfa_fin A];
      dfa_trans := reachable_trans |}.

  Lemma dfa_prune_correct : dfa_lang dfa_prune =i dfa_lang A.
  Proof.
    rewrite /dfa_lang /= -[dfa_s A]/(val reachable_s) => w.
    rewrite !inE. elim: w (reachable_s) => [|a w IHw] [x Hx] //=.
    + by rewrite /dfa_accept inE.
    + by rewrite accE IHw.
  Qed.

  Lemma dfa_prune_connected : connected dfa_prune.
  Proof.
    move => q. case/dec_eq: (svalP q) => /= x Hx. exists x.
    elim/last_ind : x q Hx => //= x a IHx q.
    rewrite -!cats1 /delta_s !delta_cat -!/(delta_s _ x) => H.
    have X : reachable (delta_s A x). apply/dec_eq; exists x. exact: eqxx.
    by rewrite (eqP (IHx (Sub (delta_s A x) X) _)).
  Qed.

  Hint Resolve dfa_prune_connected.

  Lemma dfa_prune_size : #|dfa_prune| <= #|A|.
  Proof. by rewrite card_sig subset_leq_card // subset_predT. Qed.

  (** If pruning does not remove any states, the automaton is connected *)

  Lemma prune_eq_connected : #|A| = #|dfa_prune| -> connected A.
  Proof.
    move => H. apply/connectedP. apply/forallP => x.
    by move: (cardT_eq (Logic.eq_sym H)) ->.
  Qed.

End Prune.

(** ** Quoitient modulo collapsing relation

For the minimization of connected automata we construct the quotient of the
input automaton with respect to the collapsing relation. To form the quotient
constructively, we have to show that the collapsing relation is decidable. *)

Section Collapse.
  Variable A : dfa.

  (** Decidabilty of the collapsing relation   *)

  Definition coll_fun (p q : A) x := (delta p x,delta q x).

  Lemma coll_fun_RC p q x y a :
    coll_fun p q x = coll_fun p q y -> coll_fun p q (x++[::a]) = coll_fun p q (y++[::a]).
  Proof. move => [H1 H2]. by rewrite /coll_fun !delta_cat H1 H2. Qed.

  Definition collb p q : bool :=
    allseq_dec (@coll_fun_RC p q) [pred p | (p.1 \in dfa_fin A) == (p.2 \in dfa_fin A)].

  Lemma collP p q : reflect (coll p q) (collb p q).
  Proof.
    apply: (iffP idP).
    - move/dec_eq => H x. by move/eqP: (H x).
    - move => H. apply/dec_eq => x. apply/eqP. exact: H.
  Qed.

  Lemma collb_refl x : collb x x.
  Proof. apply/collP. rewrite /coll. auto. Qed.

  Lemma collb_sym : symmetric collb.
  Proof. move => x y. by apply/collP/collP; move => H w; rewrite H. Qed.

  Lemma collb_trans : transitive collb.
  Proof. move => x y z /collP H1 /collP H2. apply/collP => w. by rewrite H1 H2. Qed.

  Lemma collb_step a x y : collb x y -> collb (dfa_trans x a) (dfa_trans y a).
  Proof. move => /collP H. apply/collP => w. by rewrite !delta_cons H. Qed.

  (** We make collb the canonical equivalence relation on [A] and take
  the corresponding quotient type as state space for the minimized automaton *)

  Canonical collb_equiv := EquivRelPack (EquivClass collb_refl collb_sym collb_trans).

  Definition collapse_state := {eq_quot collb_equiv}.

  Canonical min_quotType := [quotType of collapse_state].
  Canonical min_subType := [subType collapse_state of A by %/].
  Canonical min_eqType := EqType _ [eqMixin of collapse_state by <:%/].
  Canonical min_choiceType := ChoiceType _ [choiceMixin of collapse_state by <:%/].
  Canonical min_finType := FinType _ [finMixin of min_eqType by <:%/].
  Canonical min_subFinType := [subFinType of collapse_state].

  Definition collapse : dfa := {|
    dfa_s := \pi_(collapse_state) (dfa_s A);
    dfa_trans x a := \pi (dfa_trans (repr x) a);
    dfa_fin := [set x : collapse_state | repr x \in dfa_fin A ] |}.

  Lemma collapse_delta (x : A) w :
    delta (\pi x : collapse) w = \pi (delta x w).
  Proof.
    elim: w x => //= a w IHw x. rewrite -IHw. f_equal.
    apply/eqmodP. apply: collb_step. exact: epiK.
  Qed.

  Lemma collapse_fin (x : A) :
    (\pi x \in dfa_fin collapse) = (x \in dfa_fin A).
  Proof.
    rewrite /collapse /= inE.
    by move/collP: (epiK collb_equiv x) => /(_ [::]).
  Qed.

End Collapse.

(** ** Correctness of Minimization *)

(** Minimization yields a fully collapsed DFA accpeting the same language *)

Lemma collapse_collapsed (A  : dfa) : collapsed (collapse A).
Proof.
  split => [H|->]; last by apply/collP; exact: collb_refl.
  rewrite -[x]reprK -[y]reprK. apply/eqmodP/collP => w.
  by rewrite -!collapse_fin -!collapse_delta !reprK.
Qed.

Lemma collapse_correct A : dfa_lang (collapse A) =i dfa_lang A.
Proof.
  move => w. rewrite !inE /dfa_accept {1}/dfa_s /= inE collapse_delta.
  by rewrite -!collapse_fin reprK.
Qed.

Lemma collapse_size A : #|collapse A| <= #|A|.
Proof. rewrite card_sub. exact: max_card. Qed.

Lemma collapse_connected A : connected A -> connected (collapse A).
Proof.
  move => H x. case: (H (repr x)) => w /eqP Hw. exists w.
  by rewrite /delta_s collapse_delta -/(delta_s A w) Hw reprK.
Qed.

(** Combine prunine and collapsing into minimization function *)

Definition minimize := collapse \o dfa_prune.

Lemma minimize_size (A : dfa) : #|minimize A| <= #|A|.
Proof. exact: leq_trans (collapse_size _) (dfa_prune_size _). Qed.

Lemma minimize_collapsed (A : dfa) : collapsed (minimize A).
Proof. exact: collapse_collapsed. Qed.

Lemma minimize_connected (A : dfa) : connected (minimize A).
Proof. apply collapse_connected. exact: dfa_prune_connected. Qed.

Lemma minimize_correct (A : dfa) : dfa_lang (minimize A) =i dfa_lang A.
Proof. move => x. by rewrite collapse_correct dfa_prune_correct. Qed.

Hint Resolve minimize_size minimize_collapsed minimize_connected.

Lemma minimize_minimal A : minimal (minimize A).
Proof. apply: abstract_minimization => B. auto using minimize_correct. (* and hints *) Qed.

(** ** Uniqueness of minimal automaton *)

Lemma minimal_connected A : minimal A -> connected A.
Proof.
  move => MA. apply: prune_eq_connected.
  apply/eqP. rewrite eqn_leq dfa_prune_size andbT.
  apply: MA => x. by rewrite dfa_prune_correct.
Qed.

Lemma minimal_collapsed A : minimal A -> collapsed A.
Proof.
  move => MA.
  have B : bijective (\pi_(collapse_state A)).
    apply: surj_card_bij.
    - move => x. exists (repr x). by rewrite reprK.
    - apply/eqP. rewrite eqn_leq collapse_size (MA (collapse A)) // => x.
      by rewrite collapse_correct.
  move => x y. split => [|->]; last exact/collP/collb_refl.
  move/collP/eqmodP. exact: bij_inj.
Qed.

(** In order to generalize the reasoning above to arbitrary quotients
types over finite types we would first have to ensure that [{eq_quot e}]
inherits the finType structure on the carrier of [e]. By default
this is not the case *)

Lemma minimalP A : minimal A <-> (connected A /\ collapsed A).
Proof.
  split.
  - move => H. split. exact: minimal_connected. exact: minimal_collapsed.
  - move => [H1 H2] B L_AB. apply: leq_trans _ (minimize_size _). apply: eq_leq.
    apply: dfa_iso_size. apply: coll_iso => // x. by rewrite minimize_correct.
Qed.

Lemma minimal_iso A B :
  dfa_lang A =i dfa_lang B -> minimal A -> minimal B -> dfa_iso A B.
Proof. move => L_AB /minimalP [? ?] /minimalP [? ?]. exact: coll_iso. Qed.

End Minimization.


Require Import  month.

(** explicit use of month_rect

*)
Definition is_January_clumsy : month -> Prop :=
 month_rect (fun m => Prop)
  True
  False
  False
  False
  False
  False
  False
  False
  False
  False
  False
  False.

(** Tests:

Compute is_January_clumsy February.

Compute is_January_clumsy January.
*)

(* alternate solution *)

Definition is_January (m : month) : Prop :=
 match m with
 | January => True
 | other_month => False
 end.

Remark both_versions_are_convertible :
    is_January = is_January_clumsy.
Proof. reflexivity. Qed.


Inductive bit : Type :=
  | B0
  | B1.

Inductive nybble : Type :=
  | bits (b0 b1 b2 b3 : bit).

Check (bits B1 B0 B0 B0).

Definition all_zero (nb : nybble) : bool :=
  match nb with
    | (bits B0 B0 B0 B0) => true
    | (bits _ _ _ _) => false
  end.

Compute (all_zero (bits B1 B0 B1 B0)).

Compute (all_zero (bits B0 B0 B0 B0)).


(*************************************************************************

 Bicat of invertible 2-cells

 This is the bicategory where we only consider the invertible 2-cells.

 Contents
 1. Definition
 2. Univalence

 *************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.

Local Open Scope cat.

Section BicatOfInv2Cells.
  Context (B : bicat).

  (**
   1. Definition
   *)
  Definition disp_prebicat_1_id_comp_cells_of_inv2cells
    : disp_prebicat_1_id_comp_cells B.
  Proof.
    simple refine (((_ ,, _) ,, (_ ,, _)) ,, _).
    - exact (λ _, unit).
    - exact (λ _ _ _ _ _, unit).
    - exact (λ _ _, tt).
    - exact (λ _ _ _ _ _ _ _ _ _ _, tt).
    - exact (λ x y f g α _ _ _ _, is_invertible_2cell α).
  Defined.

  Definition disp_prebicat_ops_of_inv2cells
    : disp_prebicat_ops disp_prebicat_1_id_comp_cells_of_inv2cells.
  Proof.
    repeat split ; intro ; intros ; cbn ; is_iso.
  Defined.

  Definition disp_prebicat_data_of_inv2cells
    : disp_prebicat_data B.
  Proof.
    simple refine (_ ,, _).
    - exact disp_prebicat_1_id_comp_cells_of_inv2cells.
    - exact disp_prebicat_ops_of_inv2cells.
  Defined.

  Definition disp_prebicat_laws_of_inv2cells
    : disp_prebicat_laws disp_prebicat_data_of_inv2cells.
  Proof.
    repeat split ; intro ; intros ; apply isaprop_is_invertible_2cell.
  Qed.

  Definition disp_prebicat_of_inv2cells
    : disp_prebicat B.
  Proof.
    simple refine (_ ,, _).
    - exact disp_prebicat_data_of_inv2cells.
    - exact disp_prebicat_laws_of_inv2cells.
  Defined.

  Definition disp_bicat_of_inv2cells
    : disp_bicat B.
  Proof.
    refine (disp_prebicat_of_inv2cells ,, _).
    intro ; intros.
    apply isasetaprop.
    apply isaprop_is_invertible_2cell.
  Defined.

  Definition disp_bicat_of_inv2cells_disp_2cells_isaprop
    : disp_2cells_isaprop disp_bicat_of_inv2cells.
  Proof.
    intro ; intros.
    apply isaprop_is_invertible_2cell.
  Qed.

  Definition disp_bicat_of_inv2cells_locally_groupoid
    : disp_locally_groupoid disp_bicat_of_inv2cells.
  Proof.
    use make_disp_locally_groupoid.
    - intro ; intros.
      cbn in *.
      is_iso.
    - exact disp_bicat_of_inv2cells_disp_2cells_isaprop.
  Defined.

  (**
   2. Univalence
   *)
  Definition disp_univalent_2_1_disp_bicat_of_inv2cells
    : disp_univalent_2_1 disp_bicat_of_inv2cells.
  Proof.
    use fiberwise_local_univalent_is_univalent_2_1.
    intro ; intros.
    use isweqimplimpl.
    - intro.
      apply isapropunit.
    - apply isasetunit.
    - use invproofirrelevance.
      intros φ₁ φ₂.
      use subtypePath.
      {
        intro.
        apply isaprop_is_disp_invertible_2cell.
      }
      apply disp_bicat_of_inv2cells_disp_2cells_isaprop.
  Qed.

  Definition disp_univalent_2_0_disp_bicat_of_inv2cells
             (HB_2_1 : is_univalent_2_1 B)
    : disp_univalent_2_0 disp_bicat_of_inv2cells.
  Proof.
    use fiberwise_univalent_2_0_to_disp_univalent_2_0.
    intro ; intros.
    use isweqimplimpl.
    - intro.
      apply isapropunit.
    - apply isasetunit.
    - use invproofirrelevance.
      intros φ₁ φ₂.
      use subtypePath.
      {
        intro.
        use (isaprop_disp_left_adjoint_equivalence _ _ HB_2_1).
        exact disp_univalent_2_1_disp_bicat_of_inv2cells.
      }
      apply isapropunit.
  Qed.

  Definition disp_univalent_2_disp_bicat_of_inv2cells
             (HB_2_1 : is_univalent_2_1 B)
    : disp_univalent_2 disp_bicat_of_inv2cells.
  Proof.
    split.
    - exact (disp_univalent_2_0_disp_bicat_of_inv2cells HB_2_1).
    - exact disp_univalent_2_1_disp_bicat_of_inv2cells.
  Qed.

  Definition bicat_of_inv2cells
    : bicat
    := total_bicat disp_bicat_of_inv2cells.

  Definition is_univalent_2_1_bicat_of_inv2cells
             (HB_2_1 : is_univalent_2_1 B)
    : is_univalent_2_1 bicat_of_inv2cells.
  Proof.
    use total_is_univalent_2_1.
    - exact HB_2_1.
    - exact disp_univalent_2_1_disp_bicat_of_inv2cells.
  Defined.

  Definition is_univalent_2_0_bicat_of_inv2cells
             (HB_2_1 : is_univalent_2_1 B)
             (HB_2_0 : is_univalent_2_0 B)
    : is_univalent_2_0 bicat_of_inv2cells.
  Proof.
    use total_is_univalent_2_0.
    - exact HB_2_0.
    - use disp_univalent_2_0_disp_bicat_of_inv2cells.
      exact HB_2_1.
  Defined.

  Definition is_univalent_2_bicat_of_inv2cells
             (HB_2 : is_univalent_2 B)
    : is_univalent_2 bicat_of_inv2cells.
  Proof.
    use total_is_univalent_2.
    - apply disp_univalent_2_disp_bicat_of_inv2cells.
      exact (pr2 HB_2).
    - exact HB_2.
  Defined.

  Definition is_invertible_2cell_bicat_of_inv2cells
             {x y : bicat_of_inv2cells}
             {f g : x --> y}
             (α : f ==> g)
    : is_invertible_2cell α.
  Proof.
    use make_is_invertible_2cell.
    - simple refine (_ ,, _).
      + exact ((pr2 α)^-1).
      + cbn.
        is_iso.
    - abstract
        (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
         apply vcomp_rinv).
    - abstract
        (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
         apply vcomp_linv).
  Defined.

  Definition locally_groupoid_bicat_of_inv2cells
    : locally_groupoid bicat_of_inv2cells.
  Proof.
    intro ; intros.
    apply is_invertible_2cell_bicat_of_inv2cells.
  Defined.

  Definition eq_2cell_bicat_of_inv2cells
             {x y : bicat_of_inv2cells}
             {f g : x --> y}
             {α β : f ==> g}
             (p : pr1 α = pr1 β)
    : α = β.
  Proof.
    use subtypePath.
    {
      intro.
      apply isaprop_is_invertible_2cell.
    }
    exact p.
  Qed.
End BicatOfInv2Cells.


Require Import Nat List Decimal DecimalNat List Lia.
Import ListNotations.

Set Implicit Arguments.

Record fsa (S A : Type) := FSA {
  initial : S;
  next : S -> A -> S -> Prop
}.

Inductive fsa_run {S A : Type } (m : fsa S A) : list A -> S -> Prop :=
| step : forall a s, m.(next) m.(initial) a s -> fsa_run m [a] s
| trans : forall s1 a s2 l rs, m.(next) s1 a s2 -> fsa_run m l rs -> fsa_run m (a::l) rs.

Section strtoimax_automaton.

  Variable blen : nat.

  Definition MAX := to_uint (2 ^ (blen - 1) - 1).
  Definition MIN := to_uint (2 ^ (blen - 1)).

  (** inputs *)
  Inductive char :=
  | sign_char (s : bool)  (* [true] for [+] *)
  | digit_char (d : nat)
  | other_char.

  (** states *)
  Inductive strtoimax_state :=
  | EMPTY
  | INVAL
  | MORE (max : uint)
  | OK (n : nat) (max : uint) (b : Datatypes.comparison)
  | OK_MAX
  | RANGE
  | EXTRA.

  (* [n]th decimal digit of [u] *)
  Fixpoint nth_digit (n : nat) (u : uint) : nat :=
    match n, u with
    | O, _      => Unsigned.hd u
    | S n', Nil => 0
    | S n', _   => nth_digit n' (Unsigned.tl u)
    end.

  (* decimal length *)
  Let dlen := Unsigned.usize.
  (* [branch] selects which OK case to go to (over, under or exact) *)
  Let branch (d : nat) (n : nat) (max : uint) := Nat.compare d (nth_digit n max).
  Let branch_len (max : uint) (b : comparison) := match b with
                                                  | Gt => dlen max - 3
                                                  | _ => dlen max - 2
                                                  end.

  Reserved Notation "st1 -[ c ]-> st2" (at level 50).
  Inductive strtoimax_next : strtoimax_state -> char -> strtoimax_state -> Prop :=
  | inval         : forall c,       INVAL     -[ c               ]-> INVAL
  | range         : forall c,       RANGE     -[ c               ]-> RANGE
  | extra         : forall c,       EXTRA     -[ c               ]-> EXTRA
  | empty_other   :            EMPTY     -[ other_char      ]-> INVAL
  | empty_plus    :            EMPTY     -[ sign_char true  ]-> MORE MAX
  | empty_minus   :            EMPTY     -[ sign_char false ]-> MORE MIN
  | empty_digit   : forall d,       EMPTY     -[ digit_char d    ]-> OK 0 MAX (branch d 0 MAX)
  | more_other    : forall m,       MORE m    -[ other_char      ]-> INVAL
  | more_sign     : forall m s,     MORE m    -[ sign_char s     ]-> INVAL
  | more_digit    : forall d m,     MORE m    -[ digit_char d    ]-> OK 0 m (branch d 0 m)
  | okmax_other   :            OK_MAX    -[ other_char      ]-> EXTRA
  | okmax_sign    : forall s,       OK_MAX    -[ sign_char s     ]-> EXTRA
  | okmax_digit   : forall d,       OK_MAX    -[ digit_char d    ]-> RANGE
  | ok_other      : forall n m b,   OK n m b  -[ other_char      ]-> EXTRA
  | ok_sign       : forall n m b s, OK n m b  -[ sign_char s     ]-> EXTRA
  | ok_gt_step    : forall n m d,   n < branch_len m Gt ->
                               OK n m Gt -[ digit_char d ]-> OK (S n) m Gt
  | ok_lt_step    : forall n m d,   n < branch_len m Lt ->
                               OK n m Lt -[ digit_char d ]-> OK (S n) m Lt
  | ok_eq_step    : forall n m d,   n < branch_len m Eq ->
                               OK n m Eq -[ digit_char d ]-> OK (S n) m (branch d (S n) m)
  | ok_gt_last    : forall m d,     OK (branch_len m Gt) m Gt -[ digit_char d ]-> OK_MAX
  | ok_lt_last    : forall m d,     OK (branch_len m Lt) m Lt -[ digit_char d ]-> OK_MAX
  | ok_eq_last    : forall m d,     d <= nth_digit (branch_len m Eq) m ->
                               OK (branch_len m Eq) m Eq -[ digit_char d ]-> OK_MAX
  | ok_eq_overfl  : forall m d,     nth_digit (branch_len m Eq) m < d ->
                               OK (branch_len m Eq) m Eq -[ digit_char d]-> RANGE
  where "st1 -[ c ]-> st2" := (strtoimax_next st1 c st2).

  Definition strtoimax_fsa := {| initial := EMPTY; next := strtoimax_next |}.

  Lemma strtoimax_next_functional :
    forall c s s1 s2,
      s -[ c ]-> s1 ->
      s -[ c ]-> s2 ->
      s1 = s2.
  Proof.
    intros.
    destruct s.
    all: inversion H; inversion H0.
    all: unfold branch_len, branch in *; subst.
    all: try (replace d0 with d in * by congruence).
    all: try reflexivity.
    all: try discriminate.
    all: lia.
  Qed.

  Lemma strtoimax_next_total :
    forall s1 c, exists s2,
        s1 -[ c ]-> s2.
  Proof.
    intros.
    destruct s1, c.
    all: try (eexists; econstructor).
    destruct s; eexists; econstructor.
    destruct (Nat.compare n (branch_len max b)) eqn:B.
    - apply Compare_dec.nat_compare_eq in B; subst.
      destruct b.
       + destruct (Compare_dec.le_lt_dec d (nth_digit (branch_len max Eq) max)).
         * eexists; eapply ok_eq_last; assumption.
         * eexists; eapply ok_eq_overfl; assumption.
       + eexists; eapply ok_lt_last.
       + eexists; eapply ok_gt_last.
    - apply Compare_dec.nat_compare_Lt_lt in B.
      destruct b;
        econstructor; econstructor; assumption.
    - apply Compare_dec.nat_compare_Gt_gt in B.
      (* UNPROVABLE *)
      (* such state [OK n max b] is, however, unreachable for the automaton: *)
      Fact bad_state_unreachable :
        forall s c n max b,
          s -[ c ]-> OK n max b ->
          n <= branch_len max b.
      Admitted.
      (* this also proves there is always a finite number of OK steps *)
  Abort.

End strtoimax_automaton.


Require Import HoTT.

Definition Dec A := A + (~A).
Definition DecEq A := forall (x y : A), Dec (x = y).
Definition UIP_refl (A : Type) := forall (x : A) (p : x = x),
                           p = idpath.

Theorem transport_path_concat : forall A (a x y: A)
  (p : x = y) (k : a = x),
  transport (fun z => paths a z) p k = k @ p.
Proof.
  intros. induction p.
  simpl. symmetry. apply concat_p1.
Qed.

(** Basically, if [q : (a,b) = (c,d)], then [fstp q : a = c] and
[sndp q : b = d] *)

Definition fstp {A} {x y : A * A}
  (p : x = y) : (fst x) = (fst y) := ap fst p.
Definition sndp {A} {x y : A * A}
  (p : x = y) : (snd x) = (snd y) := ap snd p.

Theorem transport_prod_path_concat : forall {A} {x y : A * A}
  (q : x = y) (k : fst x = snd x),
  transport (fun z => (fst z = snd z))
            q
            k
  = ((fstp q)^ @ k @ (sndp q)).
Proof.
  intros. induction q. simpl.
  rewrite concat_1p. rewrite concat_p1. reflexivity.
Qed.

Theorem transport_decpath_concat : forall {A} {x y : A * A}
  (q : x = y) (k : fst x = snd x),
  transport (fun z => (fst z = snd z) + (fst z <> snd z))
            q
            (inl k)
  = inl ((fstp q)^ @ k @ (sndp q)).
Proof.
  intros. rewrite <- transport_prod_path_concat.
  rewrite transport_sum. reflexivity.
Qed.

Theorem transport_decpath_concat' : forall {A} {a b c d : A}
  (q1 : a = c) (q2 : b = d) (k : a = b),
  transport (fun z => (fst z = snd z) + (fst z <> snd z))
            (path_prod (a,b) (c,d) q1 q2)
            (inl k)
  = inl (q1^ @ k @ q2).
Proof.
  intros.
  rewrite transport_decpath_concat with (q:=path_prod (a, b) (c, d) q1 q2).
  unfold fstp,sndp.
  rewrite ap_fst_path_prod.
  rewrite ap_snd_path_prod.
  reflexivity.
Qed.

Definition uncurry {A B C} (f: forall (a:A) (b:B), C a b)
  (x : A * B) : C (fst x) (snd x) := match x with
                                       | (a, b) => f a b
                                     end.
Definition concat_p1V {A : Type} {x y : A} (p : x = y) :
  p @ 1^ = p
  :=
  match p with idpath => 1 end.
Definition concat_1Vp {A : Type} {x y : A} (p : x = y) :
  1^ @ p = p
  :=
  match p with idpath => 1 end.

Theorem Hedberg : forall A, DecEq A
  -> UIP_refl A.
Proof.
  intros A H.
  intros x p.
  (** define [z x] = [dec x x] *)
  assert (z := uncurry H); simpl in z.
  (** We need that [(1,p) # (z (x,x)) = z (x,x)] *)
  assert (transport (fun z => (fst z = snd z) + (fst z <> snd z)) (path_prod' 1 p) (z (x,x)) = z (x,x)) as H1.
    {
      apply (apD z (path_prod' 1 p)).
    }
  (** Clearly, [z (x,x)] can only be [inl q] for some [q] *)
  destruct (z (x,x)) as [q | nq]; [| destruct (nq p)].
  (** [p = 1] is the same as [1^ @ p @ q = q] *)
  apply (cancelL q). rewrite concat_p1.
  apply (cancelL 1^).
    (* we cannot do [rewrite concat_1Vp at 2] *)
    symmetry; rewrite concat_1Vp; symmetry.
  rewrite concat_p_pp.
  (** [1^ @ q @ p = q] iff [inl (1^ @ q @ p) = inl q] *)
  apply (@path_sum_inl _ (x<>x)).
  (** finally, we know that [inl ((1^ @ q) @ p)] is how transport works on a decpath space *)
  rewrite <- (transport_decpath_concat' 1 p q).
  rewrite H1. reflexivity.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* Cat: Category Theory with classes.
 *
 * This module defines categories and some standard instances.
 *
 * Author: Matthieu Sozeau <mattam@mattam.org>
 *)

Set Implicit Arguments.
Unset Strict Implicit.

(** We first define setoids on a carrier, it amounts to an equivalence relation.
   Now [equiv] is overloaded for every [Setoid].
*)

Require Export Coq.Program.Program.

(** This declares a [Setoid] for any [A] type (implicit quantification is going on as before).
   This means that every [Setoid] constraint will be trivially satisfied by this instance so we better
   add more specific instances after this one to get a finer definition. *)

Require Export Setoid.
Require Export Coq.Classes.SetoidClass.
Require Export Coq.Classes.Functions.

Instance id_morphism `(A : Type) `(R : relation A) : Morphism (R ++> R) id.
Proof. do 2 red ; intuition. Qed.

Hint Resolve id_morphism : category.

(** The type of homsets of objects of type [A] *)

Definition homomorphisms A := A -> A -> Type.

(** A [Category] is a set of objects and morphisms with a distinguished [id] morphism and a
   [compose] law satisfiying the monoid laws. We use setoids for objects and morphisms because we may
   want to redefine equality, e.g. to use extensional equality for functions. *)

Class Category obj (hom : homomorphisms obj) := {
  (* For nicer, user defined equalities. *)
  morphisms :> forall a b : obj, Setoid (hom a b) ;

  (* Definitional components: the id_A arrow and composition. *)
  id : forall {a}, hom a a;

  id_morphisms_morphism :> forall a, Morphism equiv (id (a:=a)) ;

  compose : forall {a b c}, hom a b -> hom b c -> hom a c;

  compose_morphism :> forall a b c,
    Morphism (equiv ==> equiv ==> equiv)
    (@compose a b c) ;

  (* Laws (composition reverses the arguments, hence the names) *)
  id_unit_left  : forall a b (f : hom a b), compose f id == f;

  id_unit_right : forall a b (f : hom a b), compose id f == f;

  assoc : forall a b c d (f : hom a b) (g : hom b c) (h : hom c d),
    compose f (compose g h) == compose (compose f g) h
}.

Implicit Arguments Category [].

(** Overloaded composition operator. *)

Notation " x '∘' y " := (compose y x) (at level 40, left associativity).

Hint Resolve @id_morphisms_morphism @id_unit_left @id_unit_right @assoc : category.

(** Definining the opposite category by reversing the arrows. *)

(** [opposite X] takes the opposite of the object's set: itself. *)

Definition opposite (X : Type) := X.

(** Adding hints because [opposite obj] is convertible to [obj], and [(flip hom) x x] is convertible to [hom x x].
   When we use [id] against the goal [forall a : opposite obj, Hom a a], we have to find an instance
   of [Category (opposite obj) (flip hom)] (which we are actually building), hence we have an unsolvable contraint.
   But we know we can use the [id] definition on the [Category obj hom] as [forall a : opposite obj, (flip hom) a a] is
   convertible to [forall a : obj, hom a a] hence the forcing suffices. Similarly for compose, the unspecialized
   compose instance is too general but the constrained one is ok due to conversions. *)

Program Instance opposite_category `(cat :  Category obj hom )  : Category (opposite obj) (flip hom) := {
  morphisms a b := morphisms b a ;
  id a := id (hom := hom) ;
  compose a b c := flip (compose (hom:=hom))
}.

  Solve Obligations using unfold flip in * ; program_simpl; auto with category.

  Next Obligation.
  Proof.
    do 3 (red ; intros).
    unfold flip in *.
    setoid_rewrite H.
    clrewrite H0.
    reflexivity.
  Qed.

  Next Obligation.
  Proof.
    unfold flip in *.
    symmetry ; apply assoc.
  Qed.

Record category := mkCat {
  objs : Type ;
  homs : homomorphisms objs ;
  cat : Category objs homs }.

Definition category_equality (c d : category) : Prop :=
  let 'mkCat obj₁ hom₁ cat₁ := c in
  let 'mkCat obj₂ hom₂ cat₂ := d in
    obj₁ = obj₂ /\ JMeq hom₁ hom₂.

Instance category_equality_equivalence : Equivalence category_equality.
Proof. constructor ; do 2 red ; intros.
  destruct x ; simpl.
  split ; subst ; auto.

  destruct x ; destruct y ; simpl.
  red in H.
  intuition.

  destruct x ; destruct y ; destruct z ; simpl.
  red in H, H0.
  intuition ; subst ; auto.
  simpl_JMeq.
  subst ; auto.
Qed.

Hint Resolve category_equality_equivalence.

(** We first need to show that every type constructor is a morphism for leibiniz [eq]. *)

Instance type_constructor_morphism (T : Type -> Type) : Morphism (eq ++> eq) T.
Proof.
  do 2 red; intros.
  refine (match H in eq _ y return T x = T y with
            refl_equal => refl_equal (T x)
          end).
Qed.

Ltac split_dep :=
  match goal with
    [ |- ex (fun _ : ?H => _) ] => let hyp := fresh "H" in assert (hyp:H) ; [ idtac | exists hyp ]
  end.

Lemma eq_eqdep : forall (A : Type) (x y : A), x = y -> JMeq x y.
Proof.
  intros ; subst.
  apply JMeq_refl.
Qed.

Program Instance category_setoid : Setoid category := {
  equiv := category_equality
}.


From Hammer Require Import Hammer.

Require Import ZArith_base.
Require Export Wf_nat.
Require Import Omega.
Local Open Scope Z_scope.

Definition Zwf (c x y:Z) := c <= y /\ x < y.

Section wf_proof.

Variable c : Z.

Let f (z:Z) := Z.abs_nat (z - c).

Lemma Zwf_well_founded : well_founded (Zwf c).
red; intros.
assert (forall (n:nat) (a:Z), (f a < n)%nat \/ a < c -> Acc (Zwf c) a).
clear a; simple induction n; intros.

case H; intros.
case (lt_n_O (f a)); auto.
apply Acc_intro; unfold Zwf; intros.
assert False; omega || contradiction.

case H0; clear H0; intro; auto.
apply Acc_intro; intros.
apply H.
unfold Zwf in H1.
case (Z.le_gt_cases c y); intro; auto with zarith.
left.
red in H0.
apply lt_le_trans with (f a); auto with arith.
unfold f.
apply Zabs2Nat.inj_lt; omega.
apply (H (S (f a))); auto.
Qed.

End wf_proof.

Hint Resolve Zwf_well_founded: datatypes.

Definition Zwf_up (c x y:Z) := y < x <= c.

Section wf_proof_up.

Variable c : Z.

Let f (z:Z) := Z.abs_nat (c - z).

Lemma Zwf_up_well_founded : well_founded (Zwf_up c).
Proof. hammer_hook "Zwf" "Zwf.Zwf_up_well_founded".
apply well_founded_lt_compat with (f := f).
unfold Zwf_up, f.
intros.
apply Zabs2Nat.inj_lt; try (apply Z.le_0_sub; intuition).
now apply Z.sub_lt_mono_l.
Qed.

End wf_proof_up.

Hint Resolve Zwf_up_well_founded: datatypes.


From Coq Require Import Program.
From QuickChick Require Import QuickChick.
From mathcomp Require Import all_ssreflect.
Global Set Bullet Behavior "None".
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section HilbertSaxiom.
Variables A B C : Prop.
Lemma HilbertS : (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
move=> hAiBiC hAiB hA.
move: hAiBiC.
(* move: name - removes from ctx, moves to stack *)
(* move: (name) - moves to stack without remove from ctx *)
apply.
by [].
by apply: hAiB.
Qed.

Hypotheses (hAiBiC : A -> B -> C) (hAiB : A -> B) (hA : A).
Lemma HilbertS2 : C.
Proof.
apply: hAiBiC; first by apply: hA.
exact: hAiB.
Qed.

Lemma HilbertS3 : C.
Proof. by apply: hAiBiC; last exact: hAiB. Qed.

Lemma HilbertS4 : C.
Proof. exact: (hAiBiC _ (hAiB _)). Qed.

Lemma HilbertS5 : C.
Proof. exact: hAiBiC (hAiB _). Qed.

Lemma HilbertS6 : C.
Proof. exact: HilbertS5. Qed.

Print HilbertS5.
Print HilbertS2.
Print HilbertS.
Check HilbertS.

End HilbertSaxiom.

Print bool.

Section Symmetric_Conjunction_Disjunction.
Lemma andb_sym : forall A B : bool, A && B -> B && A.
Proof.
case.
by case.
by [].
Qed.

Lemma andb_sym2 : forall A B : bool, A && B -> B && A.
Proof. by case; case. Qed.

Lemma andb_sym3 : forall A B : bool, A && B -> B && A.
Proof. by do 2! case. Qed. (* do 2! - repeat next tactic two times *)

Variables (C D : Prop) (hC : C) (hD : D).

Check (and C D).

Lemma and_sym : forall A B : Prop, A /\ B -> B /\ A.
Proof. by move=> A1 B []. Qed. (* [] - case *)

Lemma or_sym : forall A B : Prop, A \/ B -> B \/ A.
Proof. by move=> A B [hA | hB]; [apply: or_intror | apply: or_introl]. Qed.

Lemma or_sym2 : forall A B : bool, A \/ B -> B \/ A.
Proof. by move=> [] [] AorB; apply/orP; move/orP : AorB. Qed.

(* apply/orP - rephrase goal *)
(* move/orP  - rephrase stack top *)

End Symmetric_Conjunction_Disjunction.

Print ex.

Section R_sym_trans.
Variables (D : Type) (R : D -> D -> Prop).
Hypothesis R_sym : forall x y, R x y -> R y x.
Hypothesis R_trans : forall x y z, R x y -> R y z -> R x z.

Lemma refl_if : forall x : D, (exists y, R x y) -> R x x.
Proof.
move=> x [y Rxy].
by apply (R_trans Rxy (R_sym Rxy)).
Qed.
End R_sym_trans.

Section Smullyan_drinker.
Variables (D : Type)(P : D -> Prop).
Hypothesis (d : D) (EM : forall A, A \/ ~A).

Lemma drinker : exists x, P x -> forall y, P y.
Proof.
case: (EM (exists y, ~P y)) => [[y notPy]| nonotPy]; first by exists y.
exists d => _ y; case: (EM (P y)) => // notPy.
by case: nonotPy; exists y.
Qed.
End Smullyan_drinker.

Section Equality.
Variable f : nat -> nat.

Hypothesis f00 : f 0 = 0.
Lemma fkk : forall k, k = 0 -> f k = k.
Proof.
move=> k k0.
by rewrite k0.
Qed.

Lemma fkk2 : forall k, k = 0 -> f k = k.
Proof. by move=> k ->. Qed.

Variable f10 : f 1 = f 0.

Lemma ff10 : f (f 1) = 0.
Proof. by rewrite f10 f00. Qed.

Variables (D : eqType) (x y : D).

Lemma eq_prop_bool : x = y -> x == y.
Proof. by move/eqP. Qed.

Lemma eq_bool_prop : x == y -> x = y.
Proof. by move/eqP. Qed.

End Equality.

Section Using_Definition.
Variable U : Type.
Definition set := U -> Prop.
Definition subset (A B : set) := forall x, A x -> B x.
Definition transitive (T : Type) (R : T -> T -> Prop) :=
  forall x y z, R x y -> R y z -> R x z.

Lemma subset_trans : @transitive set subset.
Proof.
rewrite /transitive /subset => x y z subxy subyz t xt.
by apply: subyz; apply: subxy.
Qed.

Lemma subset_trans2 : @transitive set subset.
Proof.
move=> x y z subxy subyz t.
move/subxy. by move/subyz. (* move/name - apply name to top stack *)
Qed.
End Using_Definition.

Lemma three : S (S (S O)) = 3 /\ 2 = 0.+1.+1.
Proof. by []. Qed.

Print le. (* vanilla le *)

Lemma concrete_le : le 1 3.
Proof. by apply: (Le.le_trans _ 2); apply: Le.le_n_Sn. Qed.

Lemma concrete_big_le : le 16 64.
Proof. by auto 47 with arith. Qed.

Lemma plus_commute : forall n1 m1, n1 + m1 = m1 + n1.
Proof.
elim=> [| n IHn m].
- elim => [//| n IHn].
    by rewrite -[0 + n.+1]/(0 + n).+1 IHn.
rewrite -[n.+1 + m]/(n + m).+1 IHn. elim: m => [//| m IHm ].
  by rewrite -[m.+1 + n]/(m + n).+1 IHm.
Qed.

Definition edivn_rec d := fix loop (m q : nat) {struct m} :=
if m - d is m'.+1 then loop m' q.+1 else (q, m).

Definition edivn m d := if d > 0 then edivn_rec d.-1 m 0 else (0, m).

CoInductive edivn_spec (m d : nat) : nat * nat -> Type :=
  | EdivnSpec q r of m = q * d + r & (d > 0) ==> (r < d) : edivn_spec m d (q, r).

(* CoInductive doesn't generate induction principles *)

CoInductive edivn_spec2 (m d : nat) : nat * nat -> Type :=
  | EdivnSpec2 : forall q r, m = q * d + r -> (d > 0 -> r < d) -> edivn_spec2 m d (q, r).

CoInductive edivn_spec3 (m d : nat) : nat * nat -> Type :=
  | EdivnSpec3 q r (H1: m = q * d + r) (H2: d > 0 -> r < d) : edivn_spec3 m d (q, r).

About mulSnr.
Search (?a.+1 + ?b = ?a + ?b.+1).
Lemma edivnP : forall m d, edivn_spec m d (edivn m d).
Proof.
rewrite /edivn => m [|d] //=. rewrite -{1}[m]/(0 * d.+1 + m). (* {1} - rewrite first entry *)
elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn.
rewrite subn_if_gt; case: ltnP => [// | le_dm].
rewrite -{1}(subnK le_dm) -addSn. rewrite addSnnS (addnC (m - d) d.+1) addnA -mulSnr. apply: IHn.
apply: leq_trans le_mn; exact: leq_subr.
Qed.

Lemma edivn_eq : forall d q r, r < d -> edivn (q * d + r) d = (q, r).
Proof.
move=> d q r lt_rd; have d_pos: 0 < d by exact: leq_trans lt_rd.
case: edivnP lt_rd => q' r'; rewrite d_pos /=.
wlog: q q' r r' / q <= q' by case (ltnP q q'); last symmetry; eauto.
rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->.
rewrite -(leq_pmul2r d_pos); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}.
by rewrite addnS ltnNge mulSn -addnA Eqr addnCA addnA leq_addr.
Qed.


Require Import ssr.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** *** Withzero. *)

(* We include a type for a set with a syntactic zero element.
   While this is isomorphic to the option type, having a separate type
   makes notations cleaner and makes our intention more clear.  *)

Section Withzero.

Variable d : eqType.

Inductive withzero (s : Type) : Type := Zero | Nz (x : s).

(* Definition extract x := match x with Nz y => y | _ => t end.  *)

Lemma Nz_inj : forall x y : d, Nz x = Nz y -> x = y.
Proof. congruence. Qed.

Definition eqwithzero (x y : withzero d) :=
  match x,y with
    | Zero, Zero => true
    | Nz x, Nz y => x == y
    | _,_ => false
  end.

Lemma eqwithzeroPx : reflect_eq eqwithzero.
Proof.
 (* {{{ *)
move=> [|x] [|y]; try by [constructor].
case H : (x == y).
  rewrite /= H (eqP H).
  by left.
rewrite /= H.
right.
move=> [H']; by rewrite H' eq_refl in H.
 (* }}} *)
Qed.

Canonical Structure withzeroData := EqType eqwithzeroPx.

End Withzero.

Implicit Arguments Zero [s].


From Undecidability.Shared.Libs.PSL Require Import FinTypes.

(* * Completeness Lemmas for lists of basic types *)

Lemma bool_enum_ok x:
  count  [true; false] x = 1.
Proof.
  simpl. dec; destruct x; congruence.
Qed.

Lemma unit_enum_ok x:
  count [tt] x = 1.
Proof.
  simpl. destruct x; dec; congruence.
Qed.

Lemma Empty_set_enum_ok (x: Empty_set):
  count nil x = 1.
Proof.
  tauto.
Qed.

Lemma True_enum_ok x:
  count [I] x = 1.
Proof.
  simpl; dec;  destruct x; congruence.
Qed.

Lemma False_enum_ok (x: False):
  count nil x = 1.
Proof.
  tauto.
Qed.

(* ** Declaration of finTypeCs for base types as instances of the type class *)

#[global]
Instance finTypeC_Empty_set: finTypeC (EqType Empty_set).
Proof.
  econstructor. eapply Empty_set_enum_ok.
Defined.

#[global]
Instance finTypeC_bool: finTypeC (EqType bool).
Proof.
  econstructor. apply bool_enum_ok.
Defined.

#[global]
Instance finTypeC_unit: finTypeC (EqType unit).
Proof. econstructor. apply unit_enum_ok.
Defined.

(* Instance finTypeC_empty : finTypeC (EqType emptu *)
(* Proof. *)
(*   econstructor. apply Empty_set_enum_ok. *)
(* Defined. *)

#[global]
Instance finTypeC_True : finTypeC (EqType True).
Proof.
  econstructor. apply True_enum_ok.
Defined.

#[global]
Instance  finTypeC_False : finTypeC (EqType False).
Proof.
  econstructor. apply False_enum_ok.
Defined.


Require Export Metalib.Metatheory.
Require Export Ch5.

(*************************************************************************)
(** * Preservation 6.2 *)
(*************************************************************************)

(** *** Exercise
    Complete the proof of preservation.  In this proof, we proceed by
    induction on the given typing derivation.  The induction
    hypothesis has already been appropriately generalized by the given
    proof fragment.
    Proof sketch: By induction on the typing derivation for [e].
      - [typing_var] case: Variables don't step.
      - [typing_op] case: By case analysis on how [e] steps.
      - [typing_let] case: The
        [eval_let_red] case is interesting, since it follows by the
        substitution lemma.  The others follow directly from the
        induction hypotheses.
*)

  (* HINTS:
       - Use [auto] and [eauto], especially with [;], to solve
         "uninteresting" subgoals.
       - Use [inversion] to perform case analyses and to rule out
         impossible cases.
       - In the [eval_let_red] subcase of the [typing_let] case:
          -- Use [inversion] on a typing judgement to obtain a
             hypothesis about when the body of the abstraction is
             well-typed.
          -- Use [subst_intro] to rewrite the [open] operation into an
             [open] followed by a [subst].  You'll need to pick a
             fresh variable first.
  *)

Lemma preservation : forall (E : env) e e' T,
  typing E e T ->
  eval e e' ->
  typing E e' T.
Proof.
  intros E e e' T H.
  generalize dependent e'.
  induction H; intros e' J.
(* EXERCISE *) Admitted.

(*************************************************************************)
(** * Progress *)
(*************************************************************************)

 (** *** Exercise
    Complete the proof of the progress lemma.  The induction
    hypothesis has already been appropriately generalized by the given
    proof fragment.
    Proof sketch: By induction on the typing derivation for [e].
      - [typing_var] case: Can't happen; the empty environment doesn't
        bind anything.
      - [typing_let] case: Always reduces.
      - [typing_op] case: always reduces.  The result follows
        from an exhaustive case analysis on whether the two components
        of the operation step or are values and the fact that a
        value must be a nat.
*)

  (* HINTS:
       - Use [auto] and [eauto], especially with [;], to solve
         "uninteresting" subgoals.
       - Use [inversion] to rule out impossible cases.
       - The lemma [typing_to_lc] will be useful for reasoning
         about local closure.
       - In the [typing_op] case:
          -- Use [destruct] to perform a case analysis on the
             conclusions of the induction hypotheses.
          -- Use [inversion] on a [value] judgement to determine that
             the value must be an abstraction.
  *)

Lemma progress : forall e T,
  typing nil e T ->
  value e \/ exists e', eval e e'.
Proof.
  intros e T H.

  (* It will be useful to have a "non-destructed" form of the given
     typing derivation, since [induction] takes apart the derivation
     it is called on. *)
  assert (typing nil e T); auto.

  (* [remember nil as E] fails here because [nil] takes an implicit
     argument that Coq is unable to infer.  By prefixing [nil] with
     [@], we can supply the argument to nil explicitly. *)
  remember (@nil (atom * typ)) as E.

  induction H; subst.

(* FILL IN HERE (and delete "Admitted") *) Admitted.

(*************************************************************************)
(** * Canonical Forms *)
(*************************************************************************)

(** Exercise: The above proof implicitly reasons about the canonical forms
    of values.  State and prove the canonical forms lemma for this language.
    (Lemma 6.3). *)

(*************************************************************************)
(** * Run-time errors *)
(*************************************************************************)

(** Challenge Exercise:

    Add a division operator and an error term (of any type) to this
    language, as described in Section 6.3. You'll want to start a new
    file from  scratch, starting with the definitions from Section 4.
*)


From Hammer Require Import Hammer.

Require Export BinPos BinInt.
Require Import Lt Gt Plus Mult.

Local Open Scope Z_scope.

Lemma Zcompare_Gt_Lt_antisym : forall n m:Z, (n ?= m) = Gt <-> (m ?= n) = Lt.
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_Gt_Lt_antisym".  exact (Z.gt_lt_iff). Qed.

Lemma Zcompare_antisym n m : CompOpp (n ?= m) = (m ?= n).
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_antisym".  exact (eq_sym (Z.compare_antisym n m)). Qed.

Lemma Zcompare_Lt_trans :
forall n m p:Z, (n ?= m) = Lt -> (m ?= p) = Lt -> (n ?= p) = Lt.
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_Lt_trans".  exact (Z.lt_trans). Qed.

Lemma Zcompare_Gt_trans :
forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt.
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_Gt_trans".
intros n m p. change (n > m -> m > p -> n > p).
Z.swap_greater. intros. now transitivity m.
Qed.

Lemma Zcompare_opp n m : (n ?= m) = (- m ?= - n).
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_opp".
symmetry. apply Z.compare_opp.
Qed.

Lemma Zcompare_Gt_spec n m : (n ?= m) = Gt ->  exists h, n + - m = Zpos h.
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_Gt_spec".
rewrite Z.compare_sub. unfold Z.sub.
destruct (n+-m) as [|p|p]; try discriminate. now exists p.
Qed.

Lemma Zcompare_plus_compat n m p : (p + n ?= p + m) = (n ?= m).
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_plus_compat".
apply Z.add_compare_mono_l.
Qed.

Lemma Zplus_compare_compat (r:comparison) (n m p q:Z) :
(n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r.
Proof. hammer_hook "Zcompare" "Zcompare.Zplus_compare_compat".
rewrite (Z.compare_sub n), (Z.compare_sub p), (Z.compare_sub (n+p)).
unfold Z.sub. rewrite Z.opp_add_distr. rewrite Z.add_shuffle1.
destruct (n+-m), (p+-q); simpl; intros; now subst.
Qed.

Lemma Zcompare_succ_Gt n : (Z.succ n ?= n) = Gt.
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_succ_Gt".
apply Z.lt_gt. apply Z.lt_succ_diag_r.
Qed.

Lemma Zcompare_Gt_not_Lt n m : (n ?= m) = Gt <-> (n ?= m+1) <> Lt.
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_Gt_not_Lt".
change (n > m <-> n >= m+1). Z.swap_greater. symmetry. apply Z.le_succ_l.
Qed.

Lemma Zcompare_succ_compat n m : (Z.succ n ?= Z.succ m) = (n ?= m).
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_succ_compat".
rewrite <- 2 Z.add_1_l. apply Z.add_compare_mono_l.
Qed.

Lemma Zcompare_mult_compat :
forall (p:positive) (n m:Z), (Zpos p * n ?= Zpos p * m) = (n ?= m).
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_mult_compat".
intros p [|n|n] [|m|m]; simpl; trivial; now rewrite Pos.mul_compare_mono_l.
Qed.

Lemma Zmult_compare_compat_l n m p:
p > 0 -> (n ?= m) = (p * n ?= p * m).
Proof. hammer_hook "Zcompare" "Zcompare.Zmult_compare_compat_l".
intros; destruct p; try discriminate.
symmetry. apply Zcompare_mult_compat.
Qed.

Lemma Zmult_compare_compat_r n m p :
p > 0 -> (n ?= m) = (n * p ?= m * p).
Proof. hammer_hook "Zcompare" "Zcompare.Zmult_compare_compat_r".
intros; rewrite 2 (Z.mul_comm _ p); now apply Zmult_compare_compat_l.
Qed.

Lemma Zcompare_elim :
forall (c1 c2 c3:Prop) (n m:Z),
(n = m -> c1) ->
(n < m -> c2) ->
(n > m -> c3) -> match n ?= m with
| Eq => c1
| Lt => c2
| Gt => c3
end.
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_elim".
intros. case Z.compare_spec; trivial. now Z.swap_greater.
Qed.

Lemma Zcompare_eq_case :
forall (c1 c2 c3:Prop) (n m:Z),
c1 -> n = m -> match n ?= m with
| Eq => c1
| Lt => c2
| Gt => c3
end.
Proof. hammer_hook "Zcompare" "Zcompare.Zcompare_eq_case".
intros. subst. now rewrite Z.compare_refl.
Qed.

Lemma Zle_compare :
forall n m:Z,
n <= m -> match n ?= m with
| Eq => True
| Lt => True
| Gt => False
end.
Proof. hammer_hook "Zcompare" "Zcompare.Zle_compare".
intros. case Z.compare_spec; trivial; Z.order.
Qed.

Lemma Zlt_compare :
forall n m:Z,
n < m -> match n ?= m with
| Eq => False
| Lt => True
| Gt => False
end.
Proof. hammer_hook "Zcompare" "Zcompare.Zlt_compare".
intros x y H; now rewrite H.
Qed.

Lemma Zge_compare :
forall n m:Z,
n >= m -> match n ?= m with
| Eq => True
| Lt => False
| Gt => True
end.
Proof. hammer_hook "Zcompare" "Zcompare.Zge_compare".
intros. now case Z.compare_spec.
Qed.

Lemma Zgt_compare :
forall n m:Z,
n > m -> match n ?= m with
| Eq => False
| Lt => False
| Gt => True
end.
Proof. hammer_hook "Zcompare" "Zcompare.Zgt_compare".
intros x y H; now rewrite H.
Qed.

Notation Zcompare_refl := Z.compare_refl (compat "8.3").
Notation Zcompare_Eq_eq := Z.compare_eq (compat "8.3").
Notation Zcompare_Eq_iff_eq := Z.compare_eq_iff (compat "8.3").
Notation Zcompare_spec := Z.compare_spec (compat "8.3").
Notation Zmin_l := Z.min_l (compat "8.3").
Notation Zmin_r := Z.min_r (compat "8.3").
Notation Zmax_l := Z.max_l (compat "8.3").
Notation Zmax_r := Z.max_r (compat "8.3").
Notation Zabs_eq := Z.abs_eq (compat "8.3").
Notation Zabs_non_eq := Z.abs_neq (compat "8.3").
Notation Zsgn_0 := Z.sgn_null (compat "8.3").
Notation Zsgn_1 := Z.sgn_pos (compat "8.3").
Notation Zsgn_m1 := Z.sgn_neg (compat "8.3").


Require Export Base.
Local Unset Universe Polymorphism.

Inductive Acz :=
  acz_of: forall A: Type, (A -> Acz) -> Acz.

Fixpoint acz_eq (A B: Acz): Prop :=
  match A, B with
  | acz_of A f, acz_of B g =>
    (forall a, exists b, acz_eq (f a) (g b)) /\
    (forall b, exists a, acz_eq (f a) (g b))
  end.

Instance acz_equiv: Equivalence acz_eq.
Proof.
  constructor.
  + intros A.
    induction A as [A f IH]; simpl.
    split.
    all: intro a.
    all: exists a.
    all: apply IH.
  + intros A.
    induction A as [A f IH].
    intros [B g] [Hl Hr].
    split.
    1: clear Hl; rename Hr into H.
    2: clear Hr; rename Hl into H.
    all: intros a.
    all: specialize (H a).
    all: destruct H as [b H].
    all: exists b.
    all: apply IH, H.
  + intros A.
    induction A as [A f IH].
    intros [B g] [C h] [AB BA] [BC CB].
    split.
    1: clear BA CB.
    2: clear AB BC; rename BA into BC, CB into AB.
    all: intros a.
    all: specialize (AB a).
    all: destruct AB as [b AB].
    all: specialize (BC b).
    all: destruct BC as [c BC].
    all: exists c.
    all: now apply (IH _ (g b)).
Qed.

Definition acz_in (x X: Acz): Prop :=
  match X with
  | acz_of X f => exists a, acz_eq x (f a)
  end.

Instance acz_in_morph: Proper (acz_eq ==> acz_eq ==> iff) acz_in.
Proof.
  intros x y xy [X f] [Y g] [XY YX].
  simpl.
  split.
  all: intros [a H].
  specialize (XY a).
  destruct XY as [b XY].
  exists b.
  now rewrite <- xy, <- XY.
  specialize (YX a).
  destruct YX as [b YX].
  exists b.
  now rewrite xy, YX.
Qed.

Definition sub_acz (X Y: Acz): Prop :=
  forall z, acz_in z X -> acz_in z Y.

Instance sub_acz_preorder: PreOrder sub_acz.
Proof.
  constructor.
  easy.
  intros X Y Z XY YZ x H.
  apply YZ, XY, H.
Qed.

Instance sub_acz_partialorder: PartialOrder acz_eq sub_acz.
Proof.
  intros [X f] [Y g].
  split; intros [XY YX].
  + split.
    all: intros z [a H].
    1: clear YX.
    2: clear XY; rename YX into XY.
    all: specialize (XY a).
    all: destruct XY as [b XY].
    all: exists b.
    all: now rewrite H.
  + split.
    1: clear YX.
    2: clear XY; rename YX into XY.
    all: intros a.
    1: specialize (XY (f a)).
    2: specialize (XY (g a)).
    all: destruct XY as [b XY].
    1, 3: now exists a.
    all: now exists b.
Qed.

Lemma ain_ind (P: Acz -> Prop):
  Proper (acz_eq ==> iff) P ->
  (forall X, (forall x, acz_in x X -> P x) -> P X) ->
  forall X, P X.
Proof.
  intros morph IH X.
  induction X as [A f H].
  apply IH.
  intros x [a Hx].
  rewrite Hx.
  apply H.
Qed.

Definition acz_empty: Acz := acz_of False (False_rect _).

Definition ɛ_acz: (Acz -> Prop) -> Acz :=
  epsilon (inhabits acz_empty).

Lemma ɛ_acz_correct (P: Acz -> Prop): (exists x, P x) -> P (ɛ_acz P).
Proof. apply epsilon_spec. Qed.

Instance ɛ_acz_ext: Proper (pointwise_relation _ iff ==> eq) ɛ_acz.
Proof.
  intros P Q H.
  f_equal.
  extensionality x.
  apply propositional_extensionality, H.
Qed.

Definition N (X: Acz): Acz := ɛ_acz (acz_eq X).

Lemma acz_eq_N (X: Acz): acz_eq X (N X).
Proof.
  unfold N.
  apply ɛ_acz_correct.
  now exists X.
Qed.

Lemma N_idem (X: Acz): N (N X) = N X.
Proof.
  apply ɛ_acz_ext.
  intros Y.
  split; intro H.
  all: rewrite <- H.
  2: symmetry.
  all: apply acz_eq_N.
Qed.

Lemma acz_N_eq (X Y: Acz): acz_eq X Y <-> N X = N Y.
Proof.
  split.
  + intros H.
    apply ɛ_acz_ext.
    intro x.
    now rewrite H.
  + intros H.
    rewrite acz_eq_N, H.
    symmetry.
    apply acz_eq_N.
Qed.

Structure set: Type := acz_set {
  set_acz: {X | N X = X};
}.

Definition NS (X: Acz): set := acz_set (exist _ (N X) (N_idem X)).

Lemma acz_eq_NS (X: Acz): acz_eq X (proj1_sig (set_acz (NS X))).
Proof. apply acz_eq_N. Qed.

Definition In (X Y: set): Prop := acz_in (proj1_sig (set_acz X)) (proj1_sig (set_acz Y)).

Infix "∈" := In (at level 70).
Notation "x ∉ X" := (~In x X) (at level 70).

Lemma acz_in_set (X Y: set): acz_in (proj1_sig (set_acz X)) (proj1_sig (set_acz Y)) -> X ∈ Y.
Proof. intro H. exact H. Qed.

Lemma acz_in_NS (X Y: Acz): acz_in X Y -> NS X ∈ NS Y.
Proof.
  intro H.
  apply acz_in_set.
  simpl.
  rewrite <- !acz_eq_N.
  exact H.
Qed.

Definition subset (X Y: set): Prop :=
  forall z, z ∈ X -> z ∈ Y.

Infix "⊆" := subset (at level 70).

Instance subset_preorder: PreOrder subset.
Proof.
  constructor.
  easy.
  intros X Y Z XY YZ x H.
  apply YZ, XY, H.
Qed.

Theorem subset_subacz (X Y: set): sub_acz (proj1_sig (set_acz X)) (proj1_sig (set_acz Y)) -> X ⊆ Y.
Proof.
  intros XY z zX.
  apply XY, zX.
Qed.

Instance subset_partialorder: PartialOrder eq subset.
Proof.
  intros X Y.
  split.
  intros H.
  subst Y.
  split; reflexivity.
  intros [XY YX].
  destruct X as [[x Hx]], Y as [[y Hy]].
  f_equal.
  enough (x = y).
  subst y.
  f_equal.
  apply proof_irrelevance.
  rewrite <- Hx, <- Hy.
  apply acz_N_eq.
  apply antisymmetry.
  1: clear YX.
  2: clear XY; rename YX into XY.
  all: intros a H.
  all: rewrite acz_eq_N in H |- *.
  all: exact (XY (NS a) H).
Qed.

Theorem set_eq_ext (X Y: set): (forall z, z ∈ X <-> z ∈ Y) <-> X = Y.
Proof.
  split.
  intros H.
  apply antisymmetry.
  1, 2: intro z.
  1, 2: apply H.
  intros H z.
  now subst Y.
Qed.

Theorem set_acz_eq (X Y: set): acz_eq (proj1_sig (set_acz X)) (proj1_sig (set_acz Y)) -> X = Y.
Proof.
  intros H.
  apply partial_order_equivalence in H.
  destruct H as [XY YX].
  apply antisymmetry.
  all: now apply subset_subacz.
Qed.

Definition index (X: set): { T: Type & T -> set } :=
  match proj1_sig (set_acz X) with
  | acz_of T f => existT _ T (fun a: T => NS (f a))
  end.

Definition set_of (T: Type) (f: T -> set): set :=
  acz_set (exist _ (N (acz_of T (fun a => proj1_sig (set_acz(f a))))) (N_idem _)).

Lemma set_of_index (X: set): set_of (projT1 (index X)) (projT2 (index X)) = X.
Proof.
  apply set_acz_eq.
  unfold index; simpl.
  generalize (proj1_sig (set_acz X)).
  clear X; intros [X f].
  simpl.
  rewrite <- acz_eq_N.
  split.
  all: intros a.
  all: exists a.
  all: symmetry.
  all: apply acz_eq_N.
Qed.

Theorem in_set_of x (T: Type) (f: T -> set): x ∈ set_of T f <-> exists a: T, x = f a.
Proof.
  unfold In.
  simpl.
  rewrite <- acz_eq_N.
  unfold acz_in.
  f_equiv; intro a.
  split.
  apply set_acz_eq.
  intro H.
  now subst x.
Qed.

Theorem in_index (x X: set): x ∈ X <-> exists a: projT1 (index X), x = projT2 (index X) a.
Proof.
  rewrite <- (set_of_index X) at 1.
  apply in_set_of.
Qed.

Lemma set_NS (X: set): exists x: Acz, X = NS x.
Proof.
  destruct X as [[X H]].
  exists X.
  apply set_acz_eq, acz_eq_N.
Qed.

Lemma set_ind (P: set -> Prop):
  (forall X, (forall x, x ∈ X -> P x) -> P X) ->
  forall X, P X.
Proof.
  intros IH X.
  destruct (set_NS X) as [x H].
  subst X.
  revert x.
  apply ain_ind.
  intros X Y XY.
  f_equiv.
  apply set_acz_eq.
  simpl.
  rewrite <- !acz_eq_N.
  exact XY.
  intros X H.
  apply IH.
  intros Y Hx.
  destruct (set_NS Y) as [x H0].
  subst Y.
  apply H.
  rewrite (acz_eq_N x).
  rewrite (acz_eq_N X).
  exact Hx.
Qed.

Definition empty: set := set_of False (False_rect _).
Notation Ø := empty.

Theorem in_empty (x: set): x ∉ Ø.
Proof.
  intro H.
  apply in_set_of in H.
  destruct H as [F _].
  exact F.
Qed.

Theorem not_empty (x: set): x <> Ø <-> exists z, z ∈ x.
Proof.
  split.
  + intros H.
    destruct (dec (forall z, z ∉ x)).
    destruct H.
    symmetry.
    apply antisymmetry.
    1, 2: intros z Hz.
    now apply in_empty in Hz.
    now specialize (n z).
    destruct (dec (exists z, z ∈ x)).
    exact e.
    destruct n.
    intros z Hz.
    destruct n0.
    now exists z.
  + intros [z Hz] H.
    subst x.
    now apply in_empty in Hz.
Qed.

Definition single (x: set): set :=
  set_of True (fun _ => x).

Theorem in_single (z x: set): z ∈ single x <-> z = x.
Proof.
  unfold single.
  rewrite in_set_of.
  split.
  now intros [_ H].
  intros H.
  now exists I.
Qed.

Theorem single_inj (x y: set): single x = single y <-> x = y.
Proof.
  symmetry.
  split.
  all: intros H.
  now subst y.
  rewrite <- set_eq_ext in H.
  specialize H with x.
  rewrite !in_single in H.
  apply proj1 in H.
  now apply H.
Qed.

Theorem single_not_empty (x: set): single x <> Ø.
Proof.
  apply not_empty.
  exists x.
  now apply in_single.
Qed.

Definition upair (X Y: set): set :=
  set_of bool (fun b => if b then X else Y).

Notation "{ x , y }" := (upair x y) (at level 0, x at level 99, y at level 99).

Theorem in_upair (z x y: set): z ∈ {x, y} <-> z = x \/ z = y.
Proof.
  unfold upair.
  rewrite in_set_of.
  split.
  + intros [[] H].
    now left.
    now right.
  + intros [H | H].
    now exists true.
    now exists false.
Qed.

Lemma upair_not_empty (x y: set): upair x y <> Ø.
Proof.
  apply not_empty.
  exists x.
  apply in_upair.
  now left.
Qed.

Lemma upair_refl (x: set): upair x x = single x.
Proof.
  apply set_eq_ext.
  intros z.
  rewrite in_upair, in_single.
  split.
  now intros [H | H].
  intros H.
  now left.
Qed.

Definition union (X: set): set :=
  set_of { a: projT1 (index X) & projT1 (index (projT2 (index X) a))}
  (fun p => projT2 (index (projT2 (index X) (projT1 p))) (projT2 p)).

Notation "∪ X" := (union X) (at level 40).

Theorem in_union (x X: set): x ∈ ∪ X <-> exists y, y ∈ X /\ x ∈ y.
Proof.
  unfold union.
  rewrite in_set_of.
  split.
  + intros [[a b] H].
    simpl in *.
    subst x.
    exists (projT2 (index X) a).
    split.
    all: apply in_index.
    now exists a.
    now exists b.
  + intros [y [yX xy]].
    apply in_index in yX.
    destruct yX as [a Ha].
    subst y.
    apply in_index in xy.
    destruct xy as [b Hb].
    subst x.
    now exists (existT _ a b).
Qed.

Definition union_single (x: set): ∪ (single x) = x.
Proof.
  apply set_eq_ext.
  intros z.
  rewrite in_union.
  setoid_rewrite in_single.
  split.
  + intros [y [Hy Hz]].
    now subst y.
  + intros Hz.
    now exists x.
Qed.

Definition map (f: set -> set) (X: set): set :=
  set_of (projT1 (index X)) (fun a => f (projT2 (index X) a)).

Notation "{ y | x ⋴ X }" := (map (fun x => y) X) (at level 0, y at level 99, x, X at level 89).

Lemma in_map (z: set) (f: set -> set) (X: set): z ∈ { f x | x ⋴ X } <-> exists x, x ∈ X /\ z = f x.
Proof.
  unfold map.
  rewrite in_set_of.
  split.
  + intros [a H].
    subst z.
    exists (projT2 (index X) a).
    split.
    apply in_index.
    now exists a.
    reflexivity.
  + intros [x [xX Hx]].
    subst z.
    apply in_index in xX.
    destruct xX as [a Ha].
    subst x.
    now exists a.
Qed.

Lemma in_map' (z: set) (f: set -> set) (X: set): z ∈ X -> f z ∈ { f x | x ⋴ X}.
Proof.
  intros Hz.
  apply in_map.
  now exists z.
Qed.

Lemma map_id (X: set): {x | x ⋴ X} = X.
Proof.
  apply set_eq_ext.
  intros z.
  rewrite in_map.
  split.
  intros [x [Hx Hz]].
  now subst z.
  intros Hz.
  now exists z.
Qed.

Lemma map_comp (f g: set -> set) (X: set): {f y | y ⋴ {g x | x ⋴ X}} = {f (g x) | x ⋴ X}.
Proof.
  apply antisymmetry.
  + intros z Hz.
    apply in_map in Hz.
    destruct Hz as [y [Hy Hf]].
    apply in_map in Hy.
    destruct Hy as [x [Hx Hg]].
    subst y z.
    apply (in_map' x), Hx.
  + intros z Hz.
    apply in_map in Hz.
    destruct Hz as [x [Hx Hz]].
    subst z.
    apply in_map'.
    apply in_map'.
    exact Hx.
Qed.

Lemma map_single (f: set -> set) (x: set): {f x | x ⋴ single x} = single (f x).
Proof.
  apply set_eq_ext.
  intros z.
  rewrite in_map.
  setoid_rewrite in_single.
  split.
  + intros [y [Hy Hz]].
    now subst y.
  + intros H.
    now exists x.
Qed.

Lemma in_flat_map (z: set) (f: set -> set) (X: set): z ∈ ∪ {f x | x ⋴ X} <-> exists y, y ∈ X /\ z ∈ f y.
Proof.
  split.
  + intros Hz.
    apply in_union in Hz.
    destruct Hz as [v [Hv Hz]].
    apply in_map in Hv.
    destruct Hv as [y [Hy Hv]].
    subst v.
    now exists y.
  + intros [y [Hy Hz]].
    apply in_union.
    exists (f y).
    split.
    apply in_map.
    now exists y.
    exact Hz.
Qed.

Definition sep (P: set -> Prop) (X: set): set :=
  set_of { a: projT1 (index X) | P (projT2 (index X) a) }
  (fun a => projT2 (index X) (proj1_sig a)).

Notation "{ x ⋴ X | P }" := (sep (fun x => P) X) (at level 0, x, X at level 99, P at level 99).

Lemma in_sep (z: set) (P: set -> Prop) (X: set): z ∈ { x ⋴ X | P x } <-> z ∈ X /\ P z.
Proof.
  unfold sep.
  rewrite in_set_of.
  split.
  + intros [[a Pa] H].
    simpl in *.
    subst z.
    split.
    apply in_index.
    now exists a.
    exact Pa.
  + intros [zX Pz].
    apply in_index in zX.
    destruct zX as [a Ha].
    subst z.
    now exists (exist _ a Pz).
Qed.

Definition intersect (X: set) :=
  { x ⋴ ∪ X | forall y, y ∈ X -> x ∈ y}.

Notation "∩ X" := (intersect X) (at level 40).

Lemma in_intersect (z X: set): X <> Ø -> z ∈ ∩ X <-> forall x, x ∈ X -> z ∈ x.
Proof.
  intros HX.
  unfold intersect.
  rewrite in_sep, in_union.
  split.
  now intros [_ H].
  intros Hz.
  split.
  destruct (dec (forall x, x ∉ X)).
  destruct HX.
  apply antisymmetry.
  1, 2: intros x Hx.
  now specialize (n x).
  now apply in_empty in Hx.
  destruct (dec (exists x, x ∈ X)).
  destruct e as [x Hx].
  exists x.
  split.
  exact Hx.
  apply Hz, Hx.
  destruct n.
  intros x Hx.
  destruct n0.
  now exists x.
  exact Hz.
Qed.

Lemma intersect_single (x: set): ∩ single x = x.
Proof.
  apply set_eq_ext.
  intros z.
  rewrite in_intersect.
  2: apply single_not_empty.
  split; intros Hz.
  + now apply Hz, in_single.
  + intros y Hy.
    apply in_single in Hy.
    now subst y.
Qed.

Definition binunion (x y: set) := ∪ {x, y}.
Infix "∪" := binunion (at level 50, left associativity).

Lemma in_binunion (z x y: set): z ∈ x ∪ y <-> z ∈ x \/ z ∈ y.
Proof.
  unfold binunion.
  rewrite in_union.
  setoid_rewrite in_upair.
  split.
  + intros [p [[Hp | Hp] Hz]].
    all: subst p.
    now left.
    now right.
  + intros [Hz | Hz].
    1: exists x.
    2: exists y.
    all: split.
    2, 4: exact Hz.
    now left.
    now right.
Qed.

Definition binintersect (X Y: set) := {x ⋴ X | x ∈ Y}.
Infix "∩" := binintersect (at level 50, left associativity).

Lemma in_binintersect (z x y: set): z ∈ x ∩ y <-> z ∈ x /\ z ∈ y.
Proof.
  unfold binintersect.
  rewrite in_sep.
  reflexivity.
Qed.

Definition diff (X Y: set) := {x ⋴ X | x ∉ Y}.
Infix "\" := diff (at level 50, left associativity).

Lemma in_diff (z X Y: set): z ∈ X \ Y <-> z ∈ X /\ z ∉ Y.
Proof.
  unfold diff.
  rewrite in_sep.
  reflexivity.
Qed.

Definition pow (X: set): set :=
  set_of (projT1 (index X) -> Prop) (fun P => set_of (sig P) (fun p => projT2 (index X) (proj1_sig p))).

Lemma in_pow (z X: set): z ∈ pow X <-> z ⊆ X.
Proof.
  unfold pow.
  rewrite in_set_of.
  split.
  + intros [P H].
    subst z.
    intros z H.
    apply in_set_of in H.
    destruct H as [[a Pa] H].
    subst z.
    apply in_index.
    now exists a.
  + intros H.
    exists (fun a => projT2 (index X) a ∈ z).
    apply antisymmetry.
    - intros x Hx.
      apply in_set_of.
      specialize (H x Hx).
      apply in_index in H.
      destruct H as [a H].
      subst x.
      now exists (exist _ a Hx).
    - intros x Hx.
      apply in_set_of in Hx.
      destruct Hx as [[a Ha] Hx].
      subst x.
      exact Ha.
Qed.

Definition pair (x y: set): set :=
  { single x, { x, y } }.

Lemma in_pair (z x y: set): z ∈ pair x y <-> z = single x \/ z = {x, y}.
Proof. apply in_upair. Qed.

Lemma pair_not_empty (x y: set): pair x y <> Ø.
Proof. apply upair_not_empty. Qed.

Lemma pair_refl (x: set): pair x x = single (single x).
Proof.
  unfold pair.
  rewrite upair_refl.
  apply upair_refl.
Qed.

Lemma pair_inj (x y z v: set): pair x y = pair z v <-> x = z /\ y = v.
Proof.
  symmetry.
  split.
  intros [].
  now subst z v.
  intros H.
  rewrite <- set_eq_ext in H.
  assert (x = z).
  + specialize (H (single x)).
    apply proj1 in H.
    rewrite !in_pair in H.
    specialize (H (or_introl eq_refl)).
    destruct H.
    apply single_inj, H.
    rewrite <- set_eq_ext in H.
    specialize (H x) as Hx.
    apply proj1 in Hx.
    rewrite in_single, in_upair in Hx.
    specialize (Hx eq_refl).
    destruct Hx as [Hx | Hx].
    exact Hx.
    subst v.
    specialize (H z).
    apply proj2 in H.
    rewrite in_single, in_upair in H.
    specialize (H (or_introl eq_refl)).
    now symmetry.
  + split.
    exact H0.
    subst z.
    specialize (H {x, y}) as Hy.
    rewrite !in_pair in Hy.
    apply proj1 in Hy.
    specialize (Hy (or_intror eq_refl)).
    destruct Hy as [Hy | Hy].
    all: rewrite <- set_eq_ext in Hy.
    - specialize (Hy y).
      rewrite in_upair, in_single in Hy.
      apply proj1 in Hy.
      specialize (Hy (or_intror eq_refl)).
      subst y.
      specialize (H {x, v}).
      apply proj2 in H.
      rewrite !in_pair in H.
      specialize (H (or_intror eq_refl)).
      destruct H.
      rewrite <- set_eq_ext in H.
      specialize (H v).
      rewrite in_upair, in_single in H.
      apply proj1 in H.
      specialize (H (or_intror eq_refl)).
      now symmetry.
      rewrite <- set_eq_ext in H.
      specialize (H v).
      rewrite !in_upair in H.
      apply proj1 in H.
      specialize (H (or_intror eq_refl)).
      now destruct H.
    - specialize (Hy y) as H0.
      rewrite !in_upair in H0.
      apply proj1 in H0.
      specialize (H0 (or_intror eq_refl)).
      destruct H0.
      subst y.
      specialize (Hy v).
      rewrite !in_upair in Hy.
      apply proj2 in Hy.
      specialize (Hy (or_intror eq_refl)).
      now destruct Hy.
      exact H0.
Qed.

Lemma union_pair (x y: set): ∪ pair x y = {x, y}.
Proof.
  apply set_eq_ext.
  intros z.
  rewrite in_union, in_upair.
  setoid_rewrite in_pair.
  split.
  + intros [p [[Hp | Hp] Hz]].
    all: subst p.
    left.
    apply in_single, Hz.
    apply in_upair, Hz.
  + intros [H | H].
    all: subst z.
    all: exists {x, y}.
    all: split.
    1, 3: now right.
    all: apply in_upair.
    now left.
    now right.
Qed.

Lemma intersect_pair (x y: set): ∩ pair x y = single x.
Proof.
  apply set_eq_ext.
  intros z.
  rewrite in_intersect, in_single.
  2: apply pair_not_empty.
  setoid_rewrite in_pair.
  split.
  + intros H.
    specialize (H (single x) (or_introl eq_refl)).
    apply in_single, H.
  + intros H p [Hp | Hp].
    all: subst z p.
    now apply in_single.
    apply in_upair.
    now left.
Qed.

Definition cartisian (X Y: set): set :=
  ∪ { { pair x y | y ⋴ Y } | x ⋴ X }.

Lemma in_cartisian (z X Y: set): z ∈ cartisian X Y <-> exists x y, x ∈ X /\ y ∈ Y /\ z = pair x y.
Proof.
  unfold cartisian.
  rewrite in_flat_map.
  setoid_rewrite in_map.
  split.
  + intros [x [Hx [y [Hy H]]]].
    now exists x, y.
  + intros [x [y [Hx [Hy H]]]].
    exists x.
    split.
    exact Hx.
    now exists y.
Qed.

Lemma in_cartisian' (x y X Y: set): pair x y ∈ cartisian X Y <-> x ∈ X /\ y ∈ Y.
Proof.
  rewrite in_cartisian.
  split.
  intros [x' [y' [Hx [Hy H]]]].
  apply pair_inj in H.
  destruct H.
  now subst x' y'.
  intros [Hx Hy].
  now exists x, y.
Qed.

Lemma cartisian_inj (X Y Z V: set): X <> Ø -> Y <> Ø -> cartisian X Y = cartisian Z V <-> X = Z /\ Y = V.
Proof.
  intros HX HY.
  assert (exists x, x ∈ X).
    destruct (dec (forall x, x ∉ X)).
    destruct HX.
    apply antisymmetry.
    1, 2: intros z Hz.
    now destruct (n z).
    now apply in_empty in Hz.
    destruct (dec (exists x, x ∈ X)).
    assumption.
    destruct n.
    intros z Hz.
    destruct n0.
    now exists z.
  assert (exists y, y ∈ Y).
    destruct (dec (forall y, y ∉ Y)).
    destruct HY.
    apply antisymmetry.
    1, 2: intros z Hz.
    now destruct (n z).
    now apply in_empty in Hz.
    destruct (dec (exists y, y ∈ Y)).
    assumption.
    destruct n.
    intros z Hz.
    destruct n0.
    now exists z.
  clear HX HY.
  destruct H as [x HX].
  destruct H0 as [y HY].
  symmetry.
  split.
  intros [].
  now subst Z V.
  intros H.
  rewrite <- set_eq_ext in H.
  assert (x ∈ Z /\ y ∈ V).
    specialize (H (pair x y)).
    rewrite !in_cartisian' in H.
    apply proj1 in H.
    now apply H.
  destruct H0 as [HZ HV].
  split.
  + apply set_eq_ext.
    intros z.
    specialize (H (pair z y)).
    rewrite !in_cartisian' in H.
    split.
    all: intros Hz.
    all: now apply H.
  + apply set_eq_ext.
    intros z.
    specialize (H (pair x z)).
    rewrite !in_cartisian' in H.
    split.
    all: intros Hz.
    all: now apply H.
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Replacement_C.

Coq < Goal forall g h j k l:Prop, (((g /\ h) \/ (g /\ j)) /\ ((g \/ k) -> l)) -> l.
1 subgoal

  ============================
   forall g h j k l : Prop, (g /\ h \/ g /\ j) /\ (g \/ k -> l) -> l

Unnamed_thm < intros.
1 subgoal

  g : Prop
  h : Prop
  j : Prop
  k : Prop
  l : Prop
  H : (g /\ h \/ g /\ j) /\ (g \/ k -> l)
  ============================
   l

Unnamed_thm < elim H.
1 subgoal

  g : Prop
  h : Prop
  j : Prop
  k : Prop
  l : Prop
  H : (g /\ h \/ g /\ j) /\ (g \/ k -> l)
  ============================
   g /\ h \/ g /\ j -> (g \/ k -> l) -> l

Unnamed_thm < intro.
1 subgoal

  g : Prop
  h : Prop
  j : Prop
  k : Prop
  l : Prop
  H : (g /\ h \/ g /\ j) /\ (g \/ k -> l)
  H0 : g /\ h \/ g /\ j
  ============================
   (g \/ k -> l) -> l

Unnamed_thm < intro.
1 subgoal

  g : Prop
  h : Prop
  j : Prop
  k : Prop
  l : Prop
  H : (g /\ h \/ g /\ j) /\ (g \/ k -> l)
  H0 : g /\ h \/ g /\ j
  H1 : g \/ k -> l
  ============================
   l

Unnamed_thm < apply H1.
1 subgoal

  g : Prop
  h : Prop
  j : Prop
  k : Prop
  l : Prop
  H : (g /\ h \/ g /\ j) /\ (g \/ k -> l)
  H0 : g /\ h \/ g /\ j
  H1 : g \/ k -> l
  ============================
   g \/ k

Unnamed_thm < left.
1 subgoal

  g : Prop
  h : Prop
  j : Prop
  k : Prop
  l : Prop
  H : (g /\ h \/ g /\ j) /\ (g \/ k -> l)
  H0 : g /\ h \/ g /\ j
  H1 : g \/ k -> l
  ============================
   g

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
apply H1.
left.
firstorder .

Unnamed_thm is defined

Coq <

*)

Section Replacement_C.
Goal forall g h j k l:Prop, (((g /\ h) \/ (g /\ j)) /\ ((g \/ k) -> l)) -> l.
intros.
elim H.
intro.
intro.
apply H1.
left.
firstorder.
Qed.


(** Entropy is the source of all randomness in an evaluation. The particular
    representation we choose is the Hilbert cube #(ℕ → [0, 1])#. In particular,
    the properties we use on it are that an entropy source can be split into two
    entropy sources through the operations [πL] and [πR], which are defined here
    and axiomatized to be IID in [integration_πL_πR]. When it actually comes to
    using an entropy [σ], it is also convenient to split it into arbitrarily
    many indepent parts, as (π 0 σ), (π 1 σ), ... *)

Require Import Reals.
Require Import utils.

Local Open Scope R.

Definition Entropy := nat -> {r : R | 0 <= r <= 1}.

(** The projection functions don't muck with any real numbers, just shuffle
    indices around. [πL_n] and the like are the exact index shuffling needed for
    [πL] and the like. *)
Definition πL_n : nat -> nat := fun n => (n + n)%nat.
Definition πR_n : nat -> nat := fun n => S (n + n)%nat.

(** [join] is the inverse of projections, that is [σ = join (πL σ) (πR σ)]. This
    is later proved as [join_πL_πR]. This is finally automated in the tactic
    [π_join]. *)
Definition join' {A} (L R : nat -> A) : nat -> A :=
  fun n =>
    if Nat.even n
    then L (Nat.div2 n)
    else R (Nat.div2 n).

Definition πL (σ : Entropy) : Entropy := σ ∘ πL_n.
Definition πR (σ : Entropy) : Entropy := σ ∘ πR_n.
Definition join : Entropy -> Entropy -> Entropy := join'.

Lemma πL_join σL σR : πL (join σL σR) = σL.
Proof.
  extensionality n.
  unfold πL, πL_n, join, join', compose.
  assert (Nat.even (n + n) = true). {
    induction n; simpl; auto.
    replace (n + S n)%nat with (S (n + n)); auto.
  }
  rewrite H.
  f_equal.
  fold (Nat.double n).
  rewrite Nat.double_twice.
  apply Nat.div2_double.
Qed.

Lemma πR_join σL σR : πR (join σL σR) = σR.
Proof.
  extensionality n.
  unfold πR, πR_n, join, join', compose.
  assert (Nat.even (S (n + n)) = false). {
    induction n; simpl; auto.
    replace (n + S n)%nat with (S (n + n)); auto.
  }
  rewrite H.
  f_equal.
  fold (Nat.double n).
  rewrite Nat.double_twice.
  apply Nat.div2_succ_double.
Qed.

Lemma join_πL_πR σ : join (πL σ) (πR σ) = σ.
Proof.
  extensionality n.
  unfold join, join', πL, πR, πL_n, πR_n, compose.
  destruct (Nat.Even_or_Odd n). {
    rewrite (proj2 (Nat.even_spec n)); auto.

    f_equal.
    fold (Nat.double (Nat.div2 n)).
    rewrite <- Div2.even_double; auto.
    apply Even.even_equiv; auto.
  } {
    pose proof (proj2 (Nat.odd_spec n) H).
    rewrite <- Nat.negb_even in H0.
    apply Bool.negb_true_iff in H0.
    rewrite H0.

    f_equal.
    change (S (Nat.double (Nat.div2 n)) = n).
    rewrite <- Div2.odd_double; auto.
    apply Even.odd_equiv; auto.
  }
Qed.

Fixpoint π (n : nat) (σ : Entropy) : Entropy :=
  match n with
  | O => πL σ
  | S n' => π n' (πR σ)
  end.
Arguments π _ _ _ : simpl never.

Fixpoint π_leftover (n : nat) (σ : Entropy) : Entropy :=
  match n with
  | O => σ
  | S n' => π_leftover n' (πR σ)
  end.
Arguments π_leftover _ _ _ : simpl never.

Lemma π_O_join (σl σr : Entropy) : π 0 (join σl σr) = σl.
Proof.
  apply πL_join.
Qed.

Lemma π_S_join (n : nat) (σl σr : Entropy) : π (S n) (join σl σr) = π n σr.
Proof.
  unfold π.
  fold π.
  rewrite πR_join.
  auto.
Qed.

Ltac π_join := repeat rewrite ?π_O_join, ?π_S_join in *.


Require Export Coq.Program.Tactics.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Arith.Arith_base.
Require Export Coq.Relations.Relations.
Require Export Coq.Lists.List.

Import EqNotations.
Import ListNotations.

(***
 *** Ordered Types = Types with a PreOrder
 ***)

Record OType : Type :=
  {
    ot_Type :> Type;
    ot_R : relation ot_Type;
    ot_PreOrder :> PreOrder ot_R
  }.

Instance OType_Reflexive (A:OType) : Reflexive (ot_R A).
Proof.
  destruct A; auto with typeclass_instances.
Qed.

Instance OType_Transitive (A:OType) : Transitive (ot_R A).
Proof.
  destruct A; auto with typeclass_instances.
Qed.

(* The equivalence relation for an OrderedType *)
Definition ot_equiv (A:OType) : relation (ot_Type A) :=
  fun x y => ot_R A x y /\ ot_R A y x.

Instance ot_equiv_Equivalence A : Equivalence (ot_equiv A).
Proof.
  constructor; intro; intros.
  { split; reflexivity. }
  { destruct H; split; assumption. }
  { destruct H; destruct H0; split; transitivity y; assumption. }
Qed.

(***
 *** Commonly-Used Ordered Types
 ***)

(* The ordered type of propositions *)
Program Definition OTProp : OType :=
  {|
    ot_Type := Prop;
    ot_R := Basics.impl;
  |}.
Next Obligation.
  constructor; auto with typeclass_instances.
Qed.

(* The discrete ordered type, where things are only related to themselves *)
Program Definition OTdiscrete (A:Type) : OType :=
  {|
    ot_Type := A;
    ot_R := eq;
  |}.

(* The only ordered type over unit is the discrete one *)
Definition OTunit : OType := OTdiscrete unit.

(* The ordered type of natural numbers using <= *)
Program Definition OTnat : OType :=
  {|
    ot_Type := nat;
    ot_R := le;
  |}.

(* Flip the ordering of an OType *)
Program Definition OTflip (A:OType) : OType :=
  {|
    ot_Type := ot_Type A;
    ot_R := fun x y => ot_R A y x
  |}.
Next Obligation.
  constructor.
  { intro x. reflexivity. }
  { intros x y z; transitivity y; assumption. }
Qed.

(* The pointwise relation on pairs *)
Definition pairR {A B} (RA:relation A) (RB:relation B) : relation (A*B) :=
  fun p1 p2 => RA (fst p1) (fst p2) /\ RB (snd p1) (snd p2).

(* The non-dependent product ordered type, where pairs are related pointwise *)
Program Definition OTpair (A:OType) (B: OType) : OType :=
  {|
    ot_Type := ot_Type A * ot_Type B;
    ot_R := pairR (ot_R A) (ot_R B);
  |}.
Next Obligation.
  constructor.
  { intro p; split; reflexivity. }
  { intros p1 p2 p3 R12 R23; destruct R12; destruct R23; split.
    - transitivity (fst p2); assumption.
    - transitivity (snd p2); assumption. }
Qed.

(* The sort-of pointwise relation on sum types *)
Definition sumR {A B} (RA:relation A) (RB:relation B) : relation (A+B) :=
  fun sum1 sum2 =>
    match sum1, sum2 with
    | inl x, inl y => RA x y
    | inl x, inr y => False
    | inr x, inl y => False
    | inr x, inr y => RB x y
    end.

(* The non-dependent sum ordered type, where objects are only related if they
are both "left"s or both "right"s *)
Program Definition OTsum (A B : OType) : OType :=
  {|
    ot_Type := ot_Type A + ot_Type B;
    ot_R := sumR (ot_R A) (ot_R B)
  |}.
Next Obligation.
  constructor.
  { intro s; destruct s; simpl; reflexivity. }
  { intros s1 s2 s3 R12 R23.
    destruct s1; destruct s2; destruct s3;
      try (elimtype False; assumption); simpl.
    - transitivity o0; assumption.
    - transitivity o0; assumption. }
Qed.

(* NOTE: the following definition requires everything above to be polymorphic *)
(* NOTE: The definition we choose for OTType is actually deep: instead of
requiring ot_Type A = ot_Type B, we could just require a coercion function from
ot_Type A to ot_Type B, which would yield something more like HoTT... though
maybe it wouldn't work unless we assumed the HoTT axiom? As it is, we might need
UIP to hold if we want to use the definition given here... *)
(*
Program Definition OTType : OType :=
  {|
    ot_Type := OType;
    ot_R := (fun A B =>
               exists (e:ot_Type A = ot_Type B),
                 forall (x y:A),
                   ot_R A x y ->
                   ot_R B (rew [fun A => A] e in x)
                        (rew [fun A => A] e in y));
  |}.
*)

(***
 *** The Ordered Type for Functions
 ***)

(* The type of continuous, i.e. Proper, functions between ordered types *)
Record Pfun (A:OType) (B: OType) :=
  {
    pfun_app : ot_Type A -> ot_Type B;
    pfun_Proper :> Proper (ot_R A ==> ot_R B) pfun_app
  }.

Arguments pfun_app [_ _] _ _.
Arguments pfun_Proper [_ _] _ _ _ _.

(* Infix "@" := pfun_app (at level 50). *)

(* The non-dependent function ordered type *)
Definition OTarrow_R (A B : OType) : relation (Pfun A B) :=
  fun f g =>
    forall a1 a2, ot_R A a1 a2 -> ot_R B (pfun_app f a1) (pfun_app g a2).

Program Definition OTarrow (A:OType) (B: OType) : OType :=
  {|
    ot_Type := Pfun A B;
    ot_R := OTarrow_R A B;
  |}.
Next Obligation.
  constructor.
  { intros f; apply (pfun_Proper f). }
  { intros f g h Rfg Rgh a1 a2 Ra. transitivity (pfun_app g a1).
    - apply (Rfg a1 a1). reflexivity.
    - apply Rgh; assumption. }
Qed.

(* Curry a Pfun *)
Program Definition pfun_curry {A B C} (pfun : Pfun (OTpair A B) C)
  : Pfun A (OTarrow B C) :=
  {| pfun_app :=
       fun a =>
         {| pfun_app := fun b => pfun_app pfun (a,b);
            pfun_Proper := _ |};
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros b1 b2 Rb. apply pfun_Proper.
  split; [ reflexivity | assumption ].
Qed.
Next Obligation.
Proof.
  intros a1 a2 Ra b1 b2 Rb; simpl.
  apply pfun_Proper; split; assumption.
Qed.

(* Uncrry a Pfun *)
Program Definition pfun_uncurry {A B C} (pfun : Pfun A (OTarrow B C))
  : Pfun (OTpair A B) C :=
  {| pfun_app :=
       fun ab => pfun_app (pfun_app pfun (fst ab)) (snd ab);
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros ab1 ab2 Rab. destruct Rab as [ Ra Rb ].
  exact (pfun_Proper pfun (fst ab1) (fst ab2) Ra (snd ab1) (snd ab2) Rb).
Qed.

(* Currying and uncurrying of pfuns form an adjunction *)
(* FIXME HERE: figure out the simplest way of stating this adjunction *)

(* OTarrow is right adjoint to OTpair, meaning that (OTarrow (OTpair A B) C) is
isomorphic to (OTarrow A (OTarrow B C)). The following is the first part of this
isomorphism, mapping left-to-right. *)

(* FIXME: could also do a forall type, but need the second type argument, B, to
itself be proper, i.e., to be an element of OTarrow A OType. Would also need a
dependent version of OTContext, below. *)

(***
 *** Notations for Ordered Types
 ***)

Module OTypeNotations.

  Notation "A '-o>' B" :=
    (OTarrow A B) (right associativity, at level 99).
  Notation "A '*o*' B" :=
    (OTpair A B) (left associativity, at level 40).
  Notation "A '+o+' B" :=
    (OTsum A B) (left associativity, at level 50).
  Notation "'~o~' A" :=
    (OTflip A) (right associativity, at level 35).

  Notation "x <o= y" :=
    (ot_R _ x y) (no associativity, at level 70).
  Notation "x =o= y" :=
    (ot_equiv _ x y) (no associativity, at level 70).

  Notation "x @o@ y" :=
    (pfun_app x y) (left associativity, at level 20).

End OTypeNotations.

(***
 *** Lifting Proper Functions to Ordered Terms
 ***)

(* Class stating that the Proper elements of AU can be lifted to AO *)
Class OTLift (AU:Type) (R:relation AU) (AO:OType) : Type :=
  {
    ot_lift : forall (au:AU), Proper R au -> ot_Type AO;
    ot_lift_Proper :
      forall au1 au2 (Rau: R au1 au2) prp1 prp2,
        ot_R AO (ot_lift au1 prp1) (ot_lift au2 prp2);
  }.

Arguments OTLift AU%type R%signature AO.

(* Class stating that the lifting from AU to AO can be undone *)
Class OTLiftInv AU R AO :=
  {
    otLiftInv_Lift :> OTLift AU R AO;
    ot_unlift : ot_Type AO -> AU;
    ot_unlift_Proper : Proper (ot_R AO ==> R) ot_unlift;
    (* FIXME: these don't work for functions, since R could be non-transitive...
    ot_lift_iso1 : forall au prp, R (ot_unlift (ot_lift au prp)) au;
    ot_lift_iso2 : forall au prp, R au (ot_unlift (ot_lift au prp));
     *)
    (* FIXME: are these needed?
    ot_unlift_iso1 : forall ao prp, ot_R AO (ot_lift (ot_unlift ao) prp) ao;
    ot_unlift_iso2 : forall ao prp, ot_R AO ao (ot_lift (ot_unlift ao) prp);
     *)
  }.
(* FIXME: can we summarize the last 4 axioms above in a shorter way...? *)

Arguments OTLiftInv AU%type R%signature AO.

(* Any ordered type can be lifted to itself *)
(* FIXME: are these what we want...? *)
Program Instance OTLift_any_OType A : OTLift (ot_Type A) (ot_R A) A :=
  {| ot_lift := fun a _ => a; |}.
Program Instance OTLiftInv_any_OType A : OTLiftInv (ot_Type A) (ot_R A) A :=
  {| ot_unlift := fun a => a; |}.
Next Obligation.
  intros a1 a2 Ra; assumption.
Qed.

(* Any PreOrder gets an OTLift instance *)
Program Instance OTLift_PreOrder A R (po:@PreOrder A R) :
  OTLift A R {| ot_Type := A; ot_R := R; ot_PreOrder := po |} :=
  Build_OTLift
    A R {| ot_Type := A; ot_R := R; ot_PreOrder := po |}
    (fun a _ => a) _.

(* Any PreOrder gets an OTLiftInv instance *)
Program Instance OTLiftInv_PreOrder A R (po:@PreOrder A R) :
  OTLiftInv A R {| ot_Type := A; ot_R := R; ot_PreOrder := po |} :=
  {|
    ot_unlift := fun a => a;
  |}.
Next Obligation.
  intros a1 a2 Ra; assumption.
Qed.

(* Pairs can be lifted if their components can be lifted *)
Program Instance OTLift_pair A RA AO B RB BO
        `{OTLift A RA AO} `{OTLift B RB BO}
  : OTLift (A*B) (pairR RA RB) (OTpair AO BO) :=
  {|
    ot_lift := fun p prp =>
                 (ot_lift (fst p) (proj1 prp), ot_lift (snd p) (proj2 prp));
  |}.
Next Obligation.
  destruct Rau; split; apply ot_lift_Proper; assumption.
Qed.

(* Pairs can be unlifted if their components can be unlifted *)
Program Instance OTLiftInv_pair A RA AO B RB BO
        `{OTLiftInv A RA AO} `{OTLiftInv B RB BO}
  : OTLiftInv (A*B) (pairR RA RB) (OTpair AO BO) :=
  {|
    ot_unlift := fun p => (ot_unlift (fst p), ot_unlift (snd p));
  |}.
Next Obligation.
  intros p1 p2 Rp; destruct Rp; split; apply ot_unlift_Proper; assumption.
Qed.
(*
Next Obligation.
  destruct prp; split; apply ot_unlift_iso1.
Qed.
Next Obligation.
  destruct prp; split; apply ot_unlift_iso2.
Qed.
 *)

(* Functions can be lifted if their inputs can be unlifted *)
Program Instance OTLift_fun A RA AO B RB BO
        `{OTLiftInv A RA AO} `{OTLift B RB BO}
  : OTLift (A -> B) (RA ==> RB) (OTarrow AO BO) :=
  {|
    ot_lift :=
      fun f prp => {| pfun_app :=
                        fun a => ot_lift (f (ot_unlift a)) _;
                      pfun_Proper := _ |};
  |}.
Next Obligation.
  apply prp. apply ot_unlift_Proper. reflexivity.
Qed.
Next Obligation.
  intros a1 a2 Ra. apply ot_lift_Proper. apply prp.
  apply ot_unlift_Proper. assumption.
Qed.
Next Obligation.
  intros a1 a2 Ra. apply ot_lift_Proper. apply Rau.
  apply ot_unlift_Proper. assumption.
Qed.

(* Anything is Proper w.r.t. a pre-order *)
Instance Proper_PreOrder `{PreOrder} x : Proper R x :=
  PreOrder_Reflexive x.

(* Functions can be unlifted if their input types are PreOrders *)
Program Instance OTLiftInv_fun A RA (po:@PreOrder A RA) B RB BO
        `{OTLiftInv B RB BO}
  : OTLiftInv (A -> B) (RA ==> RB)
              (OTarrow (Build_OType A RA po) BO) :=
  {|
    ot_unlift := fun pf a => ot_unlift (pfun_app pf (ot_lift a _));
  |}.
Next Obligation.
  auto with typeclass_instances.
Qed.
(*
Next Obligation.
  unfold Proper. reflexivity.
Qed.
*)
Next Obligation.
  intros pf1 pf2 Rpf a1 a2 Ra. apply ot_unlift_Proper. apply Rpf. assumption.
Qed.
(*
Next Obligation.
  intros a1 a2 Ra. transitivity (pfun_app ao a1).
  apply ot_unlift_iso1. apply pfun_Proper; assumption.
Qed.
Next Obligation.
  intros a1 a2 Ra. simpl. transitivity (pfun_app ao a2).
  apply pfun_Proper; assumption. apply ot_unlift_iso2.
Qed.
 *)

(***
 *** Building Proper Instance for Lambdas
 ***)

(* Helper class for proving Proper relations on lambdas *)
Class ProperH {A} (R:relation A) (x y : A) :=
  properH : R x y.

Arguments ProperH {A%type} R%signature x y.

(* If the lhs and rhs are the same, we can use a normal Proper instance *)
Instance ProperH_Proper `{Proper} : ProperH R m m := proper_prf (R:=R).

(* Wrappers for variables, so the typeclass resolution can see pf *)
Definition PH_varL {A} (R:relation A) (xl xr:A) (pf:R xl xr) := xl.
Definition PH_varR {A} (R:relation A) (xl xr:A) (pf:R xl xr) := xr.

(* Proving ProperH for variables is now easy using PH_varL and PH_varR *)
Instance ProperH_var {A} R (xl xr:A) pf :
  ProperH R (PH_varL R xl xr pf) (PH_varR R xl xr pf) := pf.

(* To prove Proper-ness for a lambda, we construct PH_vars for it *)
Instance ProperH_lambda {A B RA RB} (fL fR:A -> B)
         (H: forall xl xr pf,
             ProperH RB (fL (PH_varL RA xl xr pf)) (fR (PH_varR RA xl xr pf))) :
  ProperH (RA ==> RB) (fun x => fL x) (fun x => fR x) | 2.
  exact H.
Qed.

(* Proper-ness instance for applications; note that RA will in general be an
existential variable, because it is not determined by the goal formula here. *)
Instance ProperH_app A RA {B RB} (fL fR: A -> B) argL argR :
  ProperH (RA ==> RB) fL fR -> ProperH RA argL argR ->
  ProperH RB (fL argL) (fR argR).
Proof.
  intros prp1 prp2. apply prp1. assumption.
Qed.

(* Proper-ness instance for pfun applications *)
Instance ProperH_pfun_app {A B} (fL fR: OTarrow A B) argL argR :
  ProperH (ot_R (OTarrow A B)) fL fR -> ProperH (ot_R A) argL argR ->
  ProperH (ot_R B) (pfun_app fL argL) (pfun_app fR argR).
Proof.
  intros prp1 prp2. apply prp1. assumption.
Qed.

(* Helper wrapper for ot_lift *)
Definition mkOTerm `{OTLift} (trm:AU)
           `{prp:ProperH _ R trm trm} : ot_Type AO :=
  ot_lift trm properH.

Arguments mkOTerm {AU%type} {R%signature} {AO H} trm {prp}.

(***
 *** Proper Instances for Standard Operations
 ***)

(* Proper instance for fst *)
Instance Proper_fst A B : Proper (ot_R (OTpair A B) ==> ot_R A) fst.
Proof.
  intros p1 p2 Rp; destruct Rp. assumption.
Qed.

(* Proper instance for snd *)
Instance Proper_snd A B : Proper (ot_R (OTpair A B) ==> ot_R B) snd.
Proof.
  intros p1 p2 Rp; destruct Rp. assumption.
Qed.

(* Proper instance for pair *)
Instance Proper_pair (A B:OType) :
  Proper (ot_R A ==> ot_R B ==> ot_R (OTpair A B)) pair.
Proof.
  intros a1 a2 Ra b1 b2 Rb; split; assumption.
Qed.

(***
 *** Examples of Ordered Terms
 ***)

Module OTExamples.
Import OTypeNotations.

Definition ex1 : ot_Type (OTProp -o> OTProp) := mkOTerm (fun p => p).
Print ex1.

Goal (OTLift (Prop -> Prop)
             (ot_R OTProp ==> ot_R OTProp)
             (OTProp -o> OTProp)).
  auto with typeclass_instances.
Qed.

Goal (OTLift (Prop -> Prop -> Prop)
             (ot_R OTProp ==> ot_R OTProp ==> ot_R OTProp)
             (OTProp -o> OTProp -o> OTProp)).
  auto with typeclass_instances.
Qed.

Goal (ProperH (ot_R OTProp ==> ot_R OTProp ==> ot_R OTProp)
              (fun p1 p2 => p1) (fun p1 p2 => p1)).
  auto with typeclass_instances.
Qed.

Goal ({R:_ & OTLift (ot_Type OTProp -> ot_Type OTProp -> ot_Type OTProp)
                    R (OTProp -o> OTProp -o> OTProp)}).
  eapply existT.
  auto with typeclass_instances.
Qed.

Goal ({R:_
         & OTLift (OTProp -> OTProp -> OTProp)
                  R (OTProp -o> OTProp -o> OTProp)
         & ProperH R (fun p1 p2 => p1) (fun p1 p2 => p1)
          }).
  eapply existT2.
  auto with typeclass_instances.
  auto with typeclass_instances.
Qed.

Definition ex2 : OTProp -o> OTProp -o> OTProp :=
  mkOTerm (R:=_ ==> _ ==> _) (fun p1 p2 => p1).
Eval compute in (ot_unlift ex2 : Prop -> Prop -> Prop).

Definition ex3 {A B} : A *o* B -o> A :=
  mkOTerm (R:= _ ==> _) fst.
Eval compute in (ot_unlift (@ex3 OTProp OTProp) : Prop * Prop -> Prop).

Definition ex4 {A B} : A *o* B -o> B *o* A :=
  mkOTerm (R:= _ ==> _) (fun p => (snd p, fst p)).
Eval compute in (ot_unlift (@ex4 OTProp OTProp) : Prop * Prop -> Prop * Prop).

Goal (ex2 <o= ex2). reflexivity. Qed.
Goal (forall {A B}, ex4 (A:=A) (B:=B) <o= ex4). intros. reflexivity. Qed.

Goal (OTLift ((OTProp -o> OTProp) -> OTProp -> OTProp)
             (ot_R (OTProp -o> OTProp) ==> ot_R OTProp ==> ot_R OTProp)
             ((OTProp -o> OTProp) -o> OTProp -o> OTProp)).
  auto with typeclass_instances.
Qed.

Goal ({R:_
         & OTLift ((OTProp -o> OTProp) -> OTProp -> OTProp)
                  R ((OTProp -o> OTProp) -o> OTProp -o> OTProp)
         & ProperH R (fun f a => f @o@ a) (fun f a => f @o@ a)
          }).
  eapply existT2.
  auto with typeclass_instances.
  auto with typeclass_instances.
Qed.

Goal (forall {A B},
         {R:_
            & OTLift ((A -o> B) -> A -> B)
                     R ((A -o> B) -o> A -o> B)
            & ProperH R (fun f a => f @o@ a) (fun f a => f @o@ a)
          }).
  intros; eapply existT2.
  auto with typeclass_instances.
  auto with typeclass_instances.
Defined.
Print Unnamed_thm8.

Goal (forall {A B},
         ProperH (ot_R (A -o> B) ==> ot_R A ==> ot_R B)
                 (fun (f : A -o> B) (a : A) => f @o@ a)
                 (fun (f : A -o> B) (a : A) => f @o@ a)).
  intros. auto with typeclass_instances.
Qed.
Print Unnamed_thm9.

Definition ex5 {A B} : (A -o> B) -o> A -o> B :=
  mkOTerm
          (fun f a => f @o@ a)
.

Eval compute in (ot_unlift (@ex4 OTProp OTProp) : Prop * Prop -> Prop * Prop).

End OTExamples.