(* Coq 8.9.1 *)

Require Import String.
Require Import Coq.Strings.String.
Local Open Scope string_scope.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Logic.FunctionalExtensionality.
Require Coq.MSets.MSetWeakList.
Module WS := Coq.MSets.MSetWeakList.
Require Coq.MSets.MSetFacts.
Module MSF := Coq.MSets.MSetFacts.
Require Coq.MSets.MSetProperties.
Module MSP := Coq.MSets.MSetProperties.
Require Coq.Structures.Equalities.
Module SE := Coq.Structures.Equalities.
Require Import Coq.Logic.Decidable.
Require Coq.Logic.Classical_Pred_Type.
Module CPT := Coq.Logic.Classical_Pred_Type.
Require Import Coq.Program.Equality.
Require Coq.Logic.Classical_Prop.
Module CP := Coq.Logic.Classical_Prop.
Require Coq.FSets.FMapWeakList.
Module FMW := Coq.FSets.FMapWeakList.
Require Coq.FSets.FMapFacts.
Module FMF := Coq.FSets.FMapFacts.

(* standard library lemma *)
Axiom Forall_app :
    forall {A : Type} (P : A -> Prop) (l1 l2 : list A),
    Forall P (l1 ++ l2) <-> Forall P l1 /\ Forall P l2.

(* Hindley-Milner Type-System *)

Ltac inv H := inversion H; subst.

Ltac injintrosubst H := injection H; intros; subst.

Definition id := string.

Module IdDec <: SE.DecidableType.
    Import SE.
    Require Import RelationClasses.
    Definition t := id.
    Definition eq (x1 x2 : t) := x1 = x2.
    Declare Instance eq_equiv : Equivalence eq.
    Theorem eq_dec : forall (x1 x2 : t),
        {x1 = x2} + {x1 <> x2}.
    Proof. intros. apply string_dec. Qed.
    Theorem eq_refl : forall (x : t), x = x.
    Proof. intros. reflexivity. Qed.
    Theorem eq_sym : forall (x y : t), x = y -> y = x.
    Proof. unfold eq. intros; subst; reflexivity. Qed.
    Theorem eq_trans : forall (x y z : t), x = y -> y = z -> x = z.
    Proof. intros; subst. reflexivity. Qed.
End IdDec.

(* variable sets *)
Module IS := WS.Make(IdDec).
Module ISF := MSF.WFactsOn(IdDec)(IS).
Module ISP := MSP.WPropertiesOn(IdDec)(IS).

Module TypeSyntax.
    Inductive type : Type :=
        | TUnit
        | TVar (X : id)
        | TFun (t1 t2 : type).

    Definition names : Type := IS.t.

    Fixpoint fv (t : type) : names :=
        match t with
        | TUnit => IS.empty
        | TVar X => IS.singleton X
        | TFun t1 t2 => IS.union (fv t1) (fv t2)
        end.

    (* type variable in a type *)
    Fixpoint TIn (X : id) (t : type) : Prop :=
        match t with
        | TUnit => False
        | TVar Y => X = Y
        | TFun t1 t2 => TIn X t1 \/ TIn X t2
        end.
End TypeSyntax.
Export TypeSyntax.

(* Signature for type substitution. *)
Module Type Sigma.
    (* Sigma: maps type variables
        to monomorphic types. *)
    Parameter t : Type.

    Parameter empty : t.

    Parameter bind : id -> type -> t -> t.

    Parameter get : id -> t -> option type.

    Axiom get_empty :
        forall (X : id), get X empty = None.

    Axiom bind_correct :
        forall (X : id) (ty : type) (s : t),
        get X (bind X ty s) = Some ty.

    Axiom bind_complete :
        forall {X Y : id}, Y <> X ->
        forall (s : t) (ty : type),
        get X (bind Y ty s) = get X s.

    (* Sigma composition:
        compose s1 s2 X = s2(s1(X)) *)
    Parameter compose : t -> t -> t.

    Axiom compose_empty :
        forall (s : t),
        compose empty s = s.

    Fixpoint sub_type (s : t) (t : type) : type :=
        match t with
        | TUnit => TUnit
        | TVar X =>
            match get X s with
            | None => TVar X
            | Some t' => t'
            end
        | TFun t1 t2 => TFun (sub_type s t1) (sub_type s t2)
        end.

    Axiom compose_correct :
        forall (s1 s2 : t) (ty : type),
        sub_type (compose s1 s2) ty = (sub_type s2 (sub_type s1 ty)).

    Axiom sub_type_bind_notin :
        forall (X : id) (ty : type),
        ~ TIn X ty ->
        forall (T : type),
        sub_type (bind X T empty) ty = ty.
End Sigma.

Module SigmaSubstitution(S : Sigma).
    Lemma sub_type_empty :
        forall (t : type),
        S.sub_type S.empty t = t.
    Proof.
        intros t. induction t;
        try reflexivity; simpl.
        - rewrite S.get_empty. reflexivity.
        - rewrite IHt1. rewrite IHt2. reflexivity.
    Qed.

    Lemma sub_type_bind :
        forall (X : id) (ty : type) (s : S.t),
        ~ TIn X ty ->
        S.sub_type (S.compose (S.bind X ty S.empty) s) (TVar X) =
            S.sub_type (S.compose (S.bind X ty S.empty) s) ty.
    Proof.
        intros X ty s HIn.
        rewrite S.compose_correct.
        rewrite S.compose_correct. simpl.
        destruct (X =? X)%string eqn:eq;
        simpl in *.
        - rewrite S.bind_correct.
            rewrite S.sub_type_bind_notin; auto.
        - apply eqb_neq in eq. contradiction.
    Qed.

    Lemma sub_type_bind_inj :
        forall (s : S.t) (X : id) (ty T : type),
        S.sub_type s (S.sub_type (S.bind X ty S.empty) T) =
        S.sub_type (S.compose (S.bind X ty S.empty) s) T.
    Proof.
        intros s X ty T. rewrite S.compose_correct.
        reflexivity.
    Qed.

    Definition eq (s1 s2 : S.t) :=
        forall (X : id), S.get X s1 = S.get X s2.

    Lemma eq_get :
        forall (s1 s2 : S.t),
        s1 = s2 -> eq s1 s2.
    Proof.
        intros s1 s2 H. subst.
        unfold eq. intros X.
        reflexivity.
    Qed.

    (* should change other definitions later... *)
    Axiom eq_extensional :
        forall (s1 s2 : S.t),
        eq s1 s2 -> s1 = s2.
End SigmaSubstitution.

Module ConstraintEquations.
    Definition equation : Type := type * type.

    Definition constraint : Type := list equation.

    (* type variable in an equation *)
    Fixpoint EQIn (X : id) (eq : equation) : Prop :=
        let (t1,t2) := eq in TIn X t1 \/ TIn X t2.

    (* type variable in a constraint *)
    Definition CIn (X : id) (C : constraint) : Prop :=
        Exists (EQIn X) C.
End ConstraintEquations.
Export ConstraintEquations.

Module Unification(S : Sigma).
    Module SS := SigmaSubstitution S.

    Definition satisfy_equation (s : S.t) (eq : equation) : Prop :=
        let (t1,t2) := eq in S.sub_type s t1 = S.sub_type s t2.

    Definition satisfy_constraint (s : S.t) (C : constraint) : Prop :=
    Forall (satisfy_equation s) C.

    Definition sub_equation (s : S.t) (eq : equation) : equation :=
            let (t1,t2) := eq in (S.sub_type s t1, S.sub_type s t2).

    Definition sub_constraint (s : S.t) (C : constraint) : constraint :=
        map (sub_equation s) C.

    Inductive unify : constraint -> S.t -> Prop :=
        | unify_nil : unify [] S.empty
        | unify_eq :
            forall (t : type) (C : constraint) (s : S.t),
            unify C s ->
            unify ((t,t) :: C) s
        | unify_left_var :
            forall (X : id) (t : type) (C : constraint) (s : S.t),
            ~ TIn X t ->
            unify (sub_constraint (S.bind X t S.empty) C) s ->
            unify ((TVar X, t) :: C) (S.compose (S.bind X t S.empty) s)
        | unify_right_var :
            forall (X : id) (t : type) (C : constraint) (s : S.t),
            ~ TIn X t ->
            unify (sub_constraint (S.bind X t S.empty) C) s ->
            unify ((t, TVar X) :: C) (S.compose (S.bind X t S.empty) s)
        | unify_fun :
            forall (a1 a2 b1 b2 : type) (C : constraint) (s : S.t),
            unify ((a1,a2) :: (b1,b2) :: C) s ->
            unify ((TFun a1 b1, TFun a2 b2) :: C) s.

    Definition more_general (s s' : S.t) : Prop :=
        exists (s'' : S.t), s' = S.compose s s''.

    Definition principal_unifier (C : constraint) (s : S.t) : Prop :=
        satisfy_constraint s C /\
        forall (s' : S.t),
        satisfy_constraint s' C ->  more_general s s'.

    Lemma satisfy_equation_sym :
        forall (s : S.t) (t1 t2 : type),
        satisfy_equation s (t1,t2) ->
        satisfy_equation s (t2,t1).
    Proof.
        intros s t1 t2 H.
        unfold satisfy_equation in *. auto.
    Qed.

    Lemma satisfy_constraint_compose :
        forall (s : S.t) (X : id) (t : type) (C : constraint),
        satisfy_constraint s (sub_constraint (S.bind X t S.empty) C) ->
        satisfy_constraint (S.compose (S.bind X t S.empty) s) C.
    Proof.
        intros s X t C H.
        unfold satisfy_constraint in *.
        induction C; constructor; inv H; auto.
        destruct a as [t1 t2].
        unfold satisfy_equation in *.
        simpl in H2. clear H3 IHC H.
        rewrite <- SS.sub_type_bind_inj.
        rewrite <- SS.sub_type_bind_inj.
        assumption.
    Qed.

    Lemma satisfy_equation_compose :
        forall (X : id) (t : type) (s : S.t),
        ~ TIn X t ->
        satisfy_equation (S.compose (S.bind X t S.empty) s) (TVar X, t).
    Proof.
        intros X t s HIn. unfold satisfy_equation.
        apply SS.sub_type_bind; auto.
    Qed.

    Theorem unify_correct :
        forall (C : constraint) (s : S.t),
        unify C s -> satisfy_constraint s C.
    Proof.
        intros C s HU. induction HU; constructor; auto.
        - unfold satisfy_equation. reflexivity.
        - apply satisfy_equation_compose. assumption.
        - apply satisfy_constraint_compose. assumption.
        - apply satisfy_equation_sym.
            apply satisfy_equation_compose.
            assumption.
        - apply satisfy_constraint_compose. assumption.
        - inv IHHU. simpl in *. rewrite H1. inv H2.
            inv H3. rewrite H0. reflexivity.
        - inv IHHU. inv H2. assumption.
    Qed.

    Lemma satisfy_sub_type_equation :
        forall (X : id) (T : type) (s : S.t),
        (* ~ TIn X T -> *)
        satisfy_equation s (TVar X, T) ->
        forall (E : equation),
        satisfy_equation s E ->
        satisfy_equation s (sub_equation (S.bind X T S.empty) E).
    Proof.
        intros Z T s HS.
        intros [t1 t2]. generalize dependent t2.
        induction t1; induction t2; intros H; auto;
        try discriminate; simpl in *;
        try (destruct (IdDec.eq_dec X Z) as [HX | HX]; subst;
            try rewrite S.bind_correct;
            try (rewrite S.bind_complete; auto;
                rewrite S.get_empty; simpl);
                try rewrite HS in H;
                try rewrite H in HS;
                assumption);
        try (destruct (IdDec.eq_dec X0 Z) as [HX0 | HX0];
            destruct (IdDec.eq_dec X Z) as [HX | HX];
            subst; auto;
            try rewrite S.bind_correct;
            try rewrite S.bind_complete;
            try rewrite S.bind_complete; auto;
            try rewrite S.get_empty;
            try rewrite S.get_empty; auto; simpl;
            rewrite <- HS; assumption).
        - destruct (IdDec.eq_dec X Z) as [HXZ | HXZ]; subst.
            + rewrite S.bind_correct.
                rewrite HS in H.
                rewrite H.
                (* Induction is inaccurate...
                    perhaps need to define induction
                    for equations...?*)
                rewrite S.bind_correct in IHt2_2.
                rewrite S.bind_correct in IHt2_1.
                admit.
            + admit.
        - destruct (S.get X s) eqn:eq;
            try discriminate.
            destruct (IdDec.eq_dec X Z) as [HXZ | HXZ]; subst.
            + rewrite S.bind_correct.
                rewrite eq in HS. rewrite <- HS.
                admit.
            + admit.
        - injintrosubst H.
            apply IHt1_1 in H1.
            apply IHt1_2 in H0.
            rewrite H0. rewrite H1.
            reflexivity.
    Admitted.

    Lemma satisfy_sub_type_constraint :
        forall (X : id) (T : type) (s : S.t),
        (* ~ TIn X T -> *)
        satisfy_equation s (TVar X, T) ->
        forall (C : constraint),
        satisfy_constraint s C ->
        satisfy_constraint s (sub_constraint (S.bind X T S.empty) C).
    Proof.
        intros X T s HS C HC.
        unfold satisfy_constraint in *.
        induction HC; constructor; auto.
        apply satisfy_sub_type_equation; auto.
    Qed.

    Theorem unify_principal :
        forall (C : constraint) (s : S.t),
        unify C s -> principal_unifier C s.
    Proof.
        intros C s HU. unfold principal_unifier. split.
        - apply unify_correct; auto.
        - induction HU; try (intros s' HSC; unfold more_general).
            + exists s'. rewrite S.compose_empty.
                reflexivity.
            + inv HSC. apply IHHU in H2. assumption.
            + inv HSC.
                apply satisfy_sub_type_constraint
                    with (C := C) in H2; auto.
                apply IHHU in H2.
                unfold more_general in H2.
                destruct H2 as [s'' HG].
                assert (Hs' : s' = S.compose (S.compose (S.bind X t S.empty) s) s'').
                { apply SS.eq_extensional.
                    apply SS.eq_get in HG.
                    unfold SS.eq in *.
                    intros Y. pose proof HG Y as HGY.
                    destruct (IdDec.eq_dec Y X); subst;
                    (* Need better notions of equality,
                        espeically with respect to composition. *)
                    admit. }
                { exists s''. assumption. }
            + admit.
            + assert (H : satisfy_constraint
                s' ((a1, a2) :: (b1, b2) :: C)).
                * inv HSC. inv H1.
                    constructor; auto.
                * apply IHHU in H. assumption.
    Admitted.
End Unification.

Module Monomorphic.
    Section TypeMap.
        Context {T : Type}.

        Definition tmap := id -> option T.

        Definition tempty : tmap := fun x => None.

        Definition bind (x : id) (t : T) (m : tmap) : tmap :=
            fun y => if (x =? y)%string then Some t else m y.

        Lemma bind_correct :
            forall (x : id) (t : T) (m : tmap),
            bind x t m x = Some t.
        Proof.
            intros. unfold bind. destruct ((x =? x)%string) eqn:eq.
            - reflexivity.
            - apply eqb_neq in eq. contradiction.
        Qed.

        Lemma bind_complete :
            forall (x x' : id) (t t' : T),
            x' <> x ->
            forall (m : tmap),
            (m x = Some t <-> bind x' t' m x = Some t).
        Proof.
            intros. unfold bind. apply eqb_neq in H.
            rewrite H. split; intros; apply H0.
        Qed.

        Lemma rebind_correct :
            forall (x : id) (t t' : T) (m : tmap),
            bind x t m = bind x t (bind x t' m).
        Proof.
            intros. apply functional_extensionality. intros y.
            unfold bind. destruct ((x =? y)%string); reflexivity.
        Qed.

        Lemma bind_diff_comm :
            forall (x y : id) (u v : T) (m : tmap),
            x <> y ->
            bind x u (bind y v m) = bind y v (bind x u m).
        Proof.
            intros. apply functional_extensionality. intros z.
            unfold bind. destruct ((x =? z)%string) eqn:eq.
                - apply eqb_eq in eq; subst.
                    destruct ((y =? z)%string) eqn:eeq.
                    + apply eqb_eq in eeq; subst. contradiction.
                    + reflexivity.
                - apply eqb_neq in eq. destruct ((y =? z)%string) eqn:eeq; reflexivity.
        Qed.
    End TypeMap.
    Definition bind_correct_type := @bind_correct type.

    Module Syntax.
        Inductive expr : Type :=
            | EUnit
            | EVar (x : id)
            | EFun (x : id) (t : type) (e : expr)
            | EApp (e1 e2 : expr).

        (* type variable in an expression *)
        Fixpoint EIn (X : id) (e : expr) : Prop :=
            match e with
            | EUnit | EVar _ => False
            | EFun _ t e => TIn X t \/ EIn X e
            | EApp e1 e2 => EIn X e1 \/ EIn X e2
            end.
    End Syntax.
    Export Syntax.

    Section TypeCheck.
        Definition gamma : Type := @tmap type.

        Inductive check (g : gamma) : expr -> type -> Prop :=
            | check_unit :
                check g EUnit TUnit
            | check_var :
                forall (x : id) (t : type),
                g x = Some t ->
                check g (EVar x) t
            | check_fun :
                forall (x : id) (t1 t2 : type) (e : expr),
                check (bind x t1 g) e t2 ->
                check g (EFun x t1 e) (TFun t1 t2)
            | check_app :
                forall (e1 e2 : expr) (t1 t2 : type),
                check g e1 (TFun t1 t2) ->
                check g e2 t1 ->
                check g (EApp e1 e2) t2.
    End TypeCheck.

    Module S <: Sigma.
        Definition t : Type := @tmap type.

        Definition empty : t := tempty.

        Definition bind : id -> type -> t -> t := bind.

        Definition get (x :id) (s : S.t) : option type := s x.

        Lemma bind_get_eta_eq :
            forall (X Y : id) (s : t) (ty : type),
            bind X ty s Y = get Y (bind X ty s).
        Proof. intros X Y s ty. reflexivity. Qed.

        Lemma get_empty :
            forall (X : id), get X empty = None.
        Proof. intros X. reflexivity. Qed.

        Lemma bind_correct :
            forall (x : id) (ty : type) (s : t),
            get x (bind x ty s) = Some ty.
        Proof. intros x ty s. apply bind_correct. Qed.

        Lemma bind_complete :
            forall {x y : id}, y <> x ->
            forall (s : t) (ty : type),
            get x (bind y ty s) = get x s.
        Proof.
            intros x y Hxy s ty. unfold get.
            unfold bind. unfold Monomorphic.bind.
            apply eqb_neq in Hxy. rewrite Hxy.
            reflexivity.
        Qed.

        Fixpoint sub_type (s : t) (t : type) : type :=
            match t with
            | TUnit => TUnit
            | TVar X =>
                match get X s with
                | None => TVar X
                | Some t' => t'
                end
            | TFun t1 t2 => TFun (sub_type s t1) (sub_type s t2)
            end.

        Definition compose (s1 s2 : t) : t :=
            fun X =>
                match get X s1 with
                | None => get X s2
                | Some t => Some (sub_type s2 t)
                end.

        Lemma compose_empty :
            forall (s : t),
            s = compose empty s.
        Proof.
            intros s. apply functional_extensionality.
            intros x. reflexivity.
        Qed.

        Lemma compose_correct :
            forall (s1 s2 : t) (ty : type),
            sub_type (compose s1 s2) ty = (sub_type s2 (sub_type s1 ty)).
        Proof.
            intros s1 s2 ty. induction ty;
            auto; simpl.
            - unfold compose; unfold get.
                destruct (s1 X) eqn:eq; auto.
            - rewrite IHty1. rewrite IHty2.
                reflexivity.
        Qed.

        Lemma sub_type_bind_notin :
            forall (X : id) (ty : type),
            ~ TIn X ty ->
            forall (T : type),
            sub_type (bind X T empty) ty = ty.
        Proof.
            intros X ty. induction ty;
            intros HIn T; simpl in *; auto.
            - rewrite bind_complete; auto.
            - apply CP.not_or_and in HIn as [H1 H2].
                apply IHty1 with (T := T) in H1.
                apply IHty2 with (T := T) in H2.
                rewrite H1. rewrite H2. reflexivity.
        Qed.
    End S.

    Module SS := SigmaSubstitution S.

    Section TypeSubstitution.
        Definition sub_gamma (s : S.t) (g : gamma) : gamma :=
            fun x =>
                match g x with
                | None => None
                | Some t => Some (S.sub_type s t)
                end.

        Fixpoint sub_expr (s : S.t) (e : expr) : expr :=
            match e with
            | EUnit => EUnit
            | EVar x => EVar x
            | EFun x t e => EFun x (S.sub_type s t) (sub_expr s e)
            | EApp e1 e2 => EApp (sub_expr s e1) (sub_expr s e2)
            end.

        Lemma bind_sub_gamma :
            forall (s : S.t) (g : gamma) (x : id) (t : type),
            sub_gamma s (bind x t g) = bind x (S.sub_type s t) (sub_gamma s g).
        Proof.
            intros s g x t.
            apply functional_extensionality.
            intros y.
            destruct (IdDec.eq_dec x y);
            subst; simpl;
            unfold sub_gamma;
            try rewrite bind_correct;
            try rewrite bind_correct;
            try reflexivity.
            unfold bind.
            apply eqb_neq in n as HF.
            rewrite HF. reflexivity.
        Qed.

        Theorem substutution_preserves_typing :
            forall (g : gamma) (e : expr) (t : type),
            check g e t ->
            forall (s : S.t),
            check (sub_gamma s g) (sub_expr s e) (S.sub_type s t).
        Proof.
            intros g e t H. induction H; intros s; try constructor.
            - unfold sub_gamma. rewrite H. reflexivity.
            - fold S.sub_type. fold sub_expr.
                rewrite <- bind_sub_gamma.
                apply IHcheck.
            - apply check_app with (t1 := S.sub_type s t1);
                fold sub_expr; auto.
                specialize IHcheck1 with (s := s).
                simpl in IHcheck1. assumption.
        Qed.

        Definition solution (g : gamma) (e : expr) (s : S.t) (t : type) : Prop :=
        check (sub_gamma s g) (sub_expr s e) t.
    End TypeSubstitution.

    Module U := Unification S.
    Export U.

    Module ConstraintTyping.
        (* type variable not in gamma *)
        Definition GNIn (X : id) (g : gamma) : Prop :=
            forall (x : id) (t : type),
            g x = Some t -> ~ TIn X t.

        Inductive constraint_type (g : gamma)
        : expr -> type -> names -> constraint -> Prop :=
            | ct_unit :
                constraint_type g EUnit TUnit IS.empty []
            | ct_var :
                forall (x : id) (t : type),
                g x = Some t ->
                constraint_type g (EVar x) t IS.empty []
            | ct_fun :
                forall (x : id) (t1 t2 : type)
                    (e : expr) (X : names) (C : constraint),
                constraint_type (bind x t1 g) e t2 X C ->
                constraint_type g (EFun x t1 e) (TFun t1 t2) X C
            | ct_app :
                forall (e1 e2 : expr) (t1 t2 : type) (X : id)
                    (X1 X2 : names) (C1 C2 : constraint),
                constraint_type g e1 t1 X1 C1 ->
                constraint_type g e2 t2 X2 C2 ->
                IS.Empty (IS.inter X1 X2) ->
                IS.Empty (IS.inter X1 (fv t2)) ->
                IS.Empty (IS.inter X2 (fv t1)) ->
                ~ IS.In X X1 -> ~ IS.In X X2 ->
                ~ TIn X t1 -> ~ TIn X t2 ->
                ~ EIn X e1 -> ~ EIn X e2 ->
                ~ CIn X C1 -> ~ CIn X C2 -> GNIn X g ->
                constraint_type g (EApp e1 e2) (TVar X)
                    (IS.add X (IS.union X1 X2))
                    ((t1, TFun t2 (TVar X)) :: C1 ++ C2).

        Definition constraint_solution
        {g : gamma} {e : expr} {t : type} {X : names} {C : constraint}
        (H : constraint_type g e t X C) (s : S.t) (T : type) : Prop :=
        satisfy_constraint s C /\ S.sub_type s t = T.

        Theorem Constraint_Typing_Sound :
            forall (g : gamma) (e : expr) (t : type)
                (X : names) (C : constraint)
                (H : constraint_type g e t X C)
                (s : S.t) (T : type),
            constraint_solution H s T -> solution g e s T.
        Proof.
            intros g e t X C H s T HCS.
            destruct HCS as [HSC HSE].
            unfold solution. subst.
            induction H.
            - constructor.
            - apply substutution_preserves_typing.
                constructor; auto.
            - constructor.
                fold S.sub_type. fold sub_expr.
                rewrite <- bind_sub_gamma. auto.
            - inv HSC.
                apply Forall_app in H16 as [HC1 HC2].
                apply check_app with (t1 := S.sub_type s t2); auto.
                fold sub_expr.
                apply IHconstraint_type1 in HC1.
                unfold satisfy_equation in H15.
                rewrite H15 in HC1. simpl in HC1.
                assumption.
        Qed.

        (* s/N *)
        Definition sigma_diff (s : S.t) (N : names) : S.t :=
            fun X => if IS.mem X N then None else s X.

        Theorem Constraint_Typing_Complete :
            forall (g : gamma) (e : expr) (t : type)
            (X : names) (C : constraint)
            (H : constraint_type g e t X C)
            (s : S.t) (T : type),
            sigma_diff s X = s ->
            solution g e s T ->
            exists (s' : S.t),
            sigma_diff s' X = s /\ constraint_solution H s' T.
        Proof.
            intros g e t X C H.
            (* Coq won't let me do induction on H *)
            (* induction H. *)
        Abort.
    End ConstraintTyping.
    Export ConstraintTyping.

    Section PrincipalTypes.
        Definition principal_solution
        {g : gamma} {e : expr} {t : type} {X : names} {C : constraint}
        (H : constraint_type g e t X C) (s : S.t) (T : type) : Prop :=
        constraint_solution H s T /\
        forall (s' : S.t) (T' : type),
        constraint_solution H s' T' -> more_general s s'.

        Corollary unify_principal_solution :
            forall {g : gamma} {e : expr} {t : type} {X : names} {C : constraint}
                (H : constraint_type g e t X C) (s : S.t),
            unify C s ->
            principal_solution H s (S.sub_type s t).
        Proof.
            intros g e t X C H s HU.
            apply unify_principal in HU as HUC.
            unfold principal_unifier in HUC.
            unfold principal_solution.
            destruct HUC as [HSC HMG]. split.
            - unfold constraint_solution. split; auto.
            - intros s' T' Hs'T'.
                unfold constraint_solution in Hs'T'.
                destruct Hs'T' as [HSCs' HSTs']. auto.
        Qed.

        Lemma constraint_solution_unify :
            forall {g : gamma} {e : expr} {t : type} {X : names} {C : constraint}
                (H : constraint_type g e t X C) (s' : S.t) (T' : type),
            constraint_solution H s' T' ->
            exists (s : S.t), unify C s.
        Proof.
            intros g e t X C H s' T' HCS.
            unfold constraint_solution in HCS.
            destruct HCS as [HSC HST].
            dependent induction H; simpl in *;
            try (exists tempty; apply unify_nil).
            - apply IHconstraint_type
                with (T' := S.sub_type s' t2) in HSC; auto.
            - inv HSC. apply Forall_app in H16 as [HC1 HC2].
                apply IHconstraint_type1
                    with (T' := S.sub_type s' t1) in HC1; auto.
                apply IHconstraint_type2
                    with (T' := S.sub_type s' t2) in HC2; auto.
                destruct HC1 as [s1 HU1].
                destruct HC2 as [s2 HU2].
                destruct t1.
                + inv H15.
                + exists (S.compose (S.bind X0 (TFun t2 (TVar X)) tempty) (S.compose s1 s2)).
                    constructor; admit.
                + exists (S.compose s1 s2).
                    constructor. admit.
        Admitted.

        Theorem principal_types :
            forall {g : gamma} {e : expr} {t : type} {X : names} {C : constraint}
                (H : constraint_type g e t X C),
            (exists (s' : S.t) (T' : type), constraint_solution H s' T') ->
            exists (s : S.t) (T : type), principal_solution H s T.
        Proof.
            intros g e t X C H [s' [T' HCS]].
            apply constraint_solution_unify in HCS.
            destruct HCS as [s HU].
            exists s. exists (S.sub_type s t).
            apply unify_principal_solution; auto.
        Qed.

        (* Interleave constraint generation and unification.
            Should generate a principal type at each step. *)
        Inductive interleave (g : gamma) : expr -> type -> Prop :=
            | il_unit : interleave g EUnit TUnit
            | il_var :
                forall (x : id) (t : type),
                g x = Some t ->
                interleave g (EVar x) t
            | il_fun :
                forall (x : id) (t1 t2 : type) (e : expr),
                interleave (bind x t1 g) e t2 ->
                interleave g (EFun x t1 e) (TFun t1 t2)
            | il_app :
                forall (e1 e2 : expr) (t1 t2 : type) (X : id) (s : S.t),
                interleave g e1 t1 ->
                interleave g e2 t2 ->
                ~ TIn X t1 -> ~ TIn X t2 ->
                ~ EIn X e1 -> ~ EIn X e2 -> GNIn X g ->
                unify [(t1, TFun t2 (TVar X))] s ->
                interleave g (EApp e1 e2) (S.sub_type s (TVar X)).

        Proposition interleave_sound :
            forall (g : gamma) (e : expr) (t : type),
            interleave g e t ->
            forall (N : names) (C : constraint)
                (H : constraint_type g e t N C),
            exists (s : S.t), unify C s /\ constraint_solution H s t.
        Proof.
            intros g e t HIL.
            induction HIL; intros N C HCT; inv HCT;
            unfold constraint_solution.
            - exists tempty. repeat split; constructor.
            - exists tempty. repeat split;
                try constructor. apply SS.sub_type_empty.
            - pose proof IHHIL N C H5 as IH.
                destruct IH as [s [HU HCS]].
                unfold constraint_solution in HCS.
                exists s. destruct HCS as [HSC HST].
                repeat split; auto.
                simpl. rewrite HST. admit.
            - admit.
            (* white flag. *)
            (* pose proof IHHIL1 X1 C1 H8 as IH1. *)
        Abort.
    End PrincipalTypes.

    Section Examples.
        Ltac ex222 t :=
            apply check_app with (t1 := t);
            constructor; reflexivity.

        Definition f : id := "f".
        Definition a : id := "a".
        Definition x : id := "x".
        Definition y : id := "y".
        Definition z : id := "z".
        Definition X : id := "X".
        Definition Y : id := "Y".
        Definition Z : id := "Z".

        Definition g : gamma := bind f (TVar X) (bind a (TVar Y) tempty).
        Definition e : expr := EApp (EVar f) (EVar a).

        Example ex2221 :
            solution g e (S.bind X (TFun (TVar Y) TUnit) tempty) TUnit.
        Proof. ex222 (TVar Y). Qed.

        Example ex2222 :
            solution g e (S.bind X (TFun (TVar Y) (TVar Z)) (S.bind Z TUnit tempty)) (TVar Z).
        Proof. ex222 (TVar Y). Qed.

        Example ex2223 :
            solution g e (S.bind X (TFun TUnit TUnit) (S.bind Y TUnit tempty)) TUnit.
        Proof. ex222 TUnit. Qed.

        Example ex224 :
            solution g e (S.bind X (TFun (TVar Y) (TVar Z)) tempty) (TVar Z).
        Proof. ex222 (TVar Y). Qed.

        Example ex2225 :
            solution g e (S.bind X (TFun (TVar Y) (TFun TUnit TUnit)) tempty) (TFun TUnit TUnit).
        Proof. ex222 (TVar Y). Qed.

        Definition term : expr :=
            EFun x (TVar X) (EFun y (TVar Y) (EFun z (TVar Z)
                (EApp (EApp (EVar x) (EVar z)) (EApp (EVar y) (EVar z))))).

        Example ex2231 :
            let s := (bind Y (TFun (TVar Z) TUnit) (bind X (TFun (TVar Z) (TFun TUnit TUnit)) tempty)) in
            solution tempty term s (S.sub_type s (TFun (TVar X) (TFun (TVar Y) (TFun (TVar Z) TUnit)))).
        Proof.
            unfold solution. simpl.
            repeat apply check_fun.
            apply check_app with (t1 := TUnit).
            - apply check_app with (t1 := TVar Z);
                constructor; reflexivity.
            - apply check_app with (t1 := TVar Z);
                constructor; reflexivity.
        Qed.

        Ltac ct_app_apply :=
            apply ct_app;
            try (intros HF; simpl in HF;
                subst; discriminate);
            try (intros HF; simpl in HF;
                subst; contradiction).

        (* MSet library is a pain to work with... *)
        Axiom empty_inter :
            forall (x y : id),
            x <> y <->
            IS.Empty (IS.inter (IS.singleton x) (IS.singleton y)).

        Example ex2233 :
            exists (t : type) (N : names) (C : constraint),
            constraint_type tempty term t N C.
        Proof.
            unfold term.
            remember "T" as T in *.
            remember "U" as U in *.
            remember "V" as V in *.
            remember "W" as W in *.
            exists (TFun (TVar X) (TFun (TVar Y) (TFun (TVar Z) (TVar W)))).
            exists (IS.add W
                (IS.union
                    (IS.add U (IS.union IS.empty IS.empty))
                    (IS.add V (IS.union IS.empty IS.empty)))).
            exists ((TVar U, TFun (TVar V) (TVar W)) ::
                ((TVar X, TFun (TVar Z) (TVar U)) :: [] ++ []) ++
                ((TVar Y, TFun (TVar Z) (TVar V)) :: [] ++ [])).
            repeat apply ct_fun.
            ct_app_apply.
            - ct_app_apply;
                try (constructor; reflexivity);
                try apply ISP.empty_inter_1;
                try apply ISP.empty_inter_2;
                try apply IS.empty_spec.
                + intros HF; inv HF.
                + intros HF; inv HF.
                + intros q Q Hq HIn.
                    destruct (IdDec.eq_dec z q) as [Hqz | Hqz];
                    destruct (IdDec.eq_dec y q) as [Hqy | Hqy];
                    destruct (IdDec.eq_dec x q) as [Hqx | Hqx];
                    try rewrite Hqz in *;
                    try rewrite Hqy in *;
                    try rewrite Hqx in *;
                    try (rewrite <- (bind_complete q z Q (TVar Z) Hqz) in Hq);
                    try (rewrite <- (bind_complete q y Q (TVar Y) Hqy) in Hq);
                    try (rewrite bind_correct in Hq;
                        injintrosubst Hq; simpl in HIn;
                        discriminate).
                    unfold bind in Hq.
                    apply eqb_neq in Hqx. rewrite Hqx in Hq.
                    unfold tempty in Hq. discriminate.
            - ct_app_apply;
                try (constructor; reflexivity);
                try apply ISP.empty_inter_1;
                try apply ISP.empty_inter_2;
                try apply IS.empty_spec.
                + intros HF; inv HF.
                + intros HF; inv HF.
                + intros q Q Hq HIn.
                    destruct (IdDec.eq_dec z q) as [Hqz | Hqz];
                    destruct (IdDec.eq_dec y q) as [Hqy | Hqy];
                    destruct (IdDec.eq_dec x q) as [Hqx | Hqx];
                    try rewrite Hqz in *;
                    try rewrite Hqy in *;
                    try rewrite Hqx in *;
                    try (rewrite <- (bind_complete q z Q (TVar Z) Hqz) in Hq);
                    try (rewrite <- (bind_complete q y Q (TVar Y) Hqy) in Hq);
                    try (rewrite bind_correct in Hq;
                        injintrosubst Hq; simpl in HIn;
                        discriminate).
                    unfold bind in Hq.
                    apply eqb_neq in Hqx. rewrite Hqx in Hq.
                    unfold tempty in Hq. discriminate.
            - rewrite ISP.empty_union_1; auto.
                rewrite <- ISP.singleton_equal_add.
                rewrite <- ISP.singleton_equal_add.
                apply empty_inter. intros HVU.
                subst. discriminate.
            - rewrite ISP.empty_union_1; auto.
                rewrite <- ISP.singleton_equal_add. simpl.
                apply empty_inter. intros HVU.
                subst. discriminate.
            - rewrite ISP.empty_union_1; auto.
                rewrite <- ISP.singleton_equal_add. simpl.
                apply empty_inter. intros HVU.
                subst. discriminate.
            - intros HF.
                rewrite ISP.empty_union_1 in HF; auto.
                rewrite <- ISP.singleton_equal_add in HF.
                inv HF; try discriminate. inv H0.
            - intros HF.
                rewrite ISP.empty_union_1 in HF; auto.
                rewrite <- ISP.singleton_equal_add in HF.
                inv HF; try discriminate. inv H0.
            - intros HF. simpl in HF.
                destruct HF as [HF | HF]; contradiction.
            - intros HF. simpl in HF.
                destruct HF as [HF | HF]; contradiction.
            - intros HF. simpl in HF. inv HF.
                + destruct H0 as [HX | [HZ | HU]];
                    discriminate.
                + inv H0.
            - intros HF. simpl in HF. inv HF.
                + destruct H0 as [HX | [HZ | HU]];
                    discriminate.
                + inv H0.
            - intros q Q Hq HIn.
                destruct (IdDec.eq_dec z q) as [Hqz | Hqz];
                destruct (IdDec.eq_dec y q) as [Hqy | Hqy];
                destruct (IdDec.eq_dec x q) as [Hqx | Hqx];
                try rewrite Hqz in *;
                try rewrite Hqy in *;
                try rewrite Hqx in *;
                try (rewrite <- (bind_complete q z Q (TVar Z) Hqz) in Hq);
                try (rewrite <- (bind_complete q y Q (TVar Y) Hqy) in Hq);
                try (rewrite bind_correct in Hq;
                    injintrosubst Hq; simpl in HIn;
                    discriminate).
                unfold bind in Hq.
                apply eqb_neq in Hqx. rewrite Hqx in Hq.
                unfold tempty in Hq. discriminate.
        Qed.
    End Examples.
End Monomorphic.

Module Polymorphic.
    Section Syntax.
        Inductive poly : Type :=
            | PType (t : type)
            | PForall (X : id) (t : poly).

        (* isomorphic to poly. *)
        Definition scheme : Type := list id * type.

        (* Isomorphism. *)

        Fixpoint to_scheme (p : poly) : scheme :=
            match p with
            | PType t => ([],t)
            | PForall X p =>
                let (N,t) := to_scheme p in
                (X::N,t)
            end.

        Fixpoint to_poly' (N : list id) (t : type) : poly :=
            match N with
            | [] => PType t
            | X::N => PForall X (to_poly' N t)
            end.

        Definition to_poly (sch : scheme) : poly :=
            let (N,t) := sch in to_poly' N t.

        Lemma scheme_to_scheme :
            forall (sch : scheme),
            to_scheme (to_poly sch) = sch.
        Proof.
            intros [N t]. induction N; try reflexivity.
            simpl in *. rewrite IHN. reflexivity.
        Qed.

        Lemma poly_to_poly :
            forall (p : poly),
            to_poly (to_scheme p) = p.
        Proof.
            intros p. induction p; try reflexivity.
            simpl in *. destruct (to_scheme p).
            simpl. unfold to_poly in IHp.
            rewrite IHp. reflexivity.
        Qed.

        Inductive expr : Type :=
            | EUnit
            | EVar (x : id)
            | EFun (x : id) (t : type) (e : expr)
            | EApp (e1 e2 : expr)
            | ELet (x : id) (e1 e2 : expr).
    End Syntax.

    Section TypeMap.
        Context {T : Type}.

        Definition tmap : Type := list (id * T).

        Definition tempty : tmap := [].

        Definition tbind (x : id) (t : T) (m : tmap) : tmap := (x, t) :: m.

        Fixpoint tremove (x : id) (m : tmap) : tmap :=
            match m with
            | [] => []
            | (y,t) :: m =>
                if (y =? x)%string then (tremove x m) else (y,t) :: (tremove x m)
            end.

        Fixpoint tget (X : id) (m : tmap) : option T :=
            match m with
            | [] => None
            | (Y,t)::m => if (Y =? X)%string then Some t else tget X m
            end.
    End TypeMap.

    (* typing context *)
    Definition gamma : Type := @tmap poly.

    Module S <: Sigma.
        Definition t : Type := @tmap type.

        Definition empty : t := tempty.

        Definition bind : id -> type -> t -> t := tbind.

        Definition get : id -> t -> option type := tget.

        Lemma get_empty :
            forall (X : id), get X empty = None.
        Proof. intros X. reflexivity. Qed.

        Lemma bind_correct :
            forall (X : id) (ty : type) (s : t),
            get X (bind X ty s) = Some ty.
        Proof.
            intros X ty s. cbn.
            destruct (X =? X) eqn:eq; auto.
            apply eqb_neq in eq. contradiction.
        Qed.

        Lemma bind_complete :
            forall {X Y : id}, Y <> X ->
            forall (s : t) (ty : type),
            get X (bind Y ty s) = get X s.
        Proof.
            intros X Y HYX s ty. cbn.
            apply eqb_neq in HYX. rewrite HYX.
            reflexivity.
        Qed.

        Fixpoint sub_type (s : t) (t : type) : type :=
            match t with
            | TUnit => TUnit
            | TVar X =>
                match get X s with
                | None => TVar X
                | Some t' => t'
                end
            | TFun t1 t2 => TFun (sub_type s t1) (sub_type s t2)
            end.

        Lemma sub_type_empty :
            forall (t : type),
            sub_type empty t = t.
        Proof.
            intros t. induction t; try reflexivity. simpl.
            rewrite IHt1. rewrite IHt2. reflexivity.
        Qed.

        Fixpoint compose (s1 s2 : S.t) : S.t :=
            match s1 with
            | [] => s2
            | (X, T) :: s1 => (X, sub_type s2 T) :: compose s1 s2
            end.

        Lemma compose_empty :
            forall (s : t),
            compose empty s = s.
        Proof. intros s. reflexivity. Qed.

        Lemma compose_correct :
            forall (s1 s2 : t) (ty : type),
            sub_type (compose s1 s2) ty = (sub_type s2 (sub_type s1 ty)).
        Proof.
            intros s1 s2 ty. induction ty;
            auto; simpl in *.
            - induction s1; simpl; auto.
                destruct a as [Y T]. simpl.
                destruct (Y =? X) eqn:eq; auto.
            - rewrite IHty1. rewrite IHty2.
                reflexivity.
        Qed.

        Lemma sub_type_bind_notin :
            forall (X : id) (ty : type),
            ~ TIn X ty ->
            forall (T : type),
            sub_type (bind X T empty) ty = ty.
        Proof.
            intros X ty Hin T. induction ty;
            simpl in *; auto.
            - apply eqb_neq in Hin. rewrite Hin.
                reflexivity.
            - apply CP.not_or_and in Hin as [H1 H2].
                apply IHty1 in H1. apply IHty2 in H2.
                rewrite H1. rewrite H2. reflexivity.
        Qed.
    End S.

    Section TypeSubstitution.
        Fixpoint sub_expr (s : S.t) (e : expr) : expr :=
            match e with
            | EUnit => EUnit
            | EVar x => EVar x
            | EFun x t e => EFun x (S.sub_type s t) (sub_expr s e)
            | EApp e1 e2 => EApp (sub_expr s e1) (sub_expr s e2)
            | ELet x e1 e2 => ELet x (sub_expr s e1) (sub_expr s e2)
            end.

        Fixpoint sub_poly (s : S.t) (p : poly) : poly :=
            match p with
            | PType t => PType (S.sub_type s t)
            | PForall X p =>
                PForall X (sub_poly (tremove X s) p)
            end.

        Definition sub_gamma (s : S.t) : gamma -> gamma :=
            map (fun (e : id * poly) =>
                let (x,p) := e in (x, sub_poly s p)).
    End TypeSubstitution.

    Module SS := SigmaSubstitution S.

    Module U := Unification S.
    Export U.

    Section ConstraintTyping.
        (* type name in a poly-type, accounting for bound type names *)
        Fixpoint PIn (X : id) (p : poly) : Prop :=
            match p with
            | PType t => TIn X t
            | PForall Y p => X <> Y /\ PIn X p
            end.

        (* type variable in gamma *)
        Definition GIn (X : id) (g : gamma) : Prop :=
            exists (x : id) (p : poly),
            tget x g = Some p /\ PIn X p.

        (* type variable not in gamma *)
        Definition GNIn (X : id) (g : gamma) : Prop :=
            forall (x : id) (p : poly),
            tget x g = Some p -> ~ PIn X p.

        (* type variable in an expression *)
        Fixpoint EIn (X : id) (e : expr) : Prop :=
            match e with
            | EUnit | EVar _ => False
            | EFun _ t e => TIn X t \/ EIn X e
            | EApp e1 e2 | ELet _ e1 e2 => EIn X e1 \/ EIn X e2
            end.

        (* complete substitution of a poly-type to get
            a type with fresh type variables *)
        Inductive sub_poly_type (g : gamma) (s : S.t)
        : poly -> type -> names -> constraint -> Prop :=
            | spt_type :
                forall (t t' : type),
                S.sub_type s t = t' ->
                sub_poly_type g s (PType t) t' IS.empty []
            | spt_forall :
                forall (X Y : id) (p : poly)
                    (N : names) (C : constraint) (t : type),
                GNIn Y g -> ~ PIn Y p -> ~ IS.In Y N ->
                sub_poly_type g (S.bind X (TVar Y) s) p t N C ->
                sub_poly_type g s (PForall X p) t (IS.add Y N) ((TVar X, TVar Y) :: C).

        Definition make_fun_poly (p1 p2 : poly) : poly :=
            let (N1,t1') := to_scheme p1 in
            let (N2,t2') := to_scheme p2 in
            to_poly (N1 ++ N2, TFun t1' t2').

        (* generalizes unbound type variables *)
        Inductive generalize_names (g : gamma) : type -> poly -> Prop :=
            | gun_unit : generalize_names g TUnit (PType TUnit)
            | gun_var_bound :
                forall (X : id),
                GIn X g ->
                generalize_names g (TVar X) (PType (TVar X))
            | gun_var_free :
                forall (X : id),
                ~ GIn X g ->
                generalize_names g (TVar X) (PForall X (PType (TVar X)))
            | gun_fun :
                forall (t1 t2 : type) (p1 p2 p : poly),
                p = make_fun_poly p1 p2 ->
                generalize_names g t1 p1 ->
                generalize_names g t2 p2 ->
                generalize_names g (TFun t1 t2) p.

        Inductive constraint_type (g : gamma)
        : expr -> type -> names -> constraint -> Prop :=
            | ct_unit :
                constraint_type g EUnit TUnit IS.empty []
            | ct_var :
                forall (x : id) (p : poly) (t : type)
                    (N : names) (C : constraint),
                tget x g = Some p ->
                sub_poly_type g S.empty p t N C ->
                constraint_type g (EVar x) t N C
            | ct_fun :
                forall (x : id) (t1 t2 : type)
                    (e : expr) (N : names) (C : constraint),
                constraint_type (tbind x (PType t1) g) e t2 N C ->
                constraint_type g (EFun x t1 e) (TFun t1 t2) N C
            | ct_app :
                forall (e1 e2 : expr) (t1 t2 : type) (X : id)
                    (N1 N2 : names) (C1 C2 : constraint),
                constraint_type g e1 t1 N1 C1 ->
                constraint_type g e2 t2 N2 C2 ->
                IS.Empty (IS.inter N1 N2) ->
                IS.Empty (IS.inter N1 (fv t2)) ->
                IS.Empty (IS.inter N2 (fv t1)) ->
                ~ IS.In X N1 -> ~ IS.In X N2 ->
                ~ TIn X t1 -> ~ TIn X t2 ->
                ~ EIn X e1 -> ~ EIn X e2 ->
                ~ CIn X C1 -> ~ CIn X C2 -> ~ GIn X g ->
                constraint_type g (EApp e1 e2) (TVar X)
                    (IS.add X (IS.union N1 N2))
                    ((t1, TFun t2 (TVar X)) :: C1 ++ C2)
            | ct_let :
                forall (x : id) (e1 e2 : expr) (t1 t2 : type)
                    (p1 : poly) (N1 N2 : names) (C1 C2 : constraint),
                    constraint_type g e1 t1 N1 C1 ->
                    generalize_names g t1 p1 ->
                    constraint_type (tbind x p1 g) e2 t2 N2 C2 ->
                    IS.Empty (IS.inter N1 N2) ->
                    IS.Empty (IS.inter N1 (fv t2)) ->
                    IS.Empty (IS.inter N2 (fv t1)) ->
                    constraint_type g (ELet x e1 e2) t2
                        (IS.union N1 N2) (C1 ++ C2).

        Definition constraint_solution
            {g : gamma} {e : expr} {t : type} {X : names} {C : constraint}
            (H : constraint_type g e t X C) (s : S.t) (T : type) : Prop :=
            satisfy_constraint s C /\ S.sub_type s t = T.
    End ConstraintTyping.

    Section PrincipalTypes.
        Definition principal_solution
            {g : gamma} {e : expr} {t : type} {X : names} {C : constraint}
            (H : constraint_type g e t X C) (s : S.t) (T : type) : Prop :=
            constraint_solution H s T /\
            forall (s' : S.t) (T' : type),
            constraint_solution H s' T' -> more_general s s'.

        Corollary unify_principal_solution :
            forall {g : gamma} {e : expr} {t : type} {X : names} {C : constraint}
                (H : constraint_type g e t X C) (s : S.t),
            unify C s ->
            principal_solution H s (S.sub_type s t).
        Proof.
            intros g e t X C H s HU.
            apply unify_principal in HU as HUC.
            unfold principal_unifier in HUC.
            unfold principal_solution.
            destruct HUC as [HSC HMG]. split.
            - unfold constraint_solution. split; auto.
            - intros s' T' Hs'T'.
                unfold constraint_solution in Hs'T'.
                destruct Hs'T' as [HSCs' HSTs']. auto.
        Qed.

        (* Interleave constraint generation and unification.
            Should generate a principal type at each step.
            I'm not sure this is right... *)
        Inductive interleave (g : gamma) : expr -> type -> names -> Prop :=
            | il_unit : interleave g EUnit TUnit IS.empty
            | il_var :
                forall (x : id) (p : poly) (t : type)
                    (N : names) (C : constraint) (s : S.t),
                tget x g = Some p ->
                sub_poly_type g S.empty p t N C ->
                interleave g (EVar x) t N
            | il_fun :
                forall (x : id) (t1 t2 : type) (e : expr) (N : names),
                interleave (tbind x (PType t1) g) e t2 N ->
                interleave g (EFun x t1 e) (TFun t1 t2) N
            | il_app :
                forall (e1 e2 : expr) (t1 t2 : type)
                    (X : id) (s : S.t) (N1 N2 : names),
                interleave g e1 t1 N1 ->
                interleave g e2 t2 N2 ->
                IS.Empty (IS.inter N1 N2) ->
                IS.Empty (IS.inter N1 (fv t2)) ->
                IS.Empty (IS.inter N2 (fv t1)) ->
                ~ IS.In X N1 -> ~ IS.In X N2 ->
                ~ TIn X t1 -> ~ TIn X t2 ->
                ~ EIn X e1 -> ~ EIn X e2 -> ~ GIn X g ->
                unify [(t1, TFun t2 (TVar X))] s ->
                interleave g (EApp e1 e2) (S.sub_type s (TVar X)) (IS.union N1 N2)
            | il_let :
                forall (x : id) (e1 e2 : expr) (t1 t2 : type)
                (p1 : poly) (N1 N2 : names),
                interleave g e1 t1 N1 ->
                generalize_names g t1 p1 ->
                interleave (tbind x p1 g) e2 t2 N2 ->
                IS.Empty (IS.inter N1 N2) ->
                IS.Empty (IS.inter N1 (fv t2)) ->
                IS.Empty (IS.inter N2 (fv t1)) ->
                interleave g (ELet x e1 e2) t2 (IS.union N1 N2).

        Proposition interleave_sound :
            forall (g : gamma) (e : expr) (t : type) (N : names),
            interleave g e t N ->
            forall (C : constraint)
                (H : constraint_type g e t N C),
            exists (s : S.t), unify C s /\ constraint_solution H s t.
        Proof.
            intros g e t N HIL C H.
            induction HIL; inv H.
            - exists tempty. repeat split;
                auto; constructor.
            - admit.
            - pose proof IHHIL H6 as IH.
                destruct IH as [s [HUs [HCS1 HCS2]]].
                exists s. repeat split; auto.
                simpl. rewrite HCS2.
                (* again, induction or
                    induction hypothesis
                    seems wrong... *)
                admit.
            - admit.
            - admit.
        Admitted.
    End PrincipalTypes.

    (* There are no good, concise explanations...
        hopefully this is correct. *)
    Section AlgorithmW.
        Inductive W (g : gamma) : expr -> type -> S.t -> names -> Prop :=
            | w_unit : W g EUnit TUnit S.empty IS.empty
            | w_var :
                forall (x : id) (p : poly) (t : type)
                (N : names) (C : constraint),
                tget x g = Some p ->
                sub_poly_type g S.empty p t N C ->
                W g (EVar x) t S.empty N
            | w_fun :
                forall (x : id) (t1 t2 : type) (e : expr)
                    (N : names) (s : S.t),
                W (tbind x (PType t1) g) e t2 s N ->
                W g (EFun x t1 e) (TFun (S.sub_type s t1) t2) s N
            | w_app :
                forall (e1 e2 : expr) (t1 t2 : type) (X : id)
                    (s1 s2 s : S.t) (N1 N2 : names),
                W g e1 t1 s1 N1 ->
                W (sub_gamma s1 g) e2 t2 s2 N2 ->
                IS.Empty (IS.inter N1 N2) ->
                IS.Empty (IS.inter N1 (fv t2)) ->
                IS.Empty (IS.inter N2 (fv t1)) ->
                ~ IS.In X N1 -> ~ IS.In X N2 ->
                ~ TIn X t1 -> ~ TIn X t2 ->
                ~ EIn X e1 -> ~ EIn X e2 -> ~ GIn X g ->
                unify [(S.sub_type s2 t1, TFun t2 (TVar X))] s ->
                W g (EApp e1 e2) (S.sub_type s (TVar X))
                    (S.compose (S.compose s1 s2) s) (IS.union N1 N2)
            | w_let :
                forall (x : id) (e1 e2 : expr) (t1 t2 : type)
                    (p1 : poly) (s1 s2 : S.t) (N1 N2 : names),
                W g e1 t1 s1 N1 ->
                generalize_names g (S.sub_type s1 t1) p1 ->
                W (tbind x p1 (sub_gamma s1 g)) e2 t2 s2 N2 ->
                IS.Empty (IS.inter N1 N2) ->
                IS.Empty (IS.inter N1 (fv t2)) ->
                IS.Empty (IS.inter N2 (fv t1)) ->
                W g (ELet x e1 e2) t2 s2 N2.

    (* uggghhhh... *)
    Proposition W_soundish:
        forall (g : gamma) (e : expr) (t : type) (s : S.t) (N : names),
        W g e t s N ->
        exists (C : constraint),
        constraint_type g e t N C.
    Proof.
        intros g e t s N HW.
        induction HW.
        - exists []. constructor.
        - exists C. apply ct_var
            with (p := p); assumption.
        - destruct IHHW as [C HCT].
            exists C.
            remember (S.sub_type s t1) as t1' in *.
            (* apply ct_fun. *)
    Admitted.
    End AlgorithmW.
End Polymorphic.


(* Use of Karp's theorem to bound probabilistic recurrence arising from quickselect *)
From discprob.basic Require Import base order nify exp_ext.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.

Lemma Rabs_le_compat_pos x y:
  x ≤ y → 0 ≤ x → Rabs x ≤ Rabs y.
Proof.
  rewrite /Rabs. repeat destruct (Rcase_abs); intros; fourier.
Qed.

(* There must be a more general version of this in standard library *)
Lemma piecewise_continuity z f g r:
  continuity f →
  continuity g →
  (∀ x, x ≤ z → r x = f x) →
  (∀ x, x ≥ z → r x = g x) →
  continuity r.
Proof.
  rewrite /continuity/continuity_pt/continue_in/limit1_in/limit_in//=/R_dist/D_x//=.
  intros Hfc Hgc Hle Hge x eps Hgt0.
  destruct (Hfc x eps Hgt0) as (alpf&?&Hfc').
  destruct (Hgc x eps Hgt0) as (alpg&?&Hgc').
  case (Req_dec (x - z) 0).
  - intros Hdiff0. assert (x = z) as <- by (apply Rminus_diag_uniq; auto).
    exists (Rmin alpf alpg); split.
    + repeat apply Rmin_case; auto.
    + intros x'.
      case: (Rle_dec x' x).
      * intros Hle'. rewrite (Hle x') // (Hle x) //=; last reflexivity.
        intros (?&?); eapply Hfc'; split; auto.
        eapply Rlt_le_trans; eauto.
        apply Rmin_l.
      * move /Rnot_le_gt/Rgt_ge. intros Hge'. rewrite (Hge x') // (Hge x) //=; last fourier.
        intros (?&?); eapply Hgc'; split; auto.
        eapply Rlt_le_trans; eauto.
        apply Rmin_r.
  - intros Hneq.
    exists (Rmin (Rmin alpf alpg) (Rabs (x - z))); split.
    + repeat apply Rmin_case; auto.
        by apply Rabs_pos_lt.
    + intros x'.
      case: (Rle_dec x' z).
      * intros Hle'.
        intros (?&Hmin).
        assert (x ≤ z).
        { apply Rnot_gt_le.
          intros Hgt. assert (x - z ≤ x - x') as Hdiff by fourier.
          apply Rabs_le_compat_pos in Hdiff; last fourier.
          eapply Rlt_le_trans in Hmin; last apply Rmin_r.
          rewrite (Rabs_minus_sym x x') in Hdiff.
          fourier.
        }
        rewrite (Hle x') // (Hle x) //=.
        eapply Hfc'; split; auto.
        eapply Rlt_le_trans; eauto.
        etransitivity; [apply Rmin_l | apply Rmin_l].
      * move /Rnot_le_gt/Rgt_ge => Hge'.
        intros (?&Hmin).
        assert (x ≥ z).
        { apply Rnot_lt_ge.
          intros Hgt. assert (z - x ≤ x' - x) as Hdiff by fourier.
          apply Rabs_le_compat_pos in Hdiff; last fourier.
          eapply Rlt_le_trans in Hmin; last apply Rmin_r.
          rewrite (Rabs_minus_sym z x) in Hdiff.
          fourier.
        }
        rewrite (Hge x') // (Hge x) //=.
        eapply Hgc'; split; auto.
        eapply Rlt_le_trans; eauto.
        etransitivity; [apply Rmin_l | apply Rmin_r].
Qed.

Lemma ln_continuity_pt: ∀ x, 0 < x → continuity_pt ln x.
Proof.
  move: ln_continue. rewrite /continuity_pt/continuity_pt.
  intros Hln x Hx z Hgt.
  edestruct (Hln x Hx z) as (alp&?&Halp); auto.
  exists (Rmin x alp). split.
  { apply Rmin_case; fourier. }
  intros x' ((?&?)&Hdist).
  eapply Halp; split; auto.
  - rewrite /D_x; split; auto.
    rewrite /Rlimit.dist //= /R_dist in Hdist.
    eapply Rlt_le_trans in Hdist; last apply Rmin_l.
    destruct (Rge_dec x' x) as [?|?%Rnot_ge_lt]; first by fourier.
    rewrite Rabs_left in Hdist; fourier.
  - eapply Rlt_le_trans; last apply Rmin_r; eauto.
Qed.

Lemma piecewise_continuity' z f g r:
  (∀ x, x ≤ z → continuity_pt f x) →
  (∀ x, x ≥ z → continuity_pt g x) →
  (∀ x, x ≤ z → r x = f x) →
  (∀ x, x ≥ z → r x = g x) →
  continuity r.
Proof.
  rewrite /continuity/continuity_pt/continue_in/limit1_in/limit_in//=/R_dist/D_x//=.
  intros Hfc Hgc Hle Hge x eps Hgt0.
  destruct (Rtotal_order x z) as [Hlt|[<-|Hgt]].
  - destruct (Hfc x (Rlt_le _ _ Hlt) eps Hgt0) as (alpf&?&Hfc').
    exists (Rmin alpf (Rabs (x - z))); split.
    + repeat apply Rmin_case; auto.
        apply Rabs_pos_lt, Rlt_not_eq; fourier.
    + intros x'.
      intros ((?&?)&Hmin).
        assert (x' ≤ z).
        { apply Rnot_gt_le.
          intros Hgt. assert (z - x ≤ x' - x) as Hdiff by fourier.
          apply Rabs_le_compat_pos in Hdiff; last fourier.
          eapply Rlt_le_trans in Hmin; last apply Rmin_r.
          rewrite (Rabs_minus_sym z x) in Hdiff.
          fourier.
        }
        rewrite (Hle x') // (Hle x) //=; try fourier.
        eapply Hfc'; split; auto.
        eapply Rlt_le_trans; eauto using Rmin_l.
  - destruct (Hfc x (Rle_refl x) eps Hgt0) as (alpf&?&Hfc').
    destruct (Hgc x (Rge_refl x) eps Hgt0) as (alpg&?&Hgc').
    exists (Rmin alpf alpg); split.
    + repeat apply Rmin_case; auto.
    + intros x'.
      case: (Rle_dec x' x).
      * intros Hle'. rewrite (Hle x') // (Hle x) //=; last reflexivity.
        intros (?&?); eapply Hfc'; split; auto.
        eapply Rlt_le_trans; eauto.
        apply Rmin_l.
      * move /Rnot_le_gt/Rgt_ge. intros Hge'. rewrite (Hge x') // (Hge x) //=; last fourier.
        intros (?&?); eapply Hgc'; split; auto.
        eapply Rlt_le_trans; eauto.
        apply Rmin_r.
  - destruct (Hgc x (Rgt_ge _ _ Hgt) eps Hgt0) as (alpg&?&Hgc').
    exists (Rmin alpg (Rabs (x - z))); split.
    + repeat apply Rmin_case; auto.
        apply Rabs_pos_lt, Rgt_not_eq; fourier.
    + intros x'.
      intros ((?&?)&Hmin).
        assert (x' ≥ z).
        { apply Rnot_lt_ge.
          intros Hlt. assert (x - z ≤ x - x') as Hdiff by fourier.
          apply Rabs_le_compat_pos in Hdiff; last fourier.
          eapply Rlt_le_trans in Hmin; last apply Rmin_r.
          rewrite (Rabs_minus_sym x x') in Hdiff.
          fourier.
        }
        rewrite (Hge x') // (Hge x) //=; try fourier.
        eapply Hgc'; split; auto.
        eapply Rlt_le_trans; eauto using Rmin_l.
Qed.

Lemma piecewise_continuity_pt P z f g r:
  (∀ x, P x → x ≤ z → continuity_pt f x) →
  (∀ x, P x → x ≥ z → continuity_pt g x) →
  (∀ x, x < z → r x = f x) →
  (∀ x, x > z → r x = g x) →
  (P z → f z = g z ∧ f z = r z) →
  ∀ x, P x → continuity_pt r x.
Proof.
  rewrite /continuity/continuity_pt/continue_in/limit1_in/limit_in//=/R_dist/D_x//=.
  intros Hfc Hgc Hle Hge Hjoin x HP eps Hgt0.
  destruct (Rtotal_order x z) as [Hlt|[<-|Hgt]].
  - destruct (Hfc x HP (Rlt_le _ _ Hlt) eps Hgt0) as (alpf&?&Hfc').
    exists (Rmin alpf (Rabs (x - z))); split.
    + repeat apply Rmin_case; auto.
        apply Rabs_pos_lt, Rlt_not_eq; fourier.
    + intros x'.
      intros ((?&?)&Hmin).
        assert (x' < z).
        { apply Rnot_ge_lt.
          intros Hgt. assert (z - x ≤ x' - x) as Hdiff by fourier.
          apply Rabs_le_compat_pos in Hdiff; last fourier.
          eapply Rlt_le_trans in Hmin; last apply Rmin_r.
          rewrite (Rabs_minus_sym z x) in Hdiff.
          fourier.
        }
        rewrite (Hle x') // (Hle x) //=; try fourier.
        eapply Hfc'; split; auto.
        eapply Rlt_le_trans; eauto using Rmin_l.
  - destruct (Hfc x HP (Rle_refl x) eps Hgt0) as (alpf&?&Hfc').
    destruct (Hgc x HP (Rge_refl x) eps Hgt0) as (alpg&?&Hgc').
    exists (Rmin alpf alpg); split.
    + repeat apply Rmin_case; auto.
    + intros x'.
      case: (Rle_dec x' x).
      * intros Hle'.
        destruct Hle'.
        { rewrite (Hle x') //.
          destruct Hjoin as (Heq1&Heq2); auto.
          rewrite -Heq2.
          intros (?&?); eapply Hfc'; split; auto.
          eapply Rlt_le_trans; eauto.
          apply Rmin_l.
        }
        subst. intros. rewrite Rminus_diag_eq //. rewrite Rabs_R0. auto.
      * move /Rnot_le_gt/Rgt_ge. intros Hge'.
        destruct Hge'.
        { rewrite (Hge x') //.
          destruct Hjoin as (Heq1&Heq2); auto.
          rewrite -Heq2 Heq1.
          intros (?&?); eapply Hgc'; split; auto.
          eapply Rlt_le_trans; eauto.
          apply Rmin_r.
        }
        subst. intros. rewrite Rminus_diag_eq //. rewrite Rabs_R0. auto.
  - destruct (Hgc x HP (Rgt_ge _ _ Hgt) eps Hgt0) as (alpg&?&Hgc').
    exists (Rmin alpg (Rabs (x - z))); split.
    + repeat apply Rmin_case; auto.
        apply Rabs_pos_lt, Rgt_not_eq; fourier.
    + intros x'.
      intros ((?&?)&Hmin).
        assert (x' > z).
        { apply Rnot_le_gt.
          intros Hlt. assert (x - z ≤ x - x') as Hdiff by fourier.
          apply Rabs_le_compat_pos in Hdiff; last fourier.
          eapply Rlt_le_trans in Hmin; last apply Rmin_r.
          rewrite (Rabs_minus_sym x x') in Hdiff.
          fourier.
        }
        rewrite (Hge x') // (Hge x) //=; try fourier.
        eapply Hgc'; split; auto.
        eapply Rlt_le_trans; eauto using Rmin_l.
Qed.

Lemma continuity_id: continuity id.
Proof.
  rewrite /continuity/continuity_pt/continue_in/limit1_in/limit_in//=/R_dist/D_x//=.
  intros x eps Hgt.
  exists eps. split; auto.
  firstorder.
Qed.

Module recurrence_work.
Section recurrence_work.
  Definition X := list nat.
  Variable A B : X → finType.
  Variable ΩT : ∀ x : X, distrib (A x).
  Variable Ωh : ∀ x : X, distrib (B x).
  Variable T: ∀ x: X, rrvar (ΩT x).
  Variable h: ∀ x: X, rvar (Ωh x) [eqType of X].
  Definition d := 1.
  Definition size (x: X) := INR (length x).
  Hypothesis T_non_neg: ∀ x n, (T x) n ≥ 0.
  Hypothesis hrange1: ∀ x n, size ((h x) n) ≤ size x.
  Hypothesis hrange2: ∀ x n, 0 ≤ size x →  0 ≤ size ((h x) n).
  Definition umin := 4.

  Hypothesis Tbelow: ∀ x e, size x ≤ d → (T x) e ≤ umin.

  Definition a x :=
    if (Rle_dec x 1) then
      0
    else
      x - 1.

  Hypothesis Trec:
  ∀ x r,  pr_gt (T x) r ≤ \big[Rplus/0]_(x' : imgT (h x))
                ((pr_eq (h x) (sval x')) * pr_gt (T (sval x')) (r - a (size x))).

  Definition m x := x * (3 / 4).

  Definition u x :=
    match Rle_dec x 1 with
      | left _ => 4
      | _ => 4 * x
    end.

  Definition u' x :=
    match Rle_dec x 4 with
      | left _ => 1
      | _ => x / 4
    end.

  Lemma umin_non_neg: 0 ≤ umin.
  Proof. rewrite /umin; fourier. Qed.

  Variable m_bound_Eh: ∀ x, Ex (rvar_comp (h x) size) ≤ m (size x).

  Lemma u_mono x y: x ≤ y → u x ≤ u y.
  Proof.
    rewrite /u/a/m/d => Hle.
    do 2 destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma u_strict_inc x y: x ≥ d → x < y → u x < u y.
  Proof.
    rewrite /u/a/m/d => Hle Hlt.
    do 2 destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma u'_mono x y: x ≤ y → u' x ≤ u' y.
  Proof.
    rewrite /u'/a/m/d => Hle.
    do 2 destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma u'_pos x: u' x > 0.
  Proof.
    rewrite /u'/a/m/d.
    do 1 destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma u'u x: x ≤ u' (u x).
  Proof.
    rewrite /u/u'.
    do 2 destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma u'_inv_above x: d < x → u' (u x) = x.
  Proof.
    rewrite /u/u'/d.
    do 2 destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma u_inv_above x: umin < x → u (u' x) = x.
  Proof.
    rewrite /u/u'/umin.
    do 2 destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma ud_umin: u d = umin.
  Proof.
    rewrite /u/d/umin//=. destruct (Rle_dec) => //=; field.
  Qed.

  Lemma u_cont: continuity u.
  Proof.
    apply piecewise_continuity with (g := λ x, 4 * x) (f := λ x, 4) (z := 1).
    - apply continuity_const => ? //.
    - apply continuity_mult.
      * apply continuity_const => ? //.
      * apply continuity_id.
    - rewrite /u => x. destruct (Rle_dec) => //=.
    - rewrite /u => x.
      destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma a_cont: continuity a.
  Proof.
    apply piecewise_continuity with (g := λ x, x - 1) (f := λ x, 0) (z := 1).
    - apply continuity_const => ? //.
    - apply continuity_minus.
      * apply continuity_id.
      * apply continuity_const => ? //.
    - rewrite /a => x. destruct (Rle_dec) => //=.
    - rewrite /a => x.
      destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma urec x: x > d → u x ≥ a x + u (m x).
  Proof.
    rewrite /u/a/m/d.
    replace (4 * (x * (3 /4))) with (3 * x) by field.
    do 2 destruct Rle_dec => //=; nra.
  Qed.

  Lemma alower: ∀ x, x ≤ d → a x = 0.
  Proof.
    rewrite /a => x. destruct (Rle_dec) => //=; intros; nra.
  Qed.

  Lemma ainc: ∀ x x', d ≤ x → x < x' → a x < a x'.
  Proof.
    rewrite /a/d => x x' Hle Hlt.
    assert (Hgt: x' > 1) by fourier.
    do 2 destruct (Rle_dec) => //=; intros; nra.
  Qed.

  Lemma a_nonneg: ∀ x, a x ≥ 0.
  Proof.
    intros. rewrite /a.
    do 1 destruct (Rle_dec) => //=; intros; nra.
  Qed.

  Lemma a_pos: ∀ x, d < x → 0 < a x.
  Proof.
    rewrite /d/a => ??.
    do 1 destruct (Rle_dec) => //=; intros; nra.
  Qed.

  Lemma a_mono: Rmono a.
  Proof.
    rewrite /a/d => x x' Hle.
    do 2 destruct (Rle_dec) => //=; intros; nra.
  Qed.

  Lemma mnondec: ∀ y y', 0 < y → y ≤ y' → (m y / y) ≤ (m y' / y').
  Proof.
    intros y y' Hlt Hle.
    rewrite /m.
    transitivity (3 /4); right; field; apply Rgt_not_eq; fourier.
  Qed.

  Lemma d_non_neg: 0 ≤ d.
  Proof. rewrite /d. fourier. Qed.

  (* Technically this follows solely from the assumption on m, but it also
     is a trivial consquence of the fact that (h x) <= ceil(x) - 1, we should
     prove it from the assumption on m, but we need more facts about recn *)
  Hypothesis hinf_0: ∀ a eps, eps > 0 → ∃ n, pr_gt (rvar_comp (recN_rvar h a n) size) d < eps.

  Theorem bound x w:
    size x > 1 →  pr_gt (T x) (4 * size x + INR w * (size x - 1)) ≤ (3/4)^w.
  Proof.
    intros Hgt1.
    replace (4 * size x) with (u (size x)); last first.
    {  rewrite /u. destruct (Rle_dec); first nra. done. }
    replace (size x - 1) with (a (size x)); last first.
    {  rewrite /a. destruct (Rle_dec); first nra. done. }
    etransitivity; first
    eapply karp_bound_simple with
      (A := A)
      (B := B)
      (P := λ x, true)
      (T := T)
      (h := h)
      (umin := umin)
      (d := d)
      (u := u)
      (a := a)
      (m := m)
      (w := w).
    - apply umin_non_neg.
    - intros x' Hgt.
      transitivity (a x' + u (m x') - a x').
      { rewrite /u/umin/d/m/a. do 2 destruct (Rle_dec) => //=; nra. }
      specialize (urec x'). nra.
    - apply u_mono.
    - apply u_strict_inc.
    - apply u'_mono.
    - apply u'_pos.
    - apply u'u.
    - apply u'_inv_above.
    - apply u_inv_above.
    - apply ud_umin.
    - apply m_bound_Eh.
    - intros. apply u_cont.
    - intros. eapply a_cont.
    - intros. apply Trec.
    - apply urec.
    - auto.
    - apply hrange1.
    - rewrite /d; intros. specialize (hrange2 x0). eapply hrange2. fourier.
    - apply alower.
    - apply a_nonneg.
    - apply a_mono.
    - apply a_pos.
    - apply mnondec.
    - apply d_non_neg.
    - apply hinf_0.
    - apply Tbelow.
    - rewrite /m. intros. fourier.
    - auto.
    - done.
    - rewrite /m. right. f_equal. field; nra.
  Qed.

End recurrence_work.
End recurrence_work.

Module recurrence_span.
Section recurrence_span.
  Definition X := list nat.
  Variable A B : X → finType.
  Variable ΩT: ∀ x: X, distrib (A x).
  Variable Ωh: ∀ x: X, distrib (B x).
  Variable T: ∀ x: X, rrvar (ΩT x).
  Variable h: ∀ x: X, rvar (Ωh x) [eqType of X].
  Definition d := 1.
  Definition size (x: X) := INR (length x).
  Hypothesis T_non_neg: ∀ x n, (T x) n ≥ 0.
  Hypothesis hrange1: ∀ x n, size ((h x) n) ≤ size x.
  Hypothesis hrange2: ∀ x n, 0 ≤ size x →  0 ≤ size ((h x) n).
  Definition umin := 1.
  Hypothesis Tbelow: ∀ x e, size x ≤ d → (T x) e ≤ umin.

  Definition a x :=
    match Rle_dec x 1 with
      | left _ => 0
      | _ => ln x
    end.

  Hypothesis Trec:
    ∀ x r,  pr_gt (T x) r ≤ \big[Rplus/0]_(x' : imgT (h x))
                  ((pr_eq (h x) (sval x')) * pr_gt (T (sval x')) (r - a (size x))).

  Definition m x := x * (3 / 4).

  Definition k := -/ ln(3/4).

  Definition u x :=
    match Rle_dec x 1 with
      | left _ => 1
      | _ => ((k * ln x + 1) * (k * ln x + 1))
    end.

  Definition u' x :=
    match Rle_dec x 1 with
      | left _ => 1
      | _ => exp ((sqrt x - 1) / k)
    end.

  Lemma umin_non_neg: 0 ≤ umin.
  Proof. rewrite /umin; fourier. Qed.

  Variable m_bound_Eh: ∀ x, Ex (rvar_comp (h x) size) ≤ m (size x).

  Lemma kgt1: 1 < k.
  Proof.
    rewrite /k. replace (3 / 4) with (/ (4 /3)) by field.
    rewrite ln_Rinv; last fourier.
    assert (0 < ln (4 / 3)).
    { rewrite -ln_1. apply ln_increasing; fourier. }
    rewrite Ropp_inv_permute.
    - rewrite Ropp_involutive.
      replace 1 with (/1) at 1 by field.
      apply Rinv_lt_contravar; first rewrite Rmult_1_r //.
      rewrite -[a in _ < a](ln_exp 1).
      apply ln_increasing; first fourier.
      apply (Rlt_le_trans _ 2); first fourier.
      apply exp_ge_2.
    - apply Rlt_not_eq. fourier.
  Qed.

  Lemma kgt0: 0 < k.
  Proof.
    etransitivity; last apply kgt1. fourier.
  Qed.

  Lemma u_mono x y: x ≤ y → u x ≤ u y.
  Proof.
    rewrite /u/a/m/d => Hle.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    - cut (0 ≤ ln y).
      {
        intros. generalize kgt1 => ?.
        assert (k * ln y ≥ 0).
        { transitivity (1 * ln y); last fourier.
          apply Rle_ge, Rmult_le_compat; try fourier.
        }
        rewrite -{1}Rsqr_1.
        apply Rsqr_incr_1; fourier.
      }
      left. by apply Rlt_0_ln; nra.
    - specialize (kgt0) => Hk.
      apply Rsqr_incr_1.
      apply Rplus_le_compat; last fourier.
      cut (ln x ≤ ln y).
      {
        specialize (kgt0); cut (0 ≤ ln x); intros; first apply Rmult_le_compat; auto; try fourier.
        rewrite -(ln_1). left; apply ln_increasing; nra.
      }
      * inversion Hle; auto; subst; last by nra. left. apply ln_increasing; intros; nra.
      * apply Rnot_le_gt, ln_increasing in Hnle'; last fourier.
        rewrite (ln_1) in Hnle'. nra.
      * apply Rnot_le_gt, ln_increasing in Hnle''; last fourier.
        rewrite (ln_1) in Hnle''. nra.
  Qed.

  (* This basically covers half the case for the above, so could remove some redundancy *)
  Lemma u_strict_inc x y: x ≥ d → x < y → u x < u y.
  Proof.
    rewrite /u/a/m/d => Hle Hlt.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    - specialize (kgt0) => Hk.
      replace 1 with (Rsqr 1) by (rewrite /Rsqr; field).
      assert (0 < k * ln y).
      {
        apply Rmult_lt_0_compat; try fourier.
        apply Rlt_0_ln; fourier.
      }
      apply Rsqr_incrst_1; rewrite /Rsqr ?Rmult_1_r //=; try fourier.
    - specialize (kgt0) => Hk.
      apply Rsqr_incrst_1.
      apply Rplus_lt_compat_r.
      cut (ln x < ln y).
      {
        specialize (kgt0); cut (0 < ln x); intros; first apply Rmult_lt_compat_l; auto; try fourier.
        rewrite -(ln_1); apply ln_increasing; nra.
      }
      * apply ln_increasing; intros; fourier.
      * apply Rnot_le_gt, ln_increasing in Hnle'; last fourier.
        rewrite (ln_1) in Hnle'.
        assert (0 ≤ k * ln x); nra.
      * apply Rnot_le_gt, ln_increasing in Hnle''; last fourier.
        rewrite (ln_1) in Hnle''.
        assert (0 ≤ k * ln y); nra.
  Qed.

  Lemma u'_mono x y: x ≤ y → u' x ≤ u' y.
  Proof.
    rewrite /u'/a/m/d => Hle.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    - rewrite -{1}exp_0.
      left; apply exp_increasing.
      rewrite /Rdiv.
      apply Rlt_mult_inv_pos; last apply kgt0.
      cut (sqrt y > 1); intros; first fourier.
      rewrite -sqrt_1.
      apply Rnot_le_gt in Hnle''.
      apply Rlt_gt.
      apply sqrt_lt_1; fourier.
    - apply Rnot_le_gt in Hnle'.
      apply Rnot_le_gt in Hnle''.
      apply exp_increasing_le.
      generalize (kgt0) => Hk.
      apply Rdiv_le_compat_contra; try fourier.
      * assert (1 < sqrt x).
        { rewrite -sqrt_1. apply sqrt_lt_1; fourier. }
        nra.
      * rewrite /Rminus. apply Rplus_le_compat_r.
        apply sqrt_le_1; fourier.
  Qed.

  Lemma u'_pos x: u' x > 0.
  Proof.
    rewrite /u'/a/m/d.
    do 1 destruct (Rle_dec) => //=; try nra.
    apply exp_pos.
  Qed.

  Lemma u'_inv_above x: d < x → u' (u x) = x.
  Proof.
    rewrite /u/u'/d.
    destruct (Rle_dec) as [Hc1|?] => //=; try nra;
    destruct (Rle_dec) => //=; try nra.
    - intros. exfalso.
      assert (0 < ln x) by (apply Rlt_0_ln; auto).
      assert (0 < k * ln x) by (apply Rmult_lt_0_compat; auto using kgt0).
      assert (0 < (k * ln x) * (k * ln x)) by (repeat apply Rmult_lt_0_compat; auto using kgt0).
      rewrite ?Rmult_plus_distr_r in Hc1.
      rewrite ?Rmult_plus_distr_l in Hc1.
      fourier.
    - intros. rewrite -[a in _ = a]exp_ln; last fourier.
      f_equal.
      assert (0 < ln x) by (apply Rlt_0_ln; auto).
      assert (0 < k * ln x) by (apply Rmult_lt_0_compat; auto using kgt0).
      rewrite sqrt_Rsqr; last fourier.
      field. apply Rgt_not_eq, kgt0.
  Qed.

  Lemma u'u x: x ≤ u' (u x).
  Proof.
    destruct (Rlt_dec 1 x) as [Hlt|Hnlt].
    - rewrite u'_inv_above //. reflexivity.
    - rewrite /u/u'.
      apply Rnot_lt_le in Hnlt.
      destruct (Rle_dec) => //=; try nra.
      destruct (Rle_dec) => //=; try nra.
  Qed.

  Lemma u_inv_above x: umin < x → u (u' x) = x.
  Proof.
    rewrite /u/u'/umin.
    destruct (Rle_dec) as [Hc1|?] => //=; try nra;
    destruct (Rle_dec) as [?|?] => //=; try nra.
    - exfalso. rewrite -{2}exp_0 in Hc1.
      apply exp_le_embedding in Hc1.
      assert (1 < sqrt x).
      { rewrite -sqrt_1. apply sqrt_lt_1; nra. }
      specialize (kgt1) => Hk.
      cut (0 < (sqrt x - 1) / k).
      { by intros ?%Rlt_not_le. }
      apply Rdiv_lt_0_compat; fourier.
    - rewrite ln_exp. rewrite /Rdiv.
      transitivity (sqrt x * sqrt x).
      * field. apply Rgt_not_eq, kgt0.
      * apply sqrt_sqrt. fourier.
  Qed.

  Lemma ud_umin: u d = umin.
  Proof.
    rewrite /u/d/umin//=. destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma u_cont: continuity u.
  Proof.
    apply piecewise_continuity' with (g := λ x, (k * ln x + 1) * (k * ln x + 1))
                                      (f := λ x, 1) (z := 1).
    - intros; apply continuity_const => ? //.
    - intros. repeat apply continuity_pt_mult.
      * apply continuity_pt_plus.
        ** apply continuity_pt_mult.
           *** apply continuity_pt_const => ? //.
           *** apply ln_continuity_pt; fourier.
        ** apply continuity_pt_const => ? //.
      * apply continuity_pt_plus.
        ** apply continuity_pt_mult.
           *** apply continuity_pt_const => ? //.
           *** apply ln_continuity_pt; fourier.
        ** apply continuity_pt_const => ? //.
    - rewrite /u => x. destruct (Rle_dec) => //=; nra.
    - rewrite /u => x.
      destruct (Rle_dec) => //=; try nra; intros.
      assert (x = 1) as -> by (apply Rle_antisym; nra).
      rewrite ln_1 Rmult_0_r Rplus_0_l Rmult_1_l. done.
  Qed.

  Lemma a_cont: continuity a.
  Proof.
    apply piecewise_continuity' with (g := ln) (f := λ x, 0) (z := 1).
    - intros; apply continuity_const => ? //.
    - intros. apply ln_continuity_pt; fourier.
    - rewrite /a => x. destruct (Rle_dec) => //=.
    - rewrite /a => x.
      destruct (Rle_dec) => //=; try nra; []; intros.
      assert (x = 1) as -> by (apply Rle_antisym; fourier).
      rewrite ln_1. done.
  Qed.

  Lemma urec x: x > d → u x ≥ a x + u (m x).
  Proof.
    rewrite /u/a/m/d.
    destruct (Rle_dec) as [Hc1|Hc1] => //=; first by nra.
    destruct (Rle_dec) as [Hc2|Hc2] => //=.
    - transitivity ((k * ln x) * (k * ln x) + 2 * k * (ln x) + 1).
      { right. field. }
      assert (0 < ln x) by (apply Rlt_0_ln; auto).
      assert (0 < (k * ln x) * (k * ln x)) by (repeat apply Rmult_lt_0_compat; auto using kgt0).
      assert (2 * k * ln x > ln x).
      { apply Rlt_gt. rewrite -[a in a < _](Rmult_1_l).
        apply Rmult_lt_compat_r; auto.
        generalize kgt1 =>?. fourier.
      }
      fourier.
    - assert (0 < ln x) by (apply Rlt_0_ln; auto; nra).
      rewrite ln_mult; try nra; [].
      rewrite (Rmult_plus_distr_l k _).
      assert (k * ln (3 / 4) = -1) as ->.
      { rewrite /k. field. apply Rlt_not_eq.
        rewrite -(ln_1). apply ln_increasing; fourier.
      }
      rewrite Rplus_assoc Rplus_opp_l Rplus_0_r.
      rewrite ?(Rmult_plus_distr_l).
      rewrite ?(Rmult_plus_distr_r).
      assert (k * ln x > ln x).
      { apply Rlt_gt. rewrite -[a in a < _](Rmult_1_l).
        apply Rmult_lt_compat_r; auto.
        generalize kgt1 =>?. fourier.
      }
      nra.
  Qed.

  Lemma alower: ∀ x, x ≤ d → a x = 0.
  Proof.
    rewrite /a => x. destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma a_nonneg: ∀ x, a x ≥ 0.
  Proof.
    intros. rewrite /a. destruct (Rle_dec) => //; first nra.
    left. apply Rlt_gt. apply Rlt_0_ln; nra.
  Qed.

  Lemma a_pos: ∀ x, d < x → 0 < a x.
  Proof.
    rewrite /d/a => ??. destruct (Rle_dec) => //; first nra.
    apply Rlt_gt. apply Rlt_0_ln; fourier.
  Qed.

  Lemma ainc: ∀ x x', d ≤ x → x < x' → a x < a x'.
  Proof.
    rewrite /a/d => x x' Hle Hlt.
    assert (Hgt: x' > 1) by fourier.
    destruct (Rle_dec) => //;
    destruct (Rle_dec) => //; try nra; [|].
    - rewrite -ln_1. apply ln_increasing; fourier.
    - apply ln_increasing; fourier.
  Qed.

  Lemma a_mono: Rmono a.
  Proof.
    rewrite /Rmono. intros x x' Hle.
    inversion Hle; subst; try reflexivity.
    destruct (Rle_dec d x) as [?|?%Rnot_le_gt].
    * left. apply ainc; eauto.
    * rewrite alower; auto; try fourier.
      rewrite /a. destruct (Rle_dec).
      ** intros; fourier.
      ** left. apply Rlt_0_ln. nra.
  Qed.

  Lemma mnondec: ∀ y y', 0 < y → y ≤ y' → (m y / y) ≤ (m y' / y').
  Proof.
    intros y y' Hlt Hle.
    rewrite /m. transitivity (3 /4).
    -  right. field. apply Rgt_not_eq; fourier.
    -  right. field. apply Rgt_not_eq; fourier.
  Qed.

  Lemma d_non_neg: 0 ≤ d.
  Proof.
    rewrite /d. fourier.
  Qed.

  (* Technically this follows solely from the assumption on m, but it also
     is a trivial consquence of the fact that (h x) <= ceil(x) - 1, we should
     prove it from the assumption on m, but we need more facts about recn *)
  Hypothesis hinf_0: ∀ a eps, eps > 0 → ∃ n, pr_gt (rvar_comp (recN_rvar h a n) size) d < eps.

  Theorem bound x w:
    size x > 1 →
    pr_gt (T x) ((k * ln (size x) + 1)² + INR w * ln (size x)) ≤ (3/4)^w.
  Proof.
    intros Hgt1.
    replace ((k * ln (size x) + 1)²) with (u (size x)); last first.
    {  rewrite /u. destruct (Rle_dec); first nra. rewrite //=. }
    replace (ln (size x) )with (a (size x)); last first.
    {  rewrite /a. destruct (Rle_dec); first nra. done. }
    etransitivity; first
    eapply karp_bound_simple with
      (A := A)
      (B := B)
      (T := T)
      (P := λ x, true)
      (h := h)
      (umin := umin)
      (d := d)
      (u := u)
      (a := a)
      (m := m).
    - apply umin_non_neg.
    - cut (∀ x, umin ≤ u x).
      { intros Hcut x'. specialize (Hcut (m x')). intros. etransitivity; first eauto.
        specialize (urec x'). nra.
      }
      intros x'. destruct (Rle_dec x' d) as [Hle|Hnle%Rnot_le_gt].
      * rewrite /umin/u. move: Hle. rewrite /d. destruct (Rle_dec) => //=.  intros. nra.
      * rewrite -ud_umin. apply u_mono. fourier.
    - apply u_mono.
    - apply u_strict_inc.
    - apply u'_mono.
    - apply u'_pos.
    - apply u'u.
    - apply u'_inv_above.
    - apply u_inv_above.
    - apply ud_umin.
    - apply m_bound_Eh.
    - intros; apply u_cont.
    - intros; apply a_cont.
    - intros; apply Trec.
    - apply urec.
    - auto.
    - apply hrange1.
    - rewrite /d; intros. specialize (hrange2 x0). eapply hrange2. fourier.
    - apply alower.
    - apply a_nonneg.
    - apply a_mono.
    - apply a_pos.
    - apply mnondec.
    - apply d_non_neg.
    - apply hinf_0.
    - apply Tbelow.
    - rewrite /m. intros. fourier.
    - auto.
    - done.
    - right. rewrite /m. f_equal. field. nra.
  Qed.

End recurrence_span.
End recurrence_span.


Require Import Lia.
Require Import Bool.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Global.
Require Import Local.
Require Import Thread.

Require Import OrdStep.

Set Implicit Arguments.

Module Writes.
  Section Writes.
    Variable L: Loc.t -> bool.

    Definition t: Type := list (Loc.t * Time.t * Ordering.t).

    Definition append (e: ThreadEvent.t) (rels: t): t :=
      match ThreadEvent.is_writing e with
      | Some (loc, from, to, val, released, ord) =>
        if L loc
        then (loc, to, ord) :: rels
        else rels
      | None => rels
      end.

    Variant wf (rels: t) (mem: Memory.t): Prop :=
    | wf_intro
        (SOUND: forall loc to ord (IN: List.In (loc, to, ord) rels),
            L loc /\
            exists from val released na,
              Memory.get loc to mem = Some (from, Message.message val released na))
        (COMPLETE: forall loc from to val released na
                     (LOC: L loc)
                     (TO: to <> Time.bot)
                     (GET: Memory.get loc to mem = Some (from, Message.message val released na)),
            exists ord, List.In (loc, to, ord) rels)
    .

    Lemma append_app e rels1 rels2:
      append e rels1 ++ rels2 = append e (rels1 ++ rels2).
    Proof.
      unfold append. des_ifs.
    Qed.

    Lemma add_wf
          ord
          rels mem1 loc from to msg mem2
          (RELS1: wf rels mem1)
          (MSG: L loc -> exists val released na, msg = Message.message val released na)
          (ADD: Memory.add mem1 loc from to msg mem2):
      wf (if L loc then (loc, to, ord) :: rels else rels) mem2.
    Proof.
      condtac; cycle 1.
      { inv RELS1. econs; i.
        - exploit SOUND; eauto. i. des. splits; ss.
          erewrite Memory.add_o; eauto.
          condtac; ss; eauto. des. subst. congr.
        - revert GET. erewrite Memory.add_o; eauto.
          condtac; ss; eauto. des. subst. congr.
      }
      inv RELS1. econs; i.
      { inv IN.
        { clarify. split; ss.
          exploit MSG; eauto. i. des. subst.
          exploit Memory.add_get0; eauto. i. des. eauto.
        }
        exploit SOUND; eauto. i. des. split; ss.
        exploit Memory.add_get1; try exact x1; eauto.
      }
      { revert GET. erewrite Memory.add_o; eauto. condtac; ss.
        - i. des. clarify. eauto.
        - guardH o. i.
          exploit COMPLETE; eauto. i. des.
          esplits; eauto.
      }
    Qed.

    Lemma add_wf_other
          rels mem1 loc from to msg mem2
          (RELS1: wf rels mem1)
          (LOC: ~ L loc)
          (ADD: Memory.add mem1 loc from to msg mem2):
      wf rels mem2.
    Proof.
      exploit (@add_wf Ordering.na); try exact ADD; eauto; ss.
      condtac; ss.
    Qed.

    Lemma step_wf
          ordcr ordcw rels lang e e1 e2
          (RELS1: wf rels (Global.memory (Thread.global e1)))
          (STEP: @OrdThread.step lang L ordcr ordcw e e1 e2):
      wf (append e rels) (Global.memory (Thread.global e2)).
    Proof.
      unfold append.
      inv STEP; inv LOCAL; try inv LOCAL0; ss.
      - inv STEP. ss. eapply add_wf; eauto.
      - inv LOCAL1. inv STEP. inv LOCAL2. inv STEP. ss.
        eapply add_wf; eauto.
    Qed.
  End Writes.
End Writes.