(** * ∑-categories - exploded Grothendieck constructions, or generalizations of subcategories *)
Require Import Category.Core Functor.Core.
Require Import Basics.Trunc Types.Sigma.

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

Local Notation sigT_type := sigT.

(** We can generalize the notion of [sigT] to categories.  This is, essentially, a type-theoretic perspecitive on the Grothendieck construction. *)

Section sigT_obj_mor.
  Variable A : PreCategory.
  Variable Pobj : A -> Type.

  Local Notation obj := (sigT Pobj).

  Variable Pmor : forall s d : obj, morphism A s.1 d.1 -> Type.

  Local Notation mor s d := (sigT (Pmor s d)).
  Context `(HPmor : forall s d, IsHSet (mor s d)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x.1; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Hypothesis P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).

  Hypothesis P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.

  Hypothesis P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.

  (** ** Definition of a [sigT]-precategory *)
  Definition sigT : PreCategory.
  Proof.
    refine (@Build_PreCategory
              obj
              (fun s d => mor s d)
              (fun x => identity x)
              (fun s d d' m1 m2 => compose m1 m2)
              _
              _
              _
              _);
    assumption.
  Defined.

  (** ** First projection functor *)
  Definition pr1 : Functor sigT A
    := Build_Functor
         sigT A
         (@pr1 _ _)
         (fun _ _ => @pr1 _ _)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).
End sigT_obj_mor.

Arguments pr1 {A Pobj Pmor HPmor Pidentity Pcompose P_associativity P_left_identity P_right_identity}.

(** ** Variant of [sigT]-precategory when we are taking a subset of morphisms *)
Section sigT_obj_mor_hProp.
  Variable A : PreCategory.
  Variable Pobj : A -> Type.

  Local Notation obj := (sigT_type Pobj).

  Variable Pmor : forall s d : obj, morphism A s.1 d.1 -> Type.

  Local Notation mor s d := (sigT_type (Pmor s d)).
  Context `(HPmor : forall s d m, IsHProp (Pmor s d m)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x.1; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Local Ltac t ex_tac :=
    intros;
    simpl;
    apply path_sigma_uncurried;
    simpl;
    ex_tac;
    apply path_ishprop.

  Let P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).
  Proof.
    abstract t ltac:(exists (associativity _ _ _ _ _ _ _ _))
      using P_associativity_core_subproof.
  Defined.

  Let P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.
  Proof.
    clear P_associativity.
    abstract t ltac:(exists (left_identity _ _ _ _))
      using P_left_identity_core_subproof.
  Defined.

  Let P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.
  Proof.
    clear P_associativity P_left_identity.
    abstract t ltac:(exists (right_identity _ _ _ _))
      using P_right_identity_core_subproof.
  Defined.

  (** *** Definition of [sig]-precategory *)
  Definition sig : PreCategory
    := Eval cbv delta [P_associativity P_left_identity P_right_identity]
      in @sigT A Pobj Pmor _ Pidentity Pcompose P_associativity P_left_identity P_right_identity.

  (** *** First projection functor *)
  Definition proj1_sig : Functor sig A
    := pr1.
End sigT_obj_mor_hProp.

Arguments proj1_sig {A Pobj Pmor HPmor Pidentity Pcompose}.

Notation subcategory := sig.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(****************************************************************************)
(*                                                                          *)
(*  Proof of the three gap theorem.                                         *)
(*                                                                          *)
(*  Micaela Mayero (INRIA-Rocquencourt)                                     *)
(*  September 1998                                                          *)
(*                                                                          *)
(****************************************************************************)
(****************************************************************************)
(*                               three_gap.v                                *)
(****************************************************************************)

(*********************************************************)
(*                 THE THREE GAP THER0EM                 *)
(*                                                       *)
(*********************************************************)

Require Export preuve2.
(*********************************************************)

Section gap.
Variable N n : nat.
Hypothesis alpha_irr : forall n p : Z, (alpha * IZR p)%R <> IZR n.
Hypothesis prop_alpha : (0 < alpha)%R /\ (alpha < 1)%R.
Hypothesis prop_N : forall N : nat, N >= 2.
Hypothesis Hn : 0 < n /\ n < N.

(*********)
Definition succes := after N n.

(*********)
Definition num1 := n + first N.
Definition num2 := n + first N - last N.
Definition num3 := n - last N.

(*********************************************************)
(*                 Theorem                               *)
(*********************************************************)

(**********)
Theorem three_gap : succes = num1 \/ succes = num2 \/ succes = num3.

generalize (inser2_trans_lt 0 n (last N) (N - first N) N Hn).
intro; elim H; intros.
elim a; intros y0; elim y0; intros.
left; apply (three_gap1 alpha_irr prop_alpha prop_N N n H0 H1).
right; left; apply (three_gap2 alpha_irr prop_alpha prop_N N n H0 H1).
elim b; intros.
right; right; apply (three_gap3 alpha_irr prop_alpha prop_N N n H0 H1).
Qed.

End gap.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Coq - Calculus of Inductive Constructions V5.10           *)
(*****************************************************************************)
(*                                                                           *)
(*          The Functor Category                                             *)
(*                                                                           *)
(*          Amokrane Saibi,  May 1994                                        *)
(*                                                                           *)
(*****************************************************************************)

Require Export Ntransformation.
Require Export Category_dup2.

Set Implicit Arguments.
Unset Strict Implicit.

(* Functor Category *)

Section cat_functor.

Variable C D : Category.

 Section compnt.

 Variables (F G H : Functor C D) (T : NT F G) (T' : NT G H).

 Definition Comp_tau (a : C) := T a o T' a.

 Lemma Comp_tau_nt_law : NT_law Comp_tau.
 Proof.
 unfold Comp_tau in |- *; unfold NT_law in |- *.
 intros a b f.
 (* F(f)o((tauFG b)o(tauGH b)) = ((tauFG a)o(tauGH a))oH(f) *)
 (* *) apply Trans with ((FMor F f o T b) o T' b).
 (* F(f)o((T b)o(T' b)) = (F(f)o(T b))o(T' b) *)
 apply Ass.
 (* (F(f)o(T' b))o(T' b) = ((T a)o(T' a))oH(f) *)
 (* *) apply Trans with ((T a o FMor G f) o T' b).
 (* (F(f)o(T' b))o(T' b) = ((T a)oG(f))o(T' b) *)
 apply Comp_r; apply NatCond.
 (*  ((T a)oG(f))o(T' b) = ((T a)o(T' a))oH(f) *)
 (* *) apply Trans with (T a o FMor G f o T' b).
 (* ((T a)oG(f))o(T' b) = (T a)o(G(f)o(T' b)) *)
 apply Ass1.
 (* (T a)o(G(f)o(T' b)) = ((T a)o(T' a))oH(f) *)
 (* *) apply Trans with (T a o T' a o FMor H f).
 (* (T a)o(G(f)o(T' b)) = (T a)o((T' a)oH(f)) *)
 (* G(f)o(T' b) = (T' a)oH(f) *)
 apply Comp_l; apply NatCond.
 (* (T a)o(G(f)o(T' b)) = ((T a)o(G(f))o(T' b) *)
 apply Ass.
 Qed.

 Canonical Structure CompV_NT : NT_setoid F H := Comp_tau_nt_law.

 End compnt.

Lemma CompV_NT_congl : Congl_law'' CompV_NT.
Proof.
unfold Congl_law'' in |- *; simpl in |- *.
unfold Equal_NT, CompV_NT in |- *; simpl in |- *.
intros F G H T1 T2 T3 eqT1_T2 a; unfold Comp_tau in |- *.
apply Comp_l; apply eqT1_T2.
Qed.

Lemma CompV_NT_congr : Congr_law'' CompV_NT.
Proof.
unfold Congr_law'' in |- *; simpl in |- *.
unfold Equal_NT, CompV_NT in |- *; simpl in |- *.
intros F G H T1 T2 T3 eqT1_T2 a; unfold Comp_tau in |- *.
apply Comp_r; apply eqT1_T2.
Qed.

Definition Comp_CatFunct := Build_Comp'' CompV_NT_congl CompV_NT_congr.

Lemma Assoc_CatFunct : Assoc_law'' Comp_CatFunct.
Proof.
unfold Assoc_law'' in |- *; intros a b c f.
intros T1 T2 T3.
unfold Cat_comp'', Ap2'' in |- *; simpl in |- *.
unfold Equal_NT, CompV_NT in |- *; simpl in |- *.
intro x; unfold Comp_tau in |- *; simpl in |- *.
apply Ass.
Qed.

(* Id *)

 Section id_catfunct_def.

 Variable F : Functor C D.

 Definition Id_CatFunct_tau (a : C) := Id (F a).

 Lemma Id_CatFunct_nt_law : NT_law Id_CatFunct_tau.
 Proof.
 unfold NT_law, Id_CatFunct_tau in |- *; intros a b f.
 (* *) apply Trans with (FMor F f).
 apply Idr1.
 apply Idl1.
 Qed.

 Canonical Structure Id_CatFunct := Build_NT Id_CatFunct_nt_law.

 End id_catfunct_def.

Lemma Idl_CatFunct : Idl_law'' Comp_CatFunct Id_CatFunct.
Proof.
red in |- *; simple induction f.
unfold Comp_CatFunct in |- *; unfold Id_CatFunct in |- *; simpl in |- *.
unfold Equal_NT in |- *; simpl in |- *.
unfold Comp_tau in |- *; simpl in |- *.
unfold Id_CatFunct_tau in |- *; intros.
apply Idl.
Qed.

Lemma Idr_CatFunct : Idr_law'' Comp_CatFunct Id_CatFunct.
Proof.
red in |- *; simple induction f.
unfold Comp_CatFunct in |- *; unfold Id_CatFunct in |- *; simpl in |- *.
unfold Equal_NT in |- *; simpl in |- *.
unfold Comp_tau in |- *; simpl in |- *.
unfold Id_CatFunct_tau in |- *; intros.
apply Idr.
Qed.

Canonical Structure FUNCT :=
  Build_Category'' Assoc_CatFunct Idl_CatFunct Idr_CatFunct.

End cat_functor.

Infix "o_NTv" := CompV_NT (at level 20, right associativity).


From Coq Require Import Arith Psatz Bool String List Nat Program.Equality.
Add LoadPath "./" as DanTrick.
Require Import DanTrick.DanTrickLanguage
  DanTrick.LogicProp
  DanTrick.DanLogicHelpers
  DanTrick.DanLogProp
  DanTrick.DanLogSubst .

Definition triple_Dan (P: AbsEnv) (i: imp_Dan) (Q: AbsEnv) (fenv: fun_env) : Prop :=
  forall dbenv nenv nenv',
  i_Dan i dbenv fenv nenv nenv' ->
  AbsEnv_rel P fenv dbenv nenv ->
  AbsEnv_rel Q fenv dbenv nenv'.

Definition atrueDan (b: bexp_Dan) (P: AbsEnv): AbsEnv :=
  (AbsEnvAnd P (AbsEnvLP (Dan_lp_bool (UnaryProp _ _
                                            (fun bval => bval = true)
                                            b)))).

Definition afalseDan (b: bexp_Dan) (P: AbsEnv): AbsEnv :=
  (AbsEnvAnd P (AbsEnvLP (Dan_lp_bool (UnaryProp _ _
                                            (fun bval => bval = false)
                                            b)))).

Definition aimpDan (P Q: AbsEnv) (fenv: fun_env): Prop :=
  forall dbenv nenv,
    AbsEnv_rel P fenv dbenv nenv -> AbsEnv_rel Q fenv dbenv nenv.

Definition aandDan (P Q: assertion): assertion :=
  fun dbenv nenv => P dbenv nenv /\ Q dbenv nenv.

Notation "P -->> Q" := (aimpDan P Q) (at level 95, no associativity).

Inductive hl_Dan : AbsEnv -> imp_Dan -> AbsEnv -> fun_env -> Type :=
| hl_Dan_skip :
  forall P fenv,
    hl_Dan P SKIP_Dan P fenv
| hl_Dan_assign :
  forall P fenv x a,
    hl_Dan (subst_AbsEnv x a P) (ASSIGN_Dan x a) P fenv
| hl_Dan_seq :
  forall P Q R i1 i2 fenv,
    hl_Dan P i1 R fenv ->
    hl_Dan R i2 Q fenv ->
    hl_Dan P (SEQ_Dan i1 i2) Q fenv
| hl_Dan_if :
  forall P Q b i1 i2 fenv,
    hl_Dan (atrueDan b P) i1 Q fenv ->
    hl_Dan (afalseDan b P) i2 Q fenv ->
    hl_Dan P (IF_Dan b i1 i2) Q fenv
| hl_Dan_while :
  forall P b i fenv,
    hl_Dan (atrueDan b P) i P fenv ->
    hl_Dan P (WHILE_Dan b i) (afalseDan b P) fenv
| hl_Dan_consequence :
  forall P Q P' Q' c fenv,
    hl_Dan P c Q fenv ->
    (P' -->> P) fenv->
    (Q -->> Q') fenv ->
    hl_Dan P' c Q' fenv.

Lemma Hoare_Dan_consequence_pre :
  forall P P' Q i fenv,
    hl_Dan P i Q fenv ->
    (P' -->> P) fenv ->
    hl_Dan P' i Q fenv.
Proof.
  intros.
  eapply hl_Dan_consequence; try apply H; unfold aimpDan; eauto.
Qed.

Lemma Hoare_Dan_consequence_post :
  forall P Q Q' i fenv,
    hl_Dan P i Q fenv ->
    (Q -->> Q') fenv ->
    hl_Dan P i Q' fenv.
Proof.
  intros.
  eapply hl_Dan_consequence; try apply H; unfold aimpDan; eauto.
Qed.

Lemma Hoare_Dan_ifthen :
  forall b i P Q fenv,
    hl_Dan (atrueDan b P) i Q fenv ->
    ((afalseDan b P) -->> Q) fenv ->
    hl_Dan P (IF_Dan b i SKIP_Dan) Q fenv.
Proof.
  intros. apply (hl_Dan_if P Q b i SKIP_Dan fenv); eauto.
  apply Hoare_Dan_consequence_pre with Q.
  - auto using hl_Dan_skip.
  - assumption.
Qed.

Lemma triple_Dan_skip :
  forall P fenv,
    triple_Dan P SKIP_Dan P fenv.
Proof.
unfold triple_Dan. intros. inversion H. subst. eauto.
Qed.

Lemma triple_Dan_assign :
  forall P x a fenv,
  triple_Dan (subst_AbsEnv x a P) (ASSIGN_Dan x a) P fenv.
Proof.
unfold triple_Dan. intros. inversion H. subst.
pose proof (aupdate_subst_equiv P fenv dbenv nenv a n x H7 H0).
unfold aupdate in H1. apply H1. eauto.
Qed.

Lemma triple_Dan_seq :
  forall P Q R i1 i2 fenv,
    triple_Dan P i1 Q fenv ->
    triple_Dan Q i2 R fenv ->
    triple_Dan P (SEQ_Dan i1 i2) R fenv.
Proof.
  unfold triple_Dan. intros.
  inversion H1. subst.
  pose proof (H dbenv nenv nenv'0 H5 H2).
  pose proof (H0 dbenv nenv'0 nenv' H10 H3).
  eauto.
Qed.

Lemma triple_Dan_ifthenelse :
  forall P Q b (i1 i2 : imp_Dan) fenv,
    triple_Dan (atrueDan b P) i1 Q fenv ->
    triple_Dan (afalseDan b P) i2 Q fenv ->
    triple_Dan P (IF_Dan b i1 i2) Q fenv.
Proof.
  unfold triple_Dan. intros. inversion H1; subst.
  - pose proof (H dbenv nenv nenv' H11). apply H3.
    unfold atrueDan. apply AbsEnv_and; eauto.
    apply AbsEnv_leaf. apply Dan_lp_rel_bool.
    eapply RelUnaryProp. apply H10. eauto.
  - pose proof (H0 dbenv nenv nenv' H11). apply H3.
    unfold afalseDan. apply AbsEnv_and; eauto.
    apply AbsEnv_leaf. apply Dan_lp_rel_bool.
    eapply RelUnaryProp. apply H10. eauto.
Qed.

Lemma triple_Dan_while :
  forall P b l fenv,
  triple_Dan (atrueDan b P) l P fenv ->
  triple_Dan P (WHILE_Dan b l) (afalseDan b P) fenv.
Proof.
  unfold triple_Dan. intros P b c fenv T db s s' E.
  dependent induction E; intros.
  - unfold afalseDan.  apply AbsEnv_and; eauto.
  apply AbsEnv_leaf. apply Dan_lp_rel_bool.
  eapply RelUnaryProp. apply H. eauto.
  - eapply IHE2; eauto. apply T with nenv; eauto. unfold atrueDan.
    apply AbsEnv_and; eauto.
    apply AbsEnv_leaf. apply Dan_lp_rel_bool.
    eapply RelUnaryProp. apply H. eauto.
Qed.

Lemma triple_Dan_consequence :
  forall P Q P' Q' i fenv,
    triple_Dan P i Q fenv ->
    (P' -->> P) fenv ->
    (Q -->> Q') fenv ->
    triple_Dan P' i Q' fenv.
Proof.
  unfold triple_Dan, aimpDan; intros. eauto.
Qed.

Theorem Hoare_Dan_sound :
  forall P i Q fenv,
    hl_Dan P i Q fenv ->
    triple_Dan P i Q fenv.
Proof.
  induction 1;
    eauto using triple_Dan_skip, triple_Dan_assign, triple_Dan_seq, triple_Dan_ifthenelse, triple_Dan_while, triple_Dan_consequence.
Qed.


(** The second isomorphism theorem [isomorphic_second_isomorphism]. *)

Require Import
  HoTT.HSet
  HoTT.HIT.quotient
  HoTT.Classes.interfaces.canonical_names
  HoTT.Classes.theory.ua_isomorphic
  HoTT.Classes.theory.ua_subalgebra
  HoTT.Classes.theory.ua_quotient_algebra.

Import
  algebra_notations
  quotient_algebra_notations
  subalgebra_notations
  isomorphic_notations.

Local Notation i := (hom_inc_subalgebra _ _).

(** This section defines [cong_trace] and proves that it is a
    congruence, the restriction of a congruence to a subalgebra. *)

Section cong_trace.
  Context
    {σ : Signature} {A : Algebra σ}
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}
    (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}.

  Definition cong_trace (s : Sort σ) (x : (A&&P) s) (y : (A&&P) s)
    := Φ s (i s x) (i s y).

  Global Instance equiv_rel_trace_congruence (s : Sort σ)
    : EquivRel (cong_trace s).
  Proof.
    unfold cong_trace.
    constructor.
    - intros [y Y]. reflexivity.
    - intros [y1 Y1] [y2 Y2] S. by symmetry.
    - intros [y1 Y1] [y2 Y2] [y3 Y3] S T. by transitivity y2.
  Qed.

  Lemma for_all_2_family_prod_trace_congruence {w : SymbolType σ}
    (a b : FamilyProd (A&&P) (dom_symboltype w))
    (R : for_all_2_family_prod (A&&P) (A&&P) cong_trace a b)
    : for_all_2_family_prod A A Φ
        (map_family_prod i a) (map_family_prod i b).
  Proof with try assumption.
    induction w...
    destruct a as [x a], b as [y b], R as [C R].
    split...
    apply IHw...
  Qed.

  Global Instance ops_compatible_trace_trace
    : OpsCompatible (A&&P) cong_trace.
  Proof.
    intros u a b R.
    refine (transport (λ X, Φ _ X _)
              (path_homomorphism_ap_operation i u a)^ _).
    refine (transport (λ X, Φ _ _ X)
              (path_homomorphism_ap_operation i u b)^ _).
    apply (ops_compatible_cong A Φ).
    exact (for_all_2_family_prod_trace_congruence a b R).
  Qed.

  Global Instance is_congruence_trace : IsCongruence (A&&P) cong_trace.
  Proof.
    apply (@BuildIsCongruence _ (A&&P) cong_trace);
      [intros; apply (is_mere_relation_cong A Φ) | exact _ ..].
  Qed.
End cong_trace.

(** The following section defines the [is_subalgebra_class] subalgebra
    predicate, which induces a subalgebra of [A/Φ]. *)

Section is_subalgebra_class.
  Context `{Univalence}
    {σ : Signature} {A : Algebra σ}
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}
    (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}.

  Definition is_subalgebra_class (s : Sort σ) (x : (A/Φ) s) : HProp
    := hexists (λ (y : (A&&P) s), in_class (Φ s) x (i s y)).

  Lemma op_closed_subalgebra_is_subalgebra_class {w : SymbolType σ}
    (γ : Operation (A/Φ) w)
    (α : Operation A w)
    (Q : ComputeOpQuotient A Φ α γ)
    (C : ClosedUnderOp A P α)
    : ClosedUnderOp (A/Φ) is_subalgebra_class γ.
  Proof.
    induction w.
    - specialize (Q tt). apply tr.
      exists (α; C).
      cbn in Q. destruct Q^.
      exact (EquivRel_Reflexive α).
    - refine (quotient_ind_prop (Φ t) _ _). intro x.
      refine (Trunc_rec _).
      intros [y R].
      apply (IHw (γ (class_of (Φ t) x)) (α (i t y))).
      + intro a.
        destruct (related_classes_eq (Φ t) R)^.
        apply (Q (i t y,a)).
      + apply C. exact y.2.
  Qed.

  Definition is_closed_under_ops_is_subalgebra_class
    : IsClosedUnderOps (A/Φ) is_subalgebra_class.
  Proof.
    intro u.
    eapply op_closed_subalgebra_is_subalgebra_class.
    - apply compute_op_quotient.
    - apply is_closed_under_ops_subalgebra_predicate. exact _.
  Qed.

  Global Instance is_subalgebra_predicate_is_subalgebra_class
    : IsSubalgebraPredicate (A/Φ) is_subalgebra_class.
  Proof.
    apply BuildIsSubalgebraPredicate.
    apply is_closed_under_ops_is_subalgebra_class.
  Qed.
End is_subalgebra_class.

(** The next section proves the second isomorphism theorem,

    <<
      (A&&P) / (cong_trace P Φ) ≅ (A/Φ) && (is_subalgebra_class P Φ).
    >>
*)

(* There is an alternative proof using the first isomorphism theorem,
   but the direct proof below seems simpler in HoTT. *)

Section second_isomorphism.
  Context `{Univalence}
    {σ : Signature} (A : Algebra σ)
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}
    (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}.

  Local Notation Ψ := (cong_trace P Φ).

  Local Notation Q := (is_subalgebra_class P Φ).

  Definition def_second_isomorphism (s : Sort σ)
    : ((A&&P) / Ψ) s → ((A/Φ) && Q) s
    := quotient_rec (Ψ s)
        (λ (x : (A&&P) s),
         (class_of (Φ s) (i s x); tr (x; EquivRel_Reflexive x)))
        (λ (x y : (A&&P) s) (T : Ψ s x y),
         path_sigma_hprop (class_of (Φ s) (i s x); _)
           (class_of (Φ s) (i s y); _) (related_classes_eq (Φ s) T)).

  Lemma oppreserving_second_isomorphism {w : SymbolType σ}
    (α : Operation A w) (γ : Operation (A/Φ) w)
    (ζ : Operation ((A&&P) / Ψ) w) (CA : ClosedUnderOp (A/Φ) Q γ)
    (CB : ClosedUnderOp A P α) (QA : ComputeOpQuotient A Φ α γ)
    (QB : ComputeOpQuotient (A&&P) Ψ (op_subalgebra A P α CB) ζ)
    : OpPreserving def_second_isomorphism ζ (op_subalgebra (A/Φ) Q γ CA).
  Proof.
    unfold ComputeOpQuotient in *.
    induction w; cbn in *.
    - apply path_sigma_hprop.
      cbn. destruct (QB tt)^, (QA tt)^.
      by apply related_classes_eq.
    - refine (quotient_ind_prop (Ψ t) _ _). intro x.
      apply (IHw (α (i t x)) (γ (class_of (Φ t) (i t x)))
              (ζ (class_of (Ψ t) x))
              (CA (class_of (Φ t) (i t x)) (tr (x; _)))
              (CB (i t x) x.2)).
      + intro a. exact (QA (i t x, a)).
      + intro a. exact (QB (x, a)).
  Defined.

  Global Instance is_homomorphism_second_isomorphism
    : IsHomomorphism def_second_isomorphism.
  Proof.
    intro u.
    eapply oppreserving_second_isomorphism.
    - apply (compute_op_quotient A).
    - apply (compute_op_quotient (A&&P)).
  Defined.

  Definition hom_second_isomorphism
    : Homomorphism ((A&&P) / Ψ) ((A/Φ) && Q)
    := BuildHomomorphism def_second_isomorphism.

  Global Instance embedding_second_isomorphism (s : Sort σ)
    : IsEmbedding (hom_second_isomorphism s).
  Proof.
    apply isembedding_isinj_hset.
    refine (quotient_ind_prop (Ψ s) _ _). intro x.
    refine (quotient_ind_prop (Ψ s) _ _). intros y p.
    apply related_classes_eq.
    exact (classes_eq_related (Φ s) (i s x) (i s y) (p..1)).
  Qed.

  Global Instance surjection_second_isomorphism (s : Sort σ)
    : IsSurjection (hom_second_isomorphism s).
  Proof.
    apply BuildIsSurjection.
    intros [y S].
    generalize dependent S.
    generalize dependent y.
    refine (quotient_ind_prop (Φ s) _ _). intros y S.
    refine (Trunc_rec _ S). intros [y' S']. apply tr.
    exists (class_of _ y').
    apply path_sigma_hprop.
    by apply related_classes_eq.
  Qed.

  Theorem is_isomorphism_second_isomorphism
    : IsIsomorphism hom_second_isomorphism.
  Proof.
    intro s. apply isequiv_surj_emb; exact _.
  Qed.

  Global Existing Instance is_isomorphism_second_isomorphism.

  Theorem isomorphic_second_isomorphism : (A&&P) / Ψ ≅ (A/Φ) && Q.
  Proof.
    exact (BuildIsomorphic def_second_isomorphism).
  Defined.

  Corollary id_second_isomorphism : (A&&P) / Ψ = (A/Φ) && Q.
  Proof.
    exact (id_isomorphic isomorphic_second_isomorphism).
  Defined.
End second_isomorphism.


Require Import FiatFormal.Data.List.Base.

Fixpoint catOptions {A} (xs : list (option A)) : list A
 := match xs with
    | nil             => nil
    | Some x :: rest  => x :: catOptions rest
    | None   :: rest  => catOptions rest
    end.


From Undecidability Require Import Synthetic.DecidabilityFacts Synthetic.EnumerabilityFacts Synthetic.SemiDecidabilityFacts reductions partial embed_nat.
Require Import Setoid Program Lia.

(** * Axioms for synthetic computability *)

Definition CT (ϕ : nat -> nat -> nat -> option nat) :=
  (forall c x, monotonic (ϕ c x)) /\
  forall f, exists c, forall x, exists n, ϕ c x n = Some (f x).

Section halting_CT.

  Variable ϕ : nat -> nat -> nat -> option nat.

  Variable ct : CT ϕ.

  Definition K' c := exists n m, ϕ c ⟨c, n⟩ m = Some 0.

  Lemma semidecidable_K' : semi_decidable K'.
  Proof.
    exists (fun c => fun! ⟨n, m⟩ => if (ϕ c ⟨c,n⟩ m) is Some 0 then true else false).
    intros c; unfold K'. split.
    - intros (n & m & H).
      exists ⟨n, m⟩. now rewrite embedP, H.
    - intros (nm & H). destruct (unembed nm) as [n m].
      destruct ϕ as [[] | ] eqn:E; inv H.
      eauto.
  Qed.

  Lemma not_semidecidable_compl_K' : ~ semi_decidable (compl K').
  Proof.
    intros (f & Hf). destruct ct as [Hm ct'].
    destruct (ct' (fun! ⟨x, n⟩ => if f x n then 0 else 1)) as [c Hc].
    enough(compl K' c <-> K' c) by (unfold compl in *; tauto).
    red in Hf.
    rewrite Hf. unfold K'.
    split.
    - intros [n Hn].
      specialize (Hc ⟨c, n⟩) as [m H].
      rewrite embedP in H.
      exists n, m. rewrite Hn in H. eauto.
    - intros (n & m & H). exists n.
      specialize (Hc (⟨c, n⟩)) as [m' H'].
      rewrite embedP in H'.
      destruct (f c n); try congruence.
      enough (1 = 0) by congruence.
      eapply monotonic_agnostic; eauto.
  Qed.

End halting_CT.

Lemma CT_halting {ϕ} : CT ϕ ->
  exists K : nat -> Prop, semi_decidable K /\ ~ semi_decidable (compl K) /\ ~ decidable K /\ ~ decidable (compl K).
Proof.
  intros [Hm H]. exists (K' ϕ).
  repeat split.
  - now eapply semidecidable_K'.
  - now eapply not_semidecidable_compl_K'.
  - intros ? % decidable_complement % decidable_semi_decidable.
    now eapply not_semidecidable_compl_K'.
  - intros ? % decidable_semi_decidable.
    now eapply not_semidecidable_compl_K'.
Qed.

(** ** Synthetic Church's thesis *)

Definition SCT :=
  ∑ T : nat -> nat -> nat -> option nat,
    (forall c x, monotonic (T c x)) /\
    forall f : nat -> nat -> nat, exists γ, forall x y, exists n, T (γ x) y n = Some (f x y).

Tactic Notation "intros" "⟨" ident(x) "," ident(n) "⟩" :=
  let xn := fresh "xn" in
  intros xn; destruct (unembed xn) as [x n]; try setoid_rewrite (@embedP (x,n)).

Definition SMN_for (T : nat -> nat -> nat -> option nat) :=
  (exists S : nat -> nat -> nat, forall c x y v, (exists n, T c ⟨x,y⟩ n = Some v) <-> (exists n, T (S c x) y n = Some v)).

Lemma CT_SMN_to_SCT :
  (∑ ϕ, CT ϕ /\ SMN_for ϕ) ->
  SCT.
Proof.
  intros (ϕ & H).
  exists ϕ.
  destruct H as ([Hϕ CT] & [S SMN]).
  split.
  - eapply Hϕ.
  - intros f.
    destruct (CT (fun! ⟨x,y⟩ => f x y)) as [c0 Hc0].
    exists (S c0). intros.
    eapply SMN. edestruct (Hc0 ⟨x,y⟩). rewrite embedP in H.
    eauto.
Qed.

Lemma SCT_to_CT :
  SCT ->
  ∑ ϕ, CT ϕ.
Proof.
  intros (ϕ & Hϕ & SCT).
  exists ϕ. repeat eapply conj.
  - eapply Hϕ.
  - intros f. specialize (SCT (fun _ => f)) as [γ H].
    exists (γ 0). intros. eapply H.
Qed.

Section Cantor.

  Variable A : Type.
  Variable g : A -> (A -> bool).

  Lemma Cantor : surjection_wrt ext_equiv g -> False.
  Proof.
    intros g_surj.
    pose (h x1 := negb (g x1 x1)).
    destruct (g_surj h) as [n H].
    specialize (H n). cbn in H. unfold h in H.
    destruct (g n n); inv H.
  Qed.

End Cantor.

Instance equiv_part `{partiality} {A} : equiv_on (part A) := {| equiv_rel := @partial.equiv _ A |}.

Definition EPF `{partiality} :=
  ∑ θ : nat -> (nat ↛ nat), forall f : nat -> nat ↛ nat,
      exists γ, forall x, θ (γ x) ≡{nat ↛ nat} f x.

Notation "A ↔ B" := ((A -> B) * (B -> A))%type (at level 95).

Lemma EPF_iff `{Part : partiality} :
  EPF ↔ ∑ θ : nat -> (nat ↛ nat), forall R : nat -> FunRel nat nat,
            (exists f, (forall i, pcomputes (f i) (R i))) -> exists γ, forall i, pcomputes (θ (γ i)) (R i).
Proof.
  split.
  - intros [θ H]. exists θ. intros R [f Hf].
    destruct (H f) as [γ Hγ]. exists γ. intros i x y.
    unfold pcomputes in *. specialize (Hγ i x). cbn in Hγ. red in Hγ.
    rewrite Hγ. eapply Hf.
  - intros [θ H]. exists θ. intros f.
    unshelve epose (R := fun i => @Build_FunRel nat nat (fun x y => hasvalue (f i x) y) _).
    { intros ? ? ? ? ?. eapply hasvalue_det; eauto. }
    destruct (H R) as [γ Hγ].
    + exists f. firstorder.
    + exists γ. intros i x y. eapply Hγ.
Qed.

Lemma partial_to_total `{Part : partiality} (f : nat ↛ nat) :
  {f' : nat -> nat | forall x a, f x =! a <-> exists n, f' ⟨x, n⟩ = S a }.
Proof.
  exists (fun arg => let (x,n) := unembed arg in match seval (f x) n with Some a => S a | None => 0 end).
  intros x a. split.
  - intros [n H] % seval_hasvalue.
    exists n. now rewrite embedP, H.
  - intros [n H]. rewrite embedP in H.
    eapply seval_hasvalue. exists n.
    destruct seval; congruence.
Qed.

Definition e `{partiality} (ϕ : nat -> nat -> nat -> option nat) :=
  (fun c x => mkpart (fun! ⟨n,m⟩ =>
                     if ϕ c ⟨ x, n ⟩ m is Some (S x) then Some x else None)).

Lemma SCT_to_EPF {Part : partiality} :
  SCT -> EPF.
Proof.
  intros (ϕ & Hϕ & SCT).
  exists (e ϕ). intros f.
  destruct (SCT (fun x => proj1_sig (partial_to_total (f x)))) as [γ H].
  exists γ. intros x y v.
  transitivity (exists n m, ϕ (γ x) ⟨ y, n ⟩ m = Some (S v)). {
    unfold e.
    rewrite mkpart_hasvalue.
    split.
    - intros [n Hn]. destruct (unembed n) as [n' m] eqn:E.
      exists n', m.
      destruct ϕ as [ [] | ]; try congruence.
    - intros [n [m HT]]. exists ⟨ n, m ⟩. now rewrite embedP, HT.
    - intros n1' n2' x1 x2 H1 H2.
      destruct (unembed n1') as [n1 m1], (unembed n2') as [n2 m2].
      destruct (H x ⟨y,n1⟩) as [m3 H3], (H x ⟨y,n2⟩) as [m4 H4].
      destruct (ϕ (γ x) ⟨ y, n1 ⟩ m1) eqn:E1; try congruence.
      destruct (ϕ (γ x) ⟨ y, n2 ⟩ m2) eqn:E2; try congruence.
      eapply monotonic_agnostic in E1; eauto. eapply E1 in H3. subst n.
      eapply monotonic_agnostic in E2; eauto. eapply E2 in H4. subst n0.
      destruct (proj1_sig (partial_to_total (f x)) ⟨ y, n1 ⟩) eqn:E1'; try congruence.
      destruct (proj1_sig (partial_to_total (f x)) ⟨ y, n2 ⟩) eqn:E2'; try congruence.
      inv H1. inv H2.
      assert (f x y =! x1) by (eapply (proj2_sig (partial_to_total (f x))); eauto).
      assert (f x y =! x2) by (eapply (proj2_sig (partial_to_total (f x))); eauto).
      eapply hasvalue_det; eauto.
  }

  pose proof (proj2_sig (partial_to_total (f x))) as Eq. cbn in Eq.
  rewrite Eq.

  split.
  - intros [n [m HT]].
    destruct (H x ⟨ y, n ⟩).
    eapply monotonic_agnostic in HT; eauto. eapply HT in H0. eauto.
  - intros [n Hn].
    destruct (H x ⟨ y, n ⟩).
    rewrite Hn in H0. eauto.
Qed.

Lemma EPF_to_SCT {Part : partiality} :
  EPF -> SCT.
Proof.
  intros (θ & EPF).
  exists (fun c x n => seval (θ c x) n). split.
  - intros. eapply seval_mono.
  - intros f.
    specialize (EPF (fun x y => ret (f x y))) as [γ H].
    exists γ. intros x y. specialize (H x y).
    eapply seval_hasvalue, H, ret_hasvalue.
Qed.

Lemma EPF_to_CT_SMN {Part : partiality} :
  EPF -> exists ϕ, CT ϕ /\ SMN_for ϕ.
Proof.
  intros (θ & EPF).
  exists (fun c x n => seval (θ c x) n). split. split.
  - intros. eapply seval_mono.
  - intros f.
    specialize (EPF (fun x y => ret (f y))) as [γ H].
    exists (γ 0). intros y. specialize (H 0 y).
    eapply seval_hasvalue, H, ret_hasvalue.
  - specialize (EPF (fun! ⟨c,x⟩ => fun y => θ c ⟨x,y⟩)) as [γ H].
    eexists (fun c x => γ ⟨c,x⟩).
    intros c x y v. rewrite <- !seval_hasvalue.
    specialize (H ⟨c,x⟩ y). cbn in H.
    rewrite embedP in H. symmetry. eapply H.
Qed.

Definition EA := ∑ ψ : nat -> (nat -> option nat),
    forall p : nat -> nat -> Prop, penumerable p -> exists γ, parametric_enumerator (fun x => ψ (γ x)) p.

From Undecidability Require Import reductions ReducibilityFacts EnumerabilityFacts ListEnumerabilityFacts.

Lemma EA_iff_enumerable :
  EA ↔ ∑ ψ : nat -> (nat -> option nat),
  forall p : nat -> nat -> Prop, enumerable (uncurry p) -> exists γ, parametric_enumerator (fun x => ψ (γ x)) p.
Proof.
  split; intros [ψ H]; exists ψ; intros p Hp % penumerable_iff; eauto.
  all: eapply discrete_nat.
Qed.

Lemma EA_iff_ran :
  EA ↔ ∑ ψ : nat -> (nat -> option nat),
  forall f : nat -> nat -> option nat,
  exists γ, forall x, ψ (γ x) ≡{ran} f x.
Proof.
  split; intros [ψ H]; exists ψ.
  - intros f.
    specialize (H (fun x y => exists n, f x n = Some y)) as [γ H].
    + exists f. red. reflexivity.
    + exists γ. intros x. cbn. intros y. symmetry. eapply H.
  - intros p [f Hf].
    specialize (H f) as [γ H].
    exists γ. intros x y.
    red in Hf. cbn in H. now rewrite Hf, H.
Qed.

Lemma EA_halting : EA -> exists K : nat -> Prop, enumerable K /\ ~ enumerable (compl K) /\ ~ decidable K.
Proof.
  intros [φ EA].
  exists (fun c => exists n, φ c n = Some c).
  assert (He : ~ enumerable (compl (fun c => exists n, φ c n = Some c))). {
    intros [f Hf].
    specialize (EA (fun _ => compl (fun c => exists n, φ c n = Some c))) as [γ H].
    { exists (fun _ => f). firstorder. }
    specialize (H 0 (γ 0)). cbn in H. unfold compl in *. tauto.
  }
  repeat split.
  - exists (fun! ⟨c, m⟩ => if φ c m is Some x then if Nat.eqb x c then Some c else None else None).
    unfold enumerator. intros c. split.
    + intros [n H]. exists ⟨c, n⟩. now rewrite embedP, H, PeanoNat.Nat.eqb_refl.
    + intros [cn H]. destruct (unembed cn) as [c' n]. exists n.
      destruct φ eqn:E; inv H.
      now destruct (PeanoNat.Nat.eqb_spec n0 c'); inv H1.
  - eassumption.
  - intros ? % decidable_complement % decidable_enumerable; eauto.
Qed.

Definition ψ (ϕ : nat -> nat -> nat -> option nat) c := fun! ⟨ n, m ⟩ => match ϕ c n m with Some (S x) => Some x | _ => None end.

Lemma SCTS_to_EAS :
  SCT -> EA.
Proof.
  intros (ϕ & Hϕ & SCT). eapply EA_iff_enumerable.
  unshelve eexists (ψ ϕ).
  intros p [f Hf]. unfold ψ. cbn.
  specialize (SCT (fun x n => if f n is Some (x',y) then if Nat.eqb x' x then S y else 0 else 0)) as [c Hc].
  exists c. intros x y. split.
  + intros H. eapply (Hf (x,y)) in H as [n H].
    destruct (Hc x n) as [m Hm].
    exists ⟨n,m⟩. now rewrite embedP, Hm, H, PeanoNat.Nat.eqb_refl.
  + intros [nm H]. destruct (unembed nm) as [n m].
    destruct ϕ eqn:E; try congruence.
    destruct n0; inv H.
    specialize (Hc x n) as [m' H'].
    unshelve epose proof (monotonic_agnostic _ E H'). eauto.
    destruct (f n) as [[x' y']| ] eqn:E'; try congruence.
    destruct (PeanoNat.Nat.eqb_spec x' x); inv H.
    eapply (Hf (x,y')). eauto.
Qed.

Require Import Undecidability.Synthetic.ReducibilityFacts.

Fixpoint mk_mono {X} (f : nat -> option X) (n : nat) : option X :=
  match n with
  | 0 => None
  | S n => if mk_mono f n is Some x then Some x else f n
  end.

Lemma monotonic_mk_mono {X} (f : nat -> option X) :
  monotonic (mk_mono f).
Proof.
  intros n1 v H1 n2 H2.
  induction H2; cbn; eauto.
  now rewrite IHle.
Qed.

Lemma mk_mono_spec {X} (f : nat -> option X) n x :
  mk_mono f n = Some x <-> exists m, m < n /\ f m = Some x /\ forall m', f m' <> None -> m <= m'.
Proof.
  revert x. pattern n. eapply Wf_nat.lt_wf_ind.
  clear. intros n IH x. destruct n; cbn.
  - clear IH. split.
    + firstorder. exists 0. firstorder congruence.
    + intros (m & H1 & H2 & H3). assert (m = 0) as -> by lia. lia.
  - destruct mk_mono eqn:E.
    + eapply IH in E as (m & H1 & H2 & H3); try lia.
      split.
      * intros [= ->]. exists m. split. lia. eauto.
      * intros (m' & H1' & H2' & H3').
        enough (m = m') by congruence.
        enough (m <= m' /\ m' <= m) by lia.
        split; [ eapply H3 | eapply H3']; congruence.
    + split.
      * intros H. exists n. repeat split; eauto.
        intros. enough (~ m' < n) by lia. intros ?.
        assert (exists m', f m' <> None). { eauto. }
        eapply mu_nat_dep_least in H2 as (l & _ & H4 & H5). 2: { intros k; destruct (f k); firstorder congruence. }
        destruct (f l) as [x' | ] eqn:E'; try congruence.
        enough (None = Some x') by congruence. rewrite <- E.
        eapply IH. lia. exists l. repeat eapply conj.
        -- enough (l <= m') by lia. eapply H5. lia. eauto.
        -- eauto.
        -- intros. eapply H5. lia. eauto.
      * intros (m & H1 & H2 & H3).
        assert (m = n \/ m < n) as [-> | ] by lia; eauto.
        enough (None = Some x) by congruence.
        rewrite <- E. eapply IH. lia.
        exists m. split. lia. eauto.
Qed.

Lemma EA_to_SCT :
  EA -> SCT.
Proof.
  intros [e EA] % EA_iff_enumerable.
  exists (fun c x => mk_mono (fun n => if e c n is Some xy then (fun! ⟨x',y⟩ => if Nat.eqb x x' then Some y else None) xy else None)).
  split. 1: intros; eapply monotonic_mk_mono.
  intros f.
  destruct (EA (fun x => fun! ⟨n, m⟩ => f x n = m)) as [c Hc].
  { eapply enumerable_red. 4:eapply enumerable_graph with (f0 := (fun '(x,n) => f x n)).
    - exists (fun '(x,nm) => (fun! ⟨n,m⟩ => ((x,n),m)) nm).
      intros [x nm]. cbn.
      destruct (unembed nm) as [n m].
      split.
      + intros H. exists (x,n). f_equal. symmetry. exact H.
      + now intros [[] [= -> -> ->]].
    - eauto.
    - eapply discrete_iff. eauto.
    - eauto.
  }
  exists c. intros x y.
  pose proof (Hc x ⟨y,f x y⟩) as Hc'. cbn in Hc'. rewrite embedP in Hc'.
  destruct Hc' as [H _]. specialize (H eq_refl).
  eapply mu_nat_dep_least in H as (n & _ & H & Hl).
  2:{ intros n. clear. destruct (e (c x) n); try firstorder congruence.
      destruct (Dec.nat_eq_dec n0 ⟨y,f x y⟩); firstorder congruence. }

  exists (S n). eapply mk_mono_spec. exists n. repeat eapply conj.
  + lia.
  + now rewrite H, embedP, PeanoNat.Nat.eqb_refl.
  + intros. specialize (Hl m' ltac:(lia)). destruct (e (c x) m') as [x'y | ] eqn:E; try congruence.
    destruct (unembed x'y) as [x' y'] eqn:E'.
    eapply (f_equal embed) in E'. rewrite unembedP in E'. subst.
    assert (f x x' = y'). {
      specialize (Hc x ⟨x', y'⟩). cbn in Hc. rewrite embedP in Hc. eapply Hc.
      eauto.
    }
    destruct (PeanoNat.Nat.eqb_spec y x'); try congruence.
    subst. eauto.
Qed.

Lemma EA_to_EA_star :
  EA -> ∑ φ : nat -> (nat -> option nat),
    (forall p, enumerable p -> exists c, enumerator (φ c) p) /\
    let W c x := exists n, φ c n = Some x in
    exists s, forall c x y, W (s c x) y <-> W c ⟨x,y⟩.
Proof.
  intros (φ & H) % EA_iff_enumerable.
  assert (lem : forall p : nat -> Prop, enumerable p -> exists c : nat, enumerator (φ c) p). {
    intros p [f Hf].
    destruct (H (fun _ => p)) as [c0 Hc0].
    + exists (fun! ⟨x,n⟩ => if f n is Some y then Some (x,y) else None).
      intros [x y].
      rewrite (Hf y).
      split.
      * intros [n Hn]. exists ⟨x,n⟩. now rewrite embedP, Hn.
      * intros [xn Hn]. destruct (unembed xn) as [x' n].
        destruct f eqn:E'; inv Hn. eauto.
    + exists (c0 0). intros x. eapply Hc0.
  }
  exists φ. split.
  - eapply lem.
  - cbn. destruct (H (fun! ⟨c,x⟩ => fun y => exists n, φ c n = Some ⟨x,y⟩)) as [γ Hγ].
    + eexists (fun! ⟨c,n⟩ => if φ c n is Some xy then (fun! ⟨x,y⟩ => Some (⟨c,x⟩, y)) xy else @None _). intros [cx y].
      destruct (unembed cx) as [c x] eqn:E'.
      eapply (f_equal embed) in E'. rewrite unembedP in E'.
      subst. split.
      * cbn. rewrite embedP. intros [n Hn]. exists ⟨c,n⟩.
        now rewrite embedP, Hn, embedP.
      * intros [n Hn]. destruct (unembed n) as [c' n'].
        destruct φ eqn:E; try congruence.
        destruct (unembed n0) as [x' y'] eqn:E'. inv Hn.
        eapply (f_equal unembed) in H1. rewrite !embedP in H1.
        inv H1.
        eapply (f_equal embed) in E'. rewrite !unembedP in E'. subst.
        cbn. rewrite embedP. eauto.
    + exists (fun c x => γ ⟨c,x⟩). unfold enumerator in Hγ.
      intros. specialize (Hγ ⟨c,x⟩ y). cbn in Hγ. rewrite embedP in Hγ.
      symmetry. eassumption.
Qed.

Lemma enumerable_pair_red:
  forall p : nat -> nat -> Prop, enumerable (uncurry p) -> enumerable (fun! ⟨ x, y ⟩ => p x y).
Proof.
  intros p Hp.
  eapply enumerable_red; eauto. 2: eapply discrete_iff; eauto.
  exists unembed. intros xy.
  destruct (unembed xy) as [x y]. reflexivity.
Qed.

Lemma EA_star_to_EA :
  (∑ φ : nat -> (nat -> option nat),
    (forall p, enumerable p -> exists c, enumerator (φ c) p) /\
    let W c x := exists n, φ c n = Some x in
    exists s, forall c x y, W (s c x) y <-> W c ⟨x,y⟩) -> EA.
Proof.
  intros (φ & H). eapply EA_iff_enumerable.
  exists φ. destruct H as (Hφ & S & HS).
  intros p Hp % enumerable_pair_red.

  destruct (Hφ _ Hp) as [c Hc].
  exists (fun x => S c x). intros x y. red in Hc.
  now rewrite HS, <- Hc, embedP.
Qed.

Definition EA' := ∑ W : nat -> (nat -> Prop), forall p : nat -> Prop, enumerable p <-> exists c, W c ≡{nat -> Prop} p.

Lemma EA_to_EA'  :
  EA -> EA'.
Proof.
  intros [φ H].
  exists (fun c x => exists n, φ c n = Some x). intros p.
  split.
  - intros [f Hf]. specialize (H (fun _ => p)) as [γ H].
    + exists (fun _ => f). intros _. eapply Hf.
    + exists (γ 0). intros x. cbn. firstorder.
  - intros [c Hc]. exists (φ c). firstorder.
Qed.

Definition SCT_bool :=
  ∑ ϕ : nat -> nat -> nat -> option bool,
    (forall c x, monotonic (ϕ c x)) /\
    forall f : nat -> nat -> bool, exists γ, forall x y,exists n,  ϕ (γ x) y n = Some (f x y).

Module R_spec.

Require Import List.
Import ListNotations.
Import implementation.

Definition I (f : nat -> nat) (n : nat) : bool :=
  nth n (flat_map (fun n => List.repeat false n ++ [true]) (map f (seq 0 (1 + n)))) false.

Fixpoint R (f : nat -> part bool) (x : nat) : part nat :=
  match x with
  | 0 => mu f
  | S x => bind (mu f) (fun n => R (fun m => f (m + S n)) x)
  end.

Lemma R_spec0:
  forall (g : nat ↛ bool) (f : nat -> nat),
    (forall x : nat, g x =! I f x) -> hasvalue (mu g) (f 0).
Proof.
  intros g f H.
  eapply mu_hasvalue_imp. split.
  - enough (I f (f 0) = true) as <- by eapply H.
    unfold I.
    rewrite seq_app, map_app. cbn.
    rewrite app_nth1. 2: rewrite app_length, repeat_length; cbn; lia.
    rewrite app_nth2. 2: rewrite repeat_length; cbn; lia.
    now rewrite repeat_length, PeanoNat.Nat.sub_diag.
  - intros.
    enough (I f m = false) as <- by eapply H.
    unfold I.
    rewrite seq_app, map_app. cbn.
    rewrite app_nth1. 2: rewrite app_length, repeat_length; cbn; lia.
    rewrite app_nth1. 2: rewrite repeat_length; cbn; lia.
    destruct nth eqn:E; try reflexivity.
    enough (In true (repeat false (f 0))) by (eapply repeat_spec; eassumption).
    rewrite <- E. eapply nth_In. rewrite repeat_length. lia.
Qed.

Lemma flat_map_length_ge {X Y} (f : X -> list Y) l n :
  length l >= n ->
  (forall x, length (f x) > 0) ->
  length (flat_map f l) >= n.
Proof.
  intros Hl Hf. induction l in n, Hl |- *; cbn in *.
  - lia.
  - rewrite app_length.
    destruct n; try lia.
    specialize (IHl n ltac:(lia)).
    specialize (Hf a). lia.
Qed.

Lemma R_spec g f :
  (forall x, g x =! I f x) ->
  forall x, R g x =! f x.
Proof.
  intros H x. revert g f H.
  induction x; intros; cbn.
  - now eapply R_spec0.
  - eapply bind_hasvalue_imp. exists (f 0).
    split. now eapply R_spec0.
    eapply (IHx (fun m : nat => g (m + S (f 0))) (fun y => f (S y))).
    clear - H. intros x.
    specialize (H (x + S (f 0))).
    enough (I (fun y => f (S y)) x = I f (x + S (f 0))) as -> by eassumption. clear H.
    unfold I.
    rewrite <- map_map, seq_shift. cbn.
    symmetry.
    rewrite app_nth2. all: rewrite app_length, repeat_length. 2: cbn; lia.
    cbn.
    replace (x + S (f 0) - (f 0 + 1)) with x by lia.
    replace (x + S (f 0)) with (S (x + f 0)) by lia.
    cbn. rewrite seq_app, map_app, flat_map_app.
    rewrite app_assoc, app_nth1. reflexivity.
    rewrite !app_length, repeat_length; cbn.
    enough (length (flat_map (fun n : nat => repeat false n ++ [true]) (map f (seq 2 x)))
            >= x) by lia.
    eapply flat_map_length_ge.
    + rewrite map_length, seq_length. lia.
    + intros. rewrite app_length, repeat_length. cbn. lia.
Qed.

Lemma SCT_to_SCT_bool :
  SCT -> SCT_bool.
Proof.
  intros (ϕ & Hϕ & SCT).
  exists (fun c x n => if ϕ c x n is Some x then Some (Nat.eqb x 0) else None). split.
  - intros c x n v H n2 H2. specialize (Hϕ c x n).
    destruct (ϕ c x n); inv H.
    eapply Hϕ in H2 as ->; eauto.
  - intros f.
    specialize (SCT (fun x y => if f x y then 0 else 1)) as [γ H].
    exists γ. intros x y.
    destruct (H x y) as [n Hn]. exists n. rewrite Hn.
    destruct (f x y); reflexivity.
Qed.

Lemma SCT_bool_to_SCT :
  SCT_bool -> SCT.
Proof.
  intros (ϕ & Hϕ & SCT).
  exists (fun c x => the_fun (R (fun x => @Build_part _ (ϕ c x) (Hϕ c x)) x)). split.
  - intros c x. eapply spec_fun.
  - intros f. specialize (SCT (fun x => I (f x))) as [γ H].
    exists γ. intros x y.
    enough (R (fun x0 : nat => {| the_fun := ϕ (γ x) x0; spec_fun := Hϕ (γ x) x0 |}) y
              =! f x y) as [n Hn] by firstorder.
    eapply R_spec. eapply H.
Qed.

End R_spec.

Definition EPF_bool `{partiality} :=
  ∑ θ : nat -> (nat ↛ bool), forall f : nat -> nat ↛ bool,
      exists γ, forall x, θ (γ x) ≡{nat ↛ bool} f x.

Lemma EPF_bool_to_SCT_bool {Part : partiality} :
  EPF_bool -> SCT_bool.
Proof.
    intros (θ & EPF).
  exists (fun c x n => seval (θ c x) n). split.
  - intros. eapply seval_mono.
  - intros f.
    specialize (EPF (fun x y => ret (f x y))) as [γ H].
    exists γ. intros x y. specialize (H x y).
    eapply seval_hasvalue, H, ret_hasvalue.
Qed.

Lemma EPF_to_EPF_bool {Part : partiality} :
  EPF -> EPF_bool.
Proof.
  intros (θ & EPF).
  exists (fun x y => bind (θ x y) (fun v => ret (Nat.eqb v 0))).
  intros f.
  specialize (EPF (fun x y => bind (f x y) (fun b => ret (if b then 0 else 1)))) as [γ Hγ].
  exists γ. intros x y. specialize (Hγ x y).
  intros v.
  rewrite bind_hasvalue.
  cbn in Hγ. red in Hγ. setoid_rewrite Hγ.
  setoid_rewrite bind_hasvalue.
  split.
  - intros (a & (a0 & H1 & <- % ret_hasvalue_iff) & <- % ret_hasvalue_iff).
    now destruct a0; cbn.
  - intros H. eexists. split. 1:eexists; split. 1: eassumption.
    eapply ret_hasvalue. destruct v; eapply ret_hasvalue.
Qed.

Section halting.

  Variable Part : partiality.
  Variable θ : nat -> nat ↛ bool.

  Variable EPF : forall f : nat -> nat ↛ bool,
     exists γ : nat -> nat, forall x : nat, θ (γ x) ≡{ nat ↛ bool} f x.

  Definition K c := exists v, θ c c =! v.

  Lemma semidecidable_K : semi_decidable K.
  Proof.
    exists (fun c n => if seval (θ c c) n is Some v then true else false).
    intros c; unfold K. split.
    - intros [v [n H] % seval_hasvalue]. exists n. now rewrite H.
    - intros [n H]. destruct (seval) as [v | ] eqn:E; inv H.
      exists v. eapply seval_hasvalue. eauto.
  Qed.

  Lemma not_semidecidable_compl_K : ~ semi_decidable (compl K).
  Proof.
    intros (Y & f & Hf) % semi_decidable_part_iff.
    destruct (EPF (fun _ n => bind (f n) (fun _ => ret true))) as [γ H].
    specialize (H 0).
    enough(compl K (γ 0) <-> K (γ 0)) by (unfold compl in *; tauto).
    rewrite Hf. unfold K.
    specialize (H (γ 0)). cbn in H. red in H.
    setoid_rewrite H. setoid_rewrite bind_hasvalue.
    setoid_rewrite <- ret_hasvalue_iff.
    split; intros [v Hv]; eauto; firstorder.
  Qed.

End halting.

Lemma EPF_halting {Part : partiality} : EPF_bool ->
  exists K : nat -> Prop, semi_decidable K /\ ~ semi_decidable (compl K) /\ ~ decidable K /\ ~ decidable (compl K).
Proof.
  intros [θ H]. exists (K _ θ).
  repeat split.
  - now eapply semidecidable_K.
  - now eapply not_semidecidable_compl_K.
  - intros ? % decidable_complement % decidable_semi_decidable.
    now eapply not_semidecidable_compl_K.
  - intros ? % decidable_semi_decidable.
    now eapply not_semidecidable_compl_K.
Qed.


Set Implicit Arguments.
Require Import Interpreter.
Require Import JsNumber.

Require Import LibFix LibList.

Require Export Shared.
Require Export LibTactics LibLogic LibReflect LibList
  LibOperation LibStruct LibNat LibEpsilon LibFunc LibHeap.
Require Flocq.Appli.Fappli_IEEE Flocq.Appli.Fappli_IEEE_bits.

Extraction Language Ocaml.

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.
Require Import ExtrOcamlString.

(*
(* We do not want “raise Not_found” to be at the toplevel. *)
Extraction Inline LibLogic.arbitrary.

Extract Inductive Fappli_IEEE.binary_float => float [
  "(fun s -> if s then (0.) else (-0.))"
  "(fun s -> if s then infinity else neg_infinity)"
  "nan"
  "(fun (s, m, e) -> failwith ""FIXME: No extraction from binary float allowed yet."")"
].
*)

(*** Magical stuff from JSCert that makes float extraction work. *)

(* Optimal fixpoint. *)
Extraction Inline FixFun3 FixFun3Mod FixFun4 FixFun4Mod FixFunMod curry3 uncurry3 curry4 uncurry4.
(* As classical logic statements are now unused, they should not be extracted
   (otherwise, useless errors will be launched). *)
Extraction Inline epsilon epsilon_def classicT arbitrary indefinite_description Inhab_witness Fix isTrue.

(**************************************************************)
(** ** Numerical values *)

(* number *)

Extract Inductive positive => float
[ "(fun p -> 1. +. (2. *. p))"
  "(fun p -> 2. *. p)"
  "1." ]
"(fun f2p1 f2p f1 p ->
if p <= 1. then f1 () else if mod_float p 2. = 0. then f2p (p /. 2.) else f2p1 (p /. 2.))".

Extract Inductive Z => float [ "0." "" "(~-.)" ]
"(fun f0 fp fn z -> if z=0. then f0 () else if z>0. then fp z else fn (~-. z))".

Extract Inductive N => float [ "0." "" ]
"(fun f0 fp n -> if n=0. then f0 () else fp n)".

Extract Constant Z.add => "(+.)".
Extract Constant Z.succ => "(+.) 1.".
Extract Constant Z.pred => "(fun x -> x -. 1.)".
Extract Constant Z.sub => "(-.)".
Extract Constant Z.mul => "( *. )".
Extract Constant Z.opp => "(~-.)".
Extract Constant Z.abs => "abs_float".
Extract Constant Z.min => "min".
Extract Constant Z.max => "max".
Extract Constant Z.compare =>
 "fun x y -> if x=y then Eq else if x<y then Lt else Gt".

Extract Constant Pos.add => "(+.)".
Extract Constant Pos.succ => "(+.) 1.".
Extract Constant Pos.pred => "(fun x -> x -. 1.)".
Extract Constant Pos.sub => "(-.)".
Extract Constant Pos.mul => "( *. )".
Extract Constant Pos.min => "min".
Extract Constant Pos.max => "max".
Extract Constant Pos.compare =>
 "fun x y -> if x=y then Eq else if x<y then Lt else Gt".
Extract Constant Pos.compare_cont =>
 "fun x y c -> if x=y then c else if x<y then Lt else Gt".

Extract Constant N.add => "(+.)".
Extract Constant N.succ => "(+.) 1.".
Extract Constant N.pred => "(fun x -> x -. 1.)".
Extract Constant N.sub => "(-.)".
Extract Constant N.mul => "( *. )".
Extract Constant N.min => "min".
Extract Constant N.max => "max".
Extract Constant N.div => "(fun x y -> if x = 0. then 0. else floor (x /. y))".
Extract Constant N.modulo => "mod_float".
Extract Constant N.compare =>
 "fun x y -> if x=y then Eq else if x<y then Lt else Gt".

Extract Inductive Fappli_IEEE.binary_float => float [
  "(fun s -> if s then (0.) else (-0.))"
  "(fun s -> if s then infinity else neg_infinity)"
  "nan"
  "(fun (s, m, e) -> failwith ""FIXME: No extraction from binary float allowed yet."")"
].

Extract Constant JsNumber.of_int => "fun x -> x".

Extract Constant JsNumber.nan => "nan".
Extract Constant JsNumber.zero => "0.".
Extract Constant JsNumber.neg_zero => "(-0.)".
Extract Constant JsNumber.one => "1.".
Extract Constant JsNumber.infinity => "infinity".
Extract Constant JsNumber.neg_infinity => "neg_infinity".
Extract Constant JsNumber.max_value => "max_float".
Extract Constant JsNumber.min_value => "(Int64.float_of_bits Int64.one)".
Extract Constant JsNumber.floor => "floor".
Extract Constant JsNumber.absolute => "abs_float".
Extract Constant JsNumber.from_string =>
  "(fun s ->
    try
      let s = (String.concat """" (List.map (String.make 1) s)) in
      if s = """" then 0. else float_of_string s
    with Failure ""float_of_string"" -> nan)
   (* Note that we're using `float_of_string' there, which does not have the same
      behavior than JavaScript.  For instance it will read ""022"" as 22 instead of
      18, which should be the JavaScript result for it. *)".
Extract Constant JsNumber.to_string =>
  "(fun f ->
    prerr_string (""Warning:  JsNumber.to_string called.  This might be responsible for errors.  Argument value:  "" ^ string_of_float f ^ ""."");
    prerr_newline();
    let string_of_number n =
      let inum = int_of_float n in
      if (float_of_int inum = n) then string_of_int inum else string_of_float n in
    let ret = ref [] in (* Ugly, but the API for OCaml string is not very functionnal... *)
    String.iter (fun c -> ret := c :: !ret) (string_of_number f);
    List.rev !ret)
   (* Note that this is ugly, we should use the spec of JsNumber.to_string here. *)".
Extract Constant JsNumber.add => "(+.)".
Extract Constant JsNumber.sub => "(-.)".
Extract Constant JsNumber.mult => "( *. )".
Extract Constant JsNumber.div => "(/.)".
Extract Constant JsNumber.fmod => "mod_float".
Extract Constant JsNumber.neg => "(~-.)".
Extract Constant JsNumber.sign => "(fun f -> float_of_int (compare f 0.))".
Extract Constant JsNumber.number_comparable => "(fun n1 n2 -> 0 = compare n1 n2)".
Extract Constant JsNumber.lt_bool => "(<)".
Extract Constant Operators.le_bool => "(<=)".
Extract Constant Operators.gt_bool => "(>)".
Extract Constant Operators.ge_bool => "(>=)".

Extract Constant JsNumber.to_int32 =>
"fun n ->
  match classify_float n with
  | FP_normal | FP_subnormal ->
    let i32 = 2. ** 32. in
    let i31 = 2. ** 31. in
    let posint = (if n < 0. then (-1.) else 1.) *. (floor (abs_float n)) in
    let int32bit =
      let smod = mod_float posint i32 in
      if smod < 0. then smod +. i32 else smod
    in
    (if int32bit >= i31 then int32bit -. i32 else int32bit)
  | _ -> 0.". (* LATER:  do in Coq.  Spec is 9.5, p. 47.*)
Extract Constant JsNumber.to_uint32 =>
"fun n ->
  match classify_float n with
  | FP_normal | FP_subnormal ->
    let i32 = 2. ** 32. in
    let posint = (if n < 0. then (-1.) else 1.) *. (floor (abs_float n)) in
    let int32bit =
      let smod = mod_float posint i32 in
      if smod < 0. then smod +. i32 else smod
    in
    int32bit
  | _ -> 0.". (* LAER:  do in Coq.  Spec is 9.6, p47.*)
Extract Constant JsNumber.modulo_32 => "(fun x -> let r = mod_float x 32. in if x < 0. then r +. 32. else r)".
Extract Constant JsNumber.int32_bitwise_not => "fun x -> Int32.to_float (Int32.lognot (Int32.of_float x))".
Extract Constant JsNumber.int32_bitwise_and => "fun x y -> Int32.to_float (Int32.logand (Int32.of_float x) (Int32.of_float y))".
Extract Constant JsNumber.int32_bitwise_or => "fun x y -> Int32.to_float (Int32.logor (Int32.of_float x) (Int32.of_float y))".
Extract Constant JsNumber.int32_bitwise_xor => "fun x y -> Int32.to_float (Int32.logxor (Int32.of_float x) (Int32.of_float y))".
Extract Constant JsNumber.int32_left_shift => "(fun x y -> Int32.to_float (Int32.shift_left (Int32.of_float x) (int_of_float y)))".
Extract Constant JsNumber.int32_right_shift => "(fun x y -> Int32.to_float (Int32.shift_right (Int32.of_float x) (int_of_float y)))".
Extract Constant JsNumber.uint32_right_shift =>
"(fun x y ->
  let i31 = 2. ** 31. in
  let i32 = 2. ** 32. in
  let newx = if x >= i31 then x -. i32 else x in
  let r = Int32.to_float (Int32.shift_right_logical (Int32.of_float newx) (int_of_float y)) in
  if r < 0. then r +. i32 else r)".

Extract Constant int_of_char => "(fun c -> float_of_int (int_of_char c))".

Extract Constant ascii_compare => "(=)".
Extract Constant lt_int_decidable => "(<)".
Extract Constant le_int_decidable => "(<=)".
Extract Constant ge_nat_decidable => "(>=)".

(* TODO ARTHUR:  This TLC lemma does not extract to something computable... whereas it should! *)
Extract Constant prop_eq_decidable => "(=)".

(* The following functions make pattern matches with floats and shall thus be removed. *)
Extraction Inline Fappli_IEEE.Bplus Fappli_IEEE.binary_normalize Fappli_IEEE_bits.b64_plus.
Extraction Inline Fappli_IEEE.Bmult Fappli_IEEE.Bmult_FF Fappli_IEEE_bits.b64_mult.
Extraction Inline Fappli_IEEE.Bdiv Fappli_IEEE_bits.b64_div.

(* New options for the interpreter to work in Coq 8.4 *)
Set Extraction AccessOpaque.

Extract Constant Operators._nat_of_float => "int_of_float".

Extract Constant Operators._same_value => "(fun v1 v2 -> begin
  match v1, v2 with
  | Number x, Number y ->
    if x = 0. && y = 0.
    then 1. /. x = 1. /. y
    else compare x y = 0
  | _ -> compare v1 v2 = 0
end)".

Extract Constant Operators._number_eq_bool => "(=)".

Extract Constant Operators._print_string => "fun x -> print_string (CoqUtils.implode x); print_char '\n'".
Extract Constant Operators._pretty => "fun fuel store value -> print_string (PrettyPrint.string_of_value fuel store value); print_char '\n'".

(* That would be more optimized than char lists...
Extract Inductive String.string => "string" [ """""" "(^)" ]. *)

Extraction Blacklist String List Bool.

Separate Extraction Interpreter Values Syntax Store JsNumber.to_string.


Set Primitive Projections.
From Equations Require Import Equations.

From Paco Require Import paco.
From OGS Require Import Utils Ctx EventD CatD ITreeD EqD RecD AngelicD.
From Coq Require Import RelationClasses.

Record observing {I} {E : event I I} {X Y : psh I}
           (R : relᵢ (itree' E X) (itree' E Y))
           i (t1 : itree E X i) (t2 : itree E Y i) : Prop :=
  observing_intros
  { observing_observe : R _ (observe t1) (observe t2) }.
Check observing_observe.
Arguments observing_observe {I E X Y R i t1 t2}.
Global Hint Constructors observing: core.

Definition observing_sub_eqit {I} {E : event I I} {X : psh I}
           (R : relᵢ X X) (RR : Reflexiveᵢ R) b0 b1
           : subrelᵢ (observing eqᵢ) (@eqit I E _ _ R b0 b1).
  repeat red; intros.
  pstep. red. rewrite (observing_observe H).
  apply Reflexive_eqitF; eauto.
  left; apply reflexivity.
  Qed.

Definition subst_ {I} {E : event I I} {X Y : I -> Type}
           (f : X ⇒ᵢ itree E Y) : itree E X ⇒ᵢ itree E Y
  := fun i x => match (observe x) with
             | RetF r => f _ r
             | TauF t => Tau (subst f t)
             | VisF e k => Vis e (fun r => subst f (k r))
             end.

Lemma unfold_subst {I} {E : event I I} {X Y : I -> Type}
           (f : X ⇒ᵢ itree E Y) {i} (x : itree E X i)
           : observing eqᵢ _ (subst f x) (subst_ f _ x).
  constructor; reflexivity.
Qed.

Definition iter_ {I} {E : event I I} {X Y : I -> Type} (f : X ⇒ᵢ itree E (X +ᵢ Y)) :=
  fun i x => bind (f i x) (fun i y => match y with
                                | inl x => Tau (iter f i x)
                                | inr y => Ret y
                                end).

Lemma unfold_iter {I} {E : event I I} {X Y : I -> Type}
           (f : X ⇒ᵢ itree E (X +ᵢ Y)) {i} (x : X i)
           : observing eqᵢ _ (iter f i x) (iter_ f i x).
constructor; reflexivity.
Qed.

Definition iterₐ_ {I} {E : event I I} {X Y i} (f : X -> itreeₐ E i i (X + Y)) x :=
  f x !>= fun r => match r with
                | inl x => tauₐ (iterₐ f x)
                | inr y => retₐ y
                end.

Lemma unfold_iterₐ {I} {E : event I I} {X Y i}
           (f : X -> itreeₐ E i i (X + Y)) (x : X)
  : observing eqᵢ _ (iterₐ f x) (iterₐ_ f x).
constructor; reflexivity.
Qed.


From Undecidability.L.AbstractMachines.FlatPro Require Import LM_heap_correct LM_heap_def.
From Undecidability.L.Prelim Require Import LoopSum.

Set Default Proof Using "Type".
Section fixH.
  Variable H : Heap.

  (* We define a function to unfold a closure, needed for the Turing machine M_unf. *)
  (* function that unfolds if unfoldable *)
  Definition unfoldTailRecStep '(stack,res) : (list (HClos*nat) * Pro) + option Pro :=
  match stack with
    | ((a,P),k)::stack =>
      match P with
        c::P =>
          match c with
            varT n =>
              if ( k <=? n)
              then
                  match lookup H a (n-k) with
                  | Some (b,Q) =>
                    inl (((b,Q),1)::(a,retT::P,S k)::stack,lamT::res)
                  | None => inr None
                  end
              else
                inl ((a,P,k)::stack,varT n::res)
          | appT => inl ((a,P,k)::stack,appT::res)
          | lamT => inl ((a,P,S k)::stack,lamT::res)
          | retT => inl ((a,P,pred k)::stack,retT::res)
          end
        | [] => inl (stack,res)
      end
    | [] => inr (Some res)
  end.

  (*
  Lemma unfoldTailRecStep_retT a k stack res fuel m:
    loopSum ((m+1) + fuel) unfoldTailRecStep ((a,repeat retT m,k)::stack,res)
    = loopSum fuel unfoldTailRecStep (stack,repeat retT m ++ res).
  Proof.
    induction m in k,res|-*;cbn. reflexivity.
    rewrite app_comm_cons,repeat_cons,<- app_assoc.
    erewrite <- IHm. reflexivity.
  Qed.

  Lemma unfoldTailRecStep_split_stack stack fuel:
  exists fuel', forall stack' res,
  loopSum fuel unfoldTailRecStep (stack++stack',res)
  = match loopSum ((fuel-fuel') + 1) unfoldTailRecStep (stack,res) with
      | Some res' => loopSum fuel' unfoldTailRecStep (stack',rev res')
      | x => x
  end /\ fuel' <= fuel.
  Proof.
    induction fuel in stack|-*.
    { exists 0. intros. destruct (loopSum (_ + 1)). all:now cbn. }
    destruct stack as [ | [[a [|c P]] k] stack].
    - exists (S fuel). intros. rewrite Nat.sub_diag.
      remember (S fuel) as tmp. cbn. now rewrite rev_involutive.
    - specialize IHfuel with (stack:=stack) as (fuel'&IH).
      exists fuel'. intros. specialize IH as (IH&?).
      rewrite Nat.sub_succ_l. 2:nia.
      cbn. rewrite IH. easy.
    - setoid_rewrite Nat.add_comm. cbn - ["-"].
      destruct c;cbn - ["-"].
      + destruct (Nat.leb_spec0 k n). destruct lookup as [[]|].
        * destruct (IHfuel ((h, l0, 1) :: (a, retT :: P, S k) :: stack)) as (fuel1&IH1). cbn in IH1.
          eexists (fuel1). intros. specialize IH1 as (->&?).
          rewrite Nat.sub_succ_l. rewrite Nat.add_1_r. all:easy.
        * destruct (IHfuel ((a, P, k) :: stack)) as (fuel1&IH1). cbn in IH1.
          eexists (fuel1). intros. specialize IH1 as (->&?).
          rewrite Nat.sub_succ_l. rewrite Nat.add_1_r. all:easy.
        * destruct (IHfuel ((a, P, k) :: stack)) as (fuel1&IH1). cbn in IH1.
          eexists (fuel1). intros. specialize IH1 as (->&?).
          rewrite Nat.sub_succ_l. rewrite Nat.add_1_r. all:easy.
      + destruct (IHfuel ((a, P, k) :: stack)) as (fuel1&IH1). cbn in IH1.
        eexists (fuel1). intros. specialize IH1 as (->&?).
        rewrite Nat.sub_succ_l. rewrite Nat.add_1_r. all:easy.
      + destruct (IHfuel ((a, P, S k) :: stack)) as (fuel1&IH1). cbn in IH1.
        eexists (fuel1). intros. specialize IH1 as (->&?).
        rewrite Nat.sub_succ_l. rewrite Nat.add_1_r. all:easy.
      + destruct (IHfuel ((a, P, Nat.pred k) :: stack)) as (fuel1&IH1). cbn in IH1.
        eexists (fuel1). intros. specialize IH1 as (->&?).
        rewrite Nat.sub_succ_l. rewrite Nat.add_1_r. all:easy.
  Qed.

(*
Lemma unfoldTailRecStep_splita a k s P stack res fuel:
  loopSum fuel unfoldTailRecStep ((a,compile s++P,k)::stack,res)
  = loopSum fuel unfoldTailRecStep ((a,compile s,k)::(a,P,k)::stack,res).
Proof.
  induction fuel in s,stack,res,P|-*. reflexivity.
  destruct s;cbn.
  - destruct (Nat.leb_spec0 k n). destruct lookup as [[]|].
  - eexists (1). cbn [loopSum unfoldTailRecStep plus compile]. cbn.
    destruct (Nat.leb_spec0 k n). now lia. easy.
    (*erewrite unfoldTailRecStep_retT. easy.*)
  - inv H2. edestruct IHunfolds with (fuel := S (fuel)) as (n'&eq1&?).
    rewrite Nat.add_succ_r in eq1.
  induction s in P,k,a,stack|-*.
  all:cbn.
Qed.*)
  *)
  Lemma unfoldTailRecStep_complete' a k s P s' stack res fuel:
    unfolds H a k s s' ->
    exists n,
    loopSum (n + fuel) unfoldTailRecStep  ((a,compile s++P,k)::stack,res)
    = loopSum fuel unfoldTailRecStep ((a,P,k)::stack,rev (compile s')++res) /\ n <= L_facts.size s' *3.
  Proof.
    induction 1 in fuel,stack,res,P|-* using unfolds_ind'.
    - eexists (1). cbn [loopSum unfoldTailRecStep plus compile]. cbn.
      destruct (Nat.leb_spec0 k n). now lia. easy.
      (*erewrite unfoldTailRecStep_retT. easy.*)
    - subst P0.
      edestruct (IHunfolds []) with (fuel := S (fuel +1)) as (n'&eq1&?).
      erewrite app_nil_r in eq1. cbn in eq1.
      eexists (S (n' + 2)). cbn.
      destruct (Nat.leb_spec0 k n). 2:now lia.
      rewrite H1. cbn.
      replace (n' + 2 + fuel) with (n' + S (fuel + 1)) by nia.
      rewrite eq1. replace (fuel +1) with (S fuel) by nia. cbn.
      repeat (autorewrite with list;cbn). easy.
    - cbn.
      edestruct (IHunfolds (retT :: P)) with (fuel := S fuel) as (n'&eq1&?).
      cbn in eq1.
      repeat (autorewrite with list;cbn).
      rewrite <- eq1.
      exists (S n' + 1). cbn. now rewrite <- Nat.add_assoc.
    - cbn. rewrite <- !app_assoc.
      specialize (IHunfolds2 ([appT] ++ P)) as (n2&IH2&?).
      specialize (IHunfolds1 (compile t ++ [appT] ++ P)) as (n1&IH1&?).
      eexists (n1+n2+1). rewrite <- !Nat.add_assoc.
      rewrite IH1,IH2. cbn.
      repeat (autorewrite with list;cbn). easy.
  Qed.

  Lemma unfoldTailRecStep_complete a k s s' n:
    unfolds H a k s s' ->
    L_facts.size s' * 3 + 2 <= n ->
    loopSum n unfoldTailRecStep ([(a,(compile s),k)],[])
    = Some (Some (rev (compile s'))).
  Proof.
    intros ? ?.
    edestruct unfoldTailRecStep_complete' with (P:=@nil Tok) as (n'&eq1&?). eassumption.
    rewrite app_nil_r in eq1.
    eapply loopSum_mono with (n:=n'+2). now Lia.nia.
    rewrite eq1. cbn. now rewrite  app_nil_r.
  Qed.

  (*
  Lemma unfoldTailRecStep_sound' P a k stack acc res fuel:
    loopSum fuel unfoldTailRecStep ((a,P,k)::stack,acc) = Some (Some res)
    -> exists s s' fuel',
                  P = compile s
                  /\ unfolds H a k s s'
                  /\ loopSum fuel unfoldTailRecStep ((a,P,k)::stack,acc)
                    = loopSum fuel' unfoldTailRecStep (stack,rev (compile s')++acc)
                  /\ fuel' <= fuel.
  Proof.
    revert P a k stack acc res.
    induction fuel as [fuel IH] using lt_wf_ind.
    intros ? ? ? ? ? ?.
    destruct fuel. easy.
    destruct P as [|[] P].
    all:cbn in *.
    -destruct (Nat.leb_spec0 k n) as [ |n0].
    destruct lookup as [[R0 b]| ] eqn:eq__lookup . 2:now congruence.
    +intros H'.
      specialize IH with (2:=H') as (s'&fuel'&R&eq'&leq'). easy.
      rewrite eq' in *.
      destruct fuel' as [ |fuel']. easy.
      cbn in *.
      exists (lam s'), fuel'.
      repeat apply conj.
      1-2:now eauto using unfolds.
      Lia.nia.
    +intros H'.
      do 2 eexists. repeat apply conj.
      2,1:now eauto 10 using unfolds,not_ge.
      Lia.nia.
    -intros H'.
    assert (IH':=IH).
    specialize IH' with (2:=H') as (s1'&fuel1&R1&eq1&leq1). easy.
    rewrite eq1 in *.
    specialize IH with (2:=H') as (s2'&fuel2&R2&eq2&leq2). easy.
    rewrite eq2 in *.
    destruct fuel2 as [ |fuel2]. easy.
    cbn in *.
    eexists _,_. repeat apply conj.
    1,2:now eauto using unfolds.
    Lia.nia.
    -intros H'.
    specialize IH with (2:=H') as (s'&fuel'&R&eq1&leq'). easy.
    rewrite eq1 in *.
    destruct fuel' as [ |fuel']. easy.
    eexists _,_. repeat apply conj.
    1,2:now eauto using unfolds.
    Lia.nia.
  Qed.

  Lemma unfoldTailRecStep_sound s a k H s' fuel:
    loopSum fuel unfoldTailRecStep ([closT (s,a) k],H,[]) = Some (Some s')
    -> unfolds H a k s s'.
  Proof.
    intros H'.
    specialize (unfoldTailRecStep_sound' H') as (k0&fuel'&R&eq'&leq').
    rewrite eq' in *. destruct fuel'. easy.
    inv H'. easy.
  Qed.

  Definition largestVarState : (list task * list heapEntry * list term) -> nat :=
    fun '(stack,H,res) => max (maxl (map (fun (t:task) =>
                                        match t with
                                          closT q _ => largestVarC q
                                        | _ => 0
                                        end) stack))
                          (max (largestVarH H) (maxl (map largestVar res))).

  Lemma unfoldTailRecStep_largestVar_inv x:
    match unfoldTailRecStep x with
      inl x' => largestVarState x'
    | inr (Some A)  => largestVar A
    | _ => 0
    end
    <= largestVarState x.

  Proof.
    unfold unfoldTailRecStep.
    repeat (let eq := fresh "eq" in destruct _ eqn:eq);inv eq;try congruence.

    all:repeat match goal with
                H : _ <=? _ = true |- _ => apply Nat.leb_le in H
              | H : _ <=? _ = false |- _ => apply Nat.leb_gt in H
              | H : lookup _ _ _ = Some _ |- _ => apply lookup_size in H;cbn in H

              end.
    all:unfold largestVarState,largestVarCs,largestVarC in *; cbn;fold maxl.
    all:try Lia.lia.
  Qed.

  Require Import Undecidability.L.Functions.Equality.

  Definition unfoldBoolean H (p:clos) : option bool :=
    let '(s,a) := p in
    match loopSum 7 unfoldTailRecStep ([closT p 1],H,[]) with
    | Some (Some t) =>
      if term_eqb (lam t) (enc true)
      then Some true
      else if term_eqb (lam t) (enc false )
          then Some false
          else None
    | _ => None
    end.

  Lemma unfoldBoolean_complete H p (b:bool) :
    reprC H p (enc b) -> unfoldBoolean H p = Some b.
  Proof.
    intros H1. inv H1. unfold unfoldBoolean.
    erewrite unfoldTailRecStep_complete. 2:easy. 2:{ destruct b;inv H2;cbn;Lia.lia. }
    destruct b;inv H2;cbv. all:reflexivity.
  Qed.

  Lemma unfoldBoolean_sound (H : list heapEntry) (p : clos) (b : bool) :
    unfoldBoolean H p = Some b -> reprC H p (enc b).
  Proof.
    unfold unfoldBoolean.
    destruct p as [P a].
    destruct loopSum as [[]| ] eqn:H'. 2-3:easy.
    eapply unfoldTailRecStep_sound in H'.
    destruct (term_eqb_spec (lam t) (enc true)).
    2: destruct (term_eqb_spec (lam t) (enc false)).
    all:inversion 1. all:inv e. all:cbv in *. all:easy.
  Qed.

  *)

End fixH.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall G A Z F E R : Universe, ((wd_ G A /\ (wd_ A Z /\ (wd_ G Z /\ (wd_ E G /\ (wd_ E Z /\ (wd_ F A /\ (wd_ F Z /\ (wd_ R G /\ (wd_ R A /\ (wd_ E F /\ (wd_ E R /\ (col_ R G A /\ (col_ E G Z /\ (col_ F A Z /\ col_ A R F)))))))))))))) -> col_ G A Z)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^383 - 187
Base: 22 + 9/17
***)

Definition curve : CurveParameters :=
  {|
    sz := 17%nat;
    base := 22 + 9/17;
    bitwidth := 32;
    s := 2^383;
    c := [(1, 187)];
    carry_chains := Some [seq 0 (pred 17); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import RndHoare.sigma_algebra.
Require Import RndHoare.measurable_function.
Require Import RndHoare.regular_conditional_prob.
Require Import RndHoare.random_oracle.
Require Import RndHoare.random_variable.
Require Import RndHoare.meta_state.
Require Import RndHoare.probabilistic_pred.

Class Imperative : Type := {
  cmd: Type;
  expr: Type;
  Sskip: cmd;
  Ssequence: cmd -> cmd -> cmd
}.

Module Sequential.

Class SmallStepSemantics {imp: Imperative}: Type := {
  state: Type;
  step: cmd * state -> MetaState (cmd * state) -> Prop
}.

Definition global_step {imp: Imperative} {sss: SmallStepSemantics} (flag: option unit) (s1 s2: MetaState (cmd * state)): Prop :=
  match flag with
  | Some tt =>
    match s1 with
    | Error => False
    | NonTerminating => False
    | Terminating cs => step cs s2
    end
  | None => s1 = s2
  end.

Record step_path {imp: Imperative} {sss: SmallStepSemantics}: Type := {
  path_states: nat -> MetaState (cmd * state);
  step_domains: nat -> option unit;
  step_sound: forall n, global_step (step_domains n) (path_states n) (path_states (S n));
  domain_mono: forall n, step_domains n = None -> step_domains (S n) = None
}.

Definition is_limit {imp: Imperative} {sss: SmallStepSemantics} (l: step_path) (lim: MetaState (cmd * state)): Prop :=
  forall s,
  lim = s <->
    (exists n, path_states l n = s /\ step_domains l n = None) \/
    (s = NonTerminating _ /\ forall n, step_domains l n = Some tt).

Definition access {imp: Imperative} {sss: SmallStepSemantics} (src dst: MetaState (cmd * state)): Prop :=
  exists (l: step_path) (n: nat), path_states l 0 = src /\ path_states l n = dst.

Definition omega_access {imp: Imperative} {sss: SmallStepSemantics} (src: MetaState (cmd * state)) (dst: MetaState (cmd * state)) : Prop :=
  exists (l: step_path), path_states l 0 = src /\ is_limit l dst.

Definition global_state {imp: Imperative} {sss: SmallStepSemantics} := MetaState state.

Definition global_state_command_state {imp: Imperative} {sss: SmallStepSemantics} (c: cmd) (s: global_state): MetaState (cmd * state) :=
  match s with
  | Error => Error _
  | NonTerminating => NonTerminating _
  | Terminating s0 => Terminating _ (c, s0)
  end.

Definition command_oaccess {imp: Imperative} {sss: SmallStepSemantics} (c: cmd) (src dst: global_state): Prop :=
  forall k, omega_access (global_state_command_state (Ssequence c k) src) (global_state_command_state k dst).

Definition triple {imp: Imperative} {sss: SmallStepSemantics} (P: global_state -> Prop) (c: cmd)  (Q: global_state -> Prop): Prop :=
  forall s1, P s1 -> forall s2, command_oaccess c s1 s2 -> Q s2.

Definition PartialAssertion {imp: Imperative} {sss: SmallStepSemantics}: Type :=
  {P: global_state -> Prop | forall s, P (Terminating _ s) -> P (NonTerminating _)}.

Definition TotalAssertion {imp: Imperative} {sss: SmallStepSemantics}: Type :=
  {P: global_state -> Prop | forall s, P (NonTerminating _) -> P (Terminating _ s)}.

Definition ptriple {imp: Imperative} {sss: SmallStepSemantics} (P: PartialAssertion) (c: cmd)  (Q: PartialAssertion): Prop := triple (proj1_sig P) c (proj1_sig Q).

Definition ttriple {imp: Imperative} {sss: SmallStepSemantics} (P: TotalAssertion) (c: cmd)  (Q: TotalAssertion): Prop := triple (proj1_sig P) c (proj1_sig Q).

End Sequential.

Module Randomized.

Class SmallStepSemantics {imp: Imperative} : Type := {
  state: Type;
  state_sig: SigmaAlgebra state;
  cmd_state_sig := (left_discreste_prod_sigma_alg cmd state);
  ora: RandomOracle;
  SFo: SigmaAlgebraFamily RandomHistory;
  HBSFo: HistoryBasedSigF ora;
  step: cmd * state -> forall {Omega: RandomVarDomain}, ProgState Omega (cmd * state)%type -> Prop
}.

Global Existing Instances state_sig cmd_state_sig ora SFo HBSFo.

Section Randomize.

Context {imp: Imperative} {sss: SmallStepSemantics}.

Record local_step (h: RandomHistory) {O1 O2: RandomVarDomain} (s1: ProgState O1 (cmd * state)) (s2: ProgState O2 (cmd * state)): Prop := {
  cs1: cmd * state;
  Omega: RandomVarDomain;
  cs2: ProgState Omega (cmd * state);
  sound1: s1 h (Terminating _ cs1);
  sound2: forall h' h'', history_app h h' h'' -> (forall x, s2 h'' x <-> cs2 h' x);
  step_fact: step cs1 cs2
}.

Record global_step {O1 O2: RandomVarDomain} (P: MeasurableSubset O1) (s1: ProgState O1 (cmd * state)) (s2: ProgState O2 (cmd * state)): Prop := {
  action_part:
    forall h, P h -> local_step h s1 s2;
  stable_part:
    forall h, ~ covered_by h P -> (forall x, s1 h x <-> s2 h x)
}.

Record step_path: Type := {
  path_domain: RandomVarDomainStream;
  path_states: ProgStateStream path_domain (cmd * state);
  step_domains: ConvergeDir path_domain;
  step_sound: forall n, global_step (step_domains n) (path_states n) (path_states (S n));
  domain_mono: forall n, future_anti_chain (step_domains n) (step_domains (S n))
}.

Definition access {O1 O2: RandomVarDomain} (src: ProgState O1 (cmd * state)) (dst: ProgState O2 (cmd * state)): Prop :=
  exists (l: step_path) (n: nat),
    RandomVar_global_equiv (path_states l 0) src /\
    RandomVar_global_equiv (path_states l n) dst.

Definition omega_access {O1 O2: RandomVarDomain} (src: ProgState O1 (cmd * state)) (dst: ProgState O2 (cmd * state)): Prop :=
  exists (l: step_path),
    RandomVar_global_equiv (path_states l 0) src /\
    is_limit (path_states l) (step_domains l) dst.

Definition global_state (Omega: RandomVarDomain) : Type := ProgState Omega state.

Global Identity Coercion global_state_ProgState: global_state >-> ProgState.

Definition command_oaccess (c: cmd) {O1 O2: RandomVarDomain} (src: global_state O1) (dst: global_state O2): Prop :=
  omega_access (ProgState_pair_left c src) (ProgState_pair_left Sskip dst).

Definition assertion: Type := RandomPred (MetaState (@state imp sss) :: nil).

Global Identity Coercion assertion_RandomPred: assertion >-> RandomPred.

Definition triple (P: assertion) (c: cmd) (Q: assertion): Prop :=
  forall o1 (s1: global_state o1), P o1 s1 ->
    forall o2 (s2: global_state o2), command_oaccess c s1 s2 ->
      same_covered_anti_chain o1 o2 /\ Q o2 s2.

(*
Definition filter_global_state {imp: Imperative} {sss: SmallStepSemantics} (filter: RandomHistory -> Prop) (s: global_state): global_state.
  exists (filter_var filter (proj1_sig s)).
  destruct s as [s ?H]; simpl.
  intros.
  destruct h as [h [?H ?H]].
  simpl in *.
  split; auto.
  apply (H (exist _ h H1)).
  auto.
Defined.
*)

(*
Require Import Coq.Sets.Ensembles.

Section PrePreds.

Context {imp: Imperative} {sss: SmallStepSemantics}.

Definition tm_meta_pred (P: state -> Prop): MetaState state -> Prop :=
  fun s => match s with Terminating s' => P s' | _ => False end.

End PrePreds.
*)
End Randomize.

End Randomized.


Require Import List.
Require Import Datatypes.
Require Import ZArith.
Require Import String.
Require Import Ascii.

Require Import VTypes.
Require Import VUtils.

Module Export HeapImpl.

Inductive tFreeStore : Type :=
    | FreeStore : tAddrs -> tAddr -> tFreeStore.

Definition fsGetStart (fs : tFreeStore) : tAddr :=
    match fs with
    | FreeStore _ start => start
    end.

Definition fsGetFreeList (fs : tFreeStore) : tAddrs :=
    match fs with
    | FreeStore freeList _ => freeList
    end.

Definition fsPutStart (start : tAddr) (fs : tFreeStore) : tFreeStore :=
    (FreeStore (fsGetFreeList fs) start).

Definition fsPutFreeList (freeList : tAddrs) (fs : tFreeStore) : tFreeStore :=
    (FreeStore freeList (fsGetStart fs)).

Definition fsIncrStart (fs : tFreeStore) : tFreeStore :=
    fsPutStart (S (fsGetStart fs)) fs.

Definition fsAllocateAddr (fs : tFreeStore) : (tAddr * tFreeStore) :=
    match fs with
    | FreeStore nil start => (start, fsIncrStart fs)
    | FreeStore (fAddr::fAddrs) start => (fAddr, fsPutFreeList fAddrs fs)
    end.

Definition fsFreeAddr (addr : tAddr) (fs : tFreeStore) : tFreeStore :=
    (FreeStore (addr::(fsGetFreeList fs)) (fsGetStart fs)).

Inductive tHeap (X : Type) : Type :=
    | Heap : nat -> tFreeStore -> tAssocs tAddr X -> tHeap X.

Implicit Arguments Heap [[X]].

Definition getHeapSize {X : Type} (h : tHeap X) : nat :=
    match h with
    | Heap size freeaddrs assocs => size
    end.

Definition getHeapFreeStore {X : Type} (h : tHeap X) : tFreeStore :=
    match h with
    | Heap size freeStore assocs => freeStore
    end.

Definition getHeapAssocs {X : Type} (h : tHeap X) : tAssocs tAddr X :=
    match h with
    | Heap size freeStore assocs => assocs
    end.

Definition putHeapSize {X : Type} (size : nat) (h : tHeap X) : tHeap X :=
    (Heap size (getHeapFreeStore h) (getHeapAssocs h)).

Definition putHeapFreeStore (fs : tFreeStore) {X : Type} (h : tHeap X) : tHeap X :=
    (Heap (getHeapSize h) fs (getHeapAssocs h)).

Definition putHeapAssocs {X : Type} (assocs : tAssocs tAddr X) (h : tHeap X) : tHeap X :=
    (Heap (getHeapSize h) (getHeapFreeStore h) assocs).

Definition addrComparator (addr1 addr2 : tAddr) : bool :=
    beq_nat addr1 addr2.

Definition incrHeapSize {X : Type} (h : tHeap X) : tHeap X :=
    putHeapSize (S (getHeapSize h)) h.

Definition decrHeapSize {X : Type} (h : tHeap X) : tHeap X :=
    match getHeapSize h with
    | O => h
    | S n => putHeapSize n h
    end.

Definition allocateAddr {X : Type} (h : tHeap X) : option ((tHeap X) * tAddr) :=
    match (fsAllocateAddr (getHeapFreeStore h)) with
    | (free, freeStore) => Some (putHeapFreeStore freeStore (incrHeapSize h), free)
    end.

Definition hAlloc {X : Type} (h : tHeap X) (a : X) : option ((tHeap X) * tAddr) :=
    match allocateAddr h with
    | Some (h', newaddr) => Some (putHeapAssocs ((newaddr, a)::(getHeapAssocs h')) h', newaddr)
    | None => None
    end.

Definition hLookup {X : Type} (h : tHeap X) (addr : tAddr) : option X :=
    assocLookup (getHeapAssocs h) addr beq_nat.

Definition hUpdate {X : Type} (h : tHeap X) (addr : tAddr) (x : X) : tHeap X :=
    putHeapAssocs ((addr, x) :: (assocRemove (getHeapAssocs h) addr beq_nat)) h.

Definition hFree (X : Type) (h : tHeap X) (addr : tAddr) : tHeap X :=
    putHeapFreeStore
        (fsFreeAddr addr (getHeapFreeStore h))
        (putHeapAssocs
            (assocRemove
                (getHeapAssocs h)
                addr
                beq_nat)
            (decrHeapSize h)
        ).

End HeapImpl.