(** * Types: Type Systems *)

Require Export Auto.

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of a very simple
    language with just booleans and numbers, to introduce the basic
    ideas of types, typing rules, and the fundamental theorems about
    type systems: _type preservation_ and _progress_.  Then we'll move
    on to the _simply typed lambda-calculus_, which lives at the core
    of every modern functional programming language (including
    Coq). *)

(* ###################################################################### *)
(** * Typed Arithmetic Expressions *)

(** To motivate the discussion of type systems, let's begin as
    usual with an extremely simple toy language.  We want it to have
    the potential for programs "going wrong" because of runtime type
    errors, so we need something a tiny bit more complex than the
    language of constants and addition that we used in chapter
    [Smallstep]: a single kind of data (just numbers) is too simple,
    but just two kinds (numbers and booleans) already gives us enough
    material to tell an interesting story.

    The language definition is completely routine.  The only thing to
    notice is that we are _not_ using the [asnum]/[aslist] trick that
    we used in chapter [HoareList] to make all the operations total by
    forcibly coercing the arguments to [+] (for example) into numbers.
    Instead, we simply let terms get stuck if they try to use an
    operator with the wrong kind of operands: the [step] relation
    doesn't relate them to anything. *)

(* ###################################################################### *)
(** ** Syntax *)

(** Informally:
    t ::= true
        | false
        | if t then t else t
        | 0
        | succ t
        | pred t
        | iszero t
    Formally:
*)

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tzero : tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tiszero : tm -> tm.

(** _Values_ are [true], [false], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_true : bvalue ttrue
  | bv_false : bvalue tfalse.

Inductive nvalue : tm -> Prop :=
  | nv_zero : nvalue tzero
  | nv_succ : forall t, nvalue t -> nvalue (tsucc t).

Definition value (t:tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue.
Hint Unfold value.
Hint Unfold beq_id beq_nat extend.

(* ###################################################################### *)
(** ** Operational Semantics *)

(** Informally: *)
(**
                    ------------------------------                  (ST_IfTrue)
                    if true then t1 else t2 ==> t1

                   -------------------------------                 (ST_IfFalse)
                   if false then t1 else t2 ==> t2

                              t1 ==> t1'
                      -------------------------                         (ST_If)
                      if t1 then t2 else t3 ==>
                        if t1' then t2 else t3

                              t1 ==> t1'
                         --------------------                         (ST_Succ)
                         succ t1 ==> succ t1'

                             ------------                         (ST_PredZero)
                             pred 0 ==> 0

                           numeric value v1
                        ---------------------                     (ST_PredSucc)
                        pred (succ v1) ==> v1

                              t1 ==> t1'
                         --------------------                         (ST_Pred)
                         pred t1 ==> pred t1'

                          -----------------                     (ST_IszeroZero)
                          iszero 0 ==> true

                           numeric value v1
                      --------------------------                (ST_IszeroSucc)
                      iszero (succ v1) ==> false

                              t1 ==> t1'
                       ------------------------                     (ST_Iszero)
                       iszero t1 ==> iszero t1'
*)

(** Formally: *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)
  | ST_Succ : forall t1 t1',
      t1 ==> t1' ->
      (tsucc t1) ==> (tsucc t1')
  | ST_PredZero :
      (tpred tzero) ==> tzero
  | ST_PredSucc : forall t1,
      nvalue t1 ->
      (tpred (tsucc t1)) ==> t1
  | ST_Pred : forall t1 t1',
      t1 ==> t1' ->
      (tpred t1) ==> (tpred t1')
  | ST_IszeroZero :
      (tiszero tzero) ==> ttrue
  | ST_IszeroSucc : forall t1,
       nvalue t1 ->
      (tiszero (tsucc t1)) ==> tfalse
  | ST_Iszero : forall t1 t1',
      t1 ==> t1' ->
      (tiszero t1) ==> (tiszero t1')

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_IfTrue" | Case_aux c "ST_IfFalse" | Case_aux c "ST_If"
  | Case_aux c "ST_Succ" | Case_aux c "ST_PredZero"
  | Case_aux c "ST_PredSucc" | Case_aux c "ST_Pred"
  | Case_aux c "ST_IszeroZero" | Case_aux c "ST_IszeroSucc"
  | Case_aux c "ST_Iszero" ].

Hint Constructors step.

(** Notice that the [step] relation doesn't care about whether
    expressions make global sense -- it just checks that the operation
    in the _next_ reduction step is being applied to the right kinds
    of operands.

    For example, the term [succ true] (i.e., [tsucc ttrue] in the
    formal syntax) cannot take a step, but the almost as obviously
    nonsensical term
       succ (if true then true else true)
    can take a step (once, before becoming stuck). *)

(* ###################################################################### *)
(** ** Normal Forms and Values *)

(** The first interesting thing about the [step] relation in this
    language is that the strong progress theorem from the Smallstep
    chapter fails!  That is, there are terms that are normal
    forms (they can't take a step) but not values (because we have not
    included them in our definition of possible "results of
    evaluation").  Such terms are _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t:tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck.

(** **** Exercise: 2 stars (some_term_is_stuck) *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  (* SOLUTION: *)
  exists (tsucc tfalse).
  unfold stuck. split.
    Case "normal form".
      unfold normal_form. intros contra. inversion contra as [t' Hstp].
      solve by inversion 2.
    Case "not a value".
      intros H. solve by inversion 3.  Qed.
(** [] *)

(** However, although values and normal forms are not the same in this
    language, the former set is included in the latter.  This is
    important because it shows we did not accidentally define things
    so that some value could still take a step. *)

(** **** Exercise: 3 stars, advanced (value_is_nf) *)
(** Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways. *)

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  (* SOLUTION: *)
  intros t H.
  (* Here is the easier way: *)
  unfold normal_form.
  inversion H; clear H.
  Case "boolean value". inversion H0.
    SCase "ttrue". intros Contra. inversion Contra as [t' P].
      inversion P.
    SCase "tfalse". intros Contra. inversion Contra as [t' P].
      inversion P.
  Case "numeric value".
    induction H0.
    SCase "nv_zero". intros Contra. inversion Contra as [t' P].
      inversion P.
    SCase "nv_succ". intros Contra. inversion Contra as [t' P].
      inversion P. subst. apply IHnvalue.
      exists t1'. auto.  Qed.
(** [] *)

(** **** Exercise: 3 stars, optional (step_deterministic) *)
(** Using [value_is_nf], we can show that the [step] relation is
    also deterministic... *)

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  (* SOLUTION: *)
  unfold deterministic. intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  step_cases (induction Hy1) Case;
        intros y2 Hy2; inversion Hy2; subst; auto;
        try (solve by inversion).
    Case "ST_If".
      SCase "Hy2 by ST_If". f_equal...
    Case "ST_Succ".
      SCase "Hy2 by ST_Succ". f_equal...
    Case "ST_PredSucc".
      SCase "Hy2 by ST_Pred".
        inversion H1; subst.
        apply ex_falso_quodlibet.
        apply value_is_nf with t1...
    Case "ST_Pred".
      SCase "Hy2 by ST_PredSucc".
        inversion Hy1; subst.
        apply ex_falso_quodlibet.
        apply value_is_nf with y2...
      SCase "Hy2 by ST_Pred".
        f_equal...
    Case "ST_IszeroSucc".
      SCase "Hy2 by ST_Iszero".
        inversion H1; subst.
        apply ex_falso_quodlibet.
        apply value_is_nf with t1...
    Case "ST_Iszero".
      SCase "Hy2 by ST_IszeroSucc".
        inversion Hy1; subst.
        apply ex_falso_quodlibet.
        apply value_is_nf with t0...
      SCase "Hy2 by ST_Iszero".
        f_equal... Qed.
(** [] *)

(* ###################################################################### *)
(** ** Typing *)

(** The next critical observation about this language is that,
    although there are stuck terms, they are all "nonsensical", mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | TBool : ty
  | TNat : ty.

(** In informal notation, the typing relation is often written
    [|- t \in T], pronounced "[t] has type [T]."  The [|-] symbol is
    called a "turnstile".  (Below, we're going to see richer typing
    relations where an additional "context" argument is written to the
    left of the turnstile.  Here, the context is always empty.) *)
(**
                           ----------------                            (T_True)
                           |- true \in Bool

                          -----------------                           (T_False)
                          |- false \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------                (T_If)
                    |- if t1 then t2 else t3 \in T

                             ------------                              (T_Zero)
                             |- 0 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Succ)
                          |- succ t1 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Pred)
                          |- pred t1 \in Nat

                            |- t1 \in Nat
                        ---------------------                        (T_IsZero)
                        |- iszero t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_True :
       |- ttrue \in TBool
  | T_False :
       |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T,
       |- t1 \in TBool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- tif t1 t2 t3 \in T
  | T_Zero :
       |- tzero \in TNat
  | T_Succ : forall t1,
       |- t1 \in TNat ->
       |- tsucc t1 \in TNat
  | T_Pred : forall t1,
       |- t1 \in TNat ->
       |- tpred t1 \in TNat
  | T_Iszero : forall t1,
       |- t1 \in TNat ->
       |- tiszero t1 \in TBool

where "'|-' t '\in' T" := (has_type t T).

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_True" | Case_aux c "T_False" | Case_aux c "T_If"
  | Case_aux c "T_Zero" | Case_aux c "T_Succ" | Case_aux c "T_Pred"
  | Case_aux c "T_Iszero" ].

Hint Constructors has_type.

(* ###################################################################### *)
(** *** Examples *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not calculate
    the type of the normal form of a term. *)

Example has_type_1 :
  |- tif tfalse tzero (tsucc tzero) \in TNat.
Proof.
  apply T_If.
    apply T_False.
    apply T_Zero.
    apply T_Succ.
      apply T_Zero.
Qed.

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

Example has_type_not :
  ~ (|- tif tfalse tzero ttrue \in TBool).
Proof.
  intros Contra. solve by inversion 2.  Qed.

(** **** Exercise: 1 star, optional (succ_hastype_nat__hastype_nat) *)
Example succ_hastype_nat__hastype_nat : forall t,
  |- tsucc t \in TNat ->
  |- t \in TNat.
Proof.
  (* SOLUTION: *)
  intros t H. inversion H. subst. assumption.  Qed.
(** [] *)

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

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are values (i.e., not stuck). *)

Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t ==> t'.

(** **** Exercise: 3 stars (finish_progress) *)
(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the informal proof fragment in the following
    exercise before starting -- this will save you a lot of time.) *)

Proof with auto.
  intros t T HT.
  has_type_cases (induction HT) Case...
  (* The cases that were obviously values, like T_True and
     T_False, were eliminated immediately by auto *)
  Case "T_If".
    right. inversion IHHT1; clear IHHT1.
    SCase "t1 is a value". inversion H; clear H.
      SSCase "t1 is a bvalue". inversion H0; clear H0.
        SSSCase "t1 is ttrue".
          exists t2...
        SSSCase "t1 is tfalse".
          exists t3...
      SSCase "t1 is an nvalue".
        solve by inversion 2.  (* on H and HT1 *)
    SCase "t1 can take a step".
      inversion H as [t1' H1].
      exists (tif t1' t2 t3)...
  (* SOLUTION: *)
  Case "T_Succ".
    inversion IHHT; clear IHHT.
    SCase "t1 is a value". inversion H...
      SSCase "t1 is a bvalue". solve by inversion 2.
    SCase "t1 can take a step".
      right. inversion H as [t1' H1].
      exists (tsucc t1')...
  Case "T_Pred".
    inversion IHHT; clear IHHT.
    SCase "t1 is a value". inversion H; clear H.
      SSCase "t1 is a bvalue". solve by inversion 2.
      SSCase "t1 is an nvalue". right.
        inversion H0; subst.
        SSSCase "t1 is zero".
          exists (tzero)...
        SSSCase "t1 is nonzero".
          exists t...
    SCase "t1 can take a step".
      right. inversion H as [t1' H1].
      exists (tpred t1')...
  Case "T_Iszero".
    inversion IHHT; clear IHHT.
    SCase "t1 is a value". inversion H; clear H.
      SSCase "t1 is a bvalue". solve by inversion 2.
      SSCase "t1 is an nvalue". right.
        inversion H0; subst.
        SSSCase "t1 is zero".
          exists ttrue...
        SSSCase "t1 is nonzero".
          exists tfalse...
    SCase "t1 can take a step".
      right. inversion H as [t1' H1].
      exists (tiszero t1')...  Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_progress_informal) *)
(** Complete the corresponding informal proof: *)

(** _Theorem_: If [|- t \in T], then either [t] is a value or else
    [t ==> t'] for some [t']. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].  By the IH, either [t1] is a value or else [t1] can step
        to some [t1'].

            - If [t1] is a value, then it is either an [nvalue] or a
              [bvalue].  But it cannot be an [nvalue], because we know
              [|- t1 \in Bool] and there are no rules assigning type
              [Bool] to any term that could be an [nvalue].  So [t1]
              is a [bvalue] -- i.e., it is either [true] or [false].
              If [t1 = true], then [t] steps to [t2] by [ST_IfTrue],
              while if [t1 = false], then [t] steps to [t3] by
              [ST_IfFalse].  Either way, [t] can step, which is what
              we wanted to show.

            - If [t1] itself can take a step, then, by [ST_If], so can
              [t].

    (* SOLUTION: *)

      - If the last rule in the derivation is [T_True], then [t =
        true], which is a boolean value and hence a value.  The cases
        for [T_False] and [T_Zero] are similar.

      - If the last rule in the derivation is [T_Succ], then [t = succ
        t1], with [|- t1 \in Nat].  By the IH, either [t1] is a value or
        else [t1] can step to some [t1'].

            - If [t1] is a value, then it is either an [nvalue] or a
              [bvalue].  But it cannot be an [bvalue], because we know
              [|- t1 \in Nat] and there are no rules assigning type
              [Bool] to any term that could be a [bvalue].  So [t1] is
              a [nvalue], and hence [t] is also an [nvalue] (and hence
              a value) by [nv_succ].

            - If [t1] can take a step, then by [ST_Succ], so can [t].

      - If the last rule in the derivation is [T_Pred], then [t =
        pred t1], with [|- t1 \in Nat].   By the IH, either [t1] is a
        value or else [t1] can step to some [t1'].

            - If [t1] is a value, then (by the same argument as in the
              previous case) it must be an [nvalue].  By inversion on
              the [nvalue] judgement, there are two cases:

                - If [t1 = zero], then [t] can take a step by
                  [ST_PredZero].

                - Otherwise, [t1 = succ t1'], with [t1'] an [nvalue].
                  Hence [t] can again take a step, this time by
                  [ST_PredSucc].

            - Finally, if [t1] can take a step, then by [ST_Pred], so
              can [t].

      - If the last rule in the derivation is [T_IsZero], then [t =
        iszero t1], with [|- t1 \in Nat].  By the IH, either [t1] is a
        value or else [t1] steps to some [t1'].

            - If [t1] is a value, it must be an [nvalue], and there
              are two cases to consider:

                - If [t1 = zero], then [t] can take a step by
                  [ST_IsZeroZero].

                - Otherwise, [t1 = succ t1'] where [t1'] is an
                  [nvalue].  Hence [t] can take a step by
                  [ST_IsZeroSucc].

            - If [t1] can take a step, then so can [t], by [ST_IsZero].

    []
*)

(** This is more interesting than the strong progress theorem that we
    saw in the Smallstep chapter, where _all_ normal forms were
    values.  Here, a term can be stuck, but only if it is ill
    typed. *)

(** **** Exercise: 1 star (step_review) *)
(** Quick review.  Answer _true_ or _false_.  In this language...
      - Every well-typed normal form is a value.

            TRUE: This is the content of the progress theorem.
      - Every value is a normal form.

            TRUE: This can proved by induction on values.
      - The single-step evaluation relation is
        a partial function (i.e., it is deterministic).

            TRUE: This is the determinism theorem.
      - The single-step evaluation relation is a _total_ function.

            FALSE: normal forms do not evaluate to anything + can get stuck.
*)
(** [] *)

(* ###################################################################### *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is also a well-typed term.

    This theorem is often called the _subject reduction_ property,
    because it tells us what happens when the "subject" of the typing
    relation is reduced.  This terminology comes from thinking of
    typing statements as sentences, where the term is the subject and
    the type is the predicate. *)

Theorem preservation : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.

(** **** Exercise: 2 stars (finish_preservation) *)
(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)

Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  has_type_cases (induction HT) Case;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try (solve by inversion).
    Case "T_If". inversion HE; subst.
      SCase "ST_IFTrue". assumption.
      SCase "ST_IfFalse". assumption.
      SCase "ST_If". apply T_If; try assumption.
        apply IHHT1; assumption.
    (* SOLUTION: *)
    Case "T_Succ". inversion HE; subst...
    Case "T_Pred". inversion HE; subst...
      SCase "ST_PredSucc". inversion HT...
    Case "T_Iszero". inversion HE; subst...  Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_preservation_informal) *)
(** Complete the following proof: *)

(** _Theorem_: If [|- t \in T] and [t ==> t'], then [|- t' \in T]. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].

        Inspecting the rules for the small-step reduction relation and
        remembering that [t] has the form [if ...], we see that the
        only ones that could have been used to prove [t ==> t'] are
        [ST_IfTrue], [ST_IfFalse], or [ST_If].

           - If the last rule was [ST_IfTrue], then [t' = t2].  But we
             know that [|- t2 \in T], so we are done.

           - If the last rule was [ST_IfFalse], then [t' = t3].  But we
             know that [|- t3 \in T], so we are done.

           - If the last rule was [ST_If], then [t' = if t1' then t2
             else t3], where [t1 ==> t1'].  We know [|- t1 \in Bool] so,
             by the IH, [|- t1' \in Bool].  The [T_If] rule then gives us
             [|- if t1' then t2 else t3 \in T], as required.

    (* SOLUTION: *)

      - If the last rule in the derivation were [T_True], then [t =
        true].  However, [true] does not step to anything, so this
        case cannot actually occur.

      - Similarly, neither [T_False] nor [T_Zero] could not be the
        final rule in the derivation.

      - If the last rule in the derivation is [T_Succ], then [t = succ
        t1] with [|- t1 \in Nat] and [T = Nat]. The only rule which
        could have been used to show that [t] steps is [ST_Succ], in
        which case [t1] steps to some [t1'].  So, by the IH, [|- t1' \in
        Nat], and hence [t' = succ t1'] also has type [Nat] by
        [T_Succ].

      - If the last rule in the derivation is [T_Pred], then [t = pred
        t1] with [|- t1 \in Nat].  There are only three rules which could
        have been the last rule in the derivation of [pred t1 ==> t'].

          - If the last rule was [ST_PredZero], then [t' = zero] which
            has type [Nat].

          - If the last rule was [ST_PredSucc], then [t1 = succ t'];
            by inversion on the fact that [|- t1 \in Nat] it follows
            that [|- t' \in Nat] as well.

          - If the last rule was [ST_Pred], then [t1] steps to some
            [t1']; by the IH [|- t1' \in Nat], and so [pred t1'] has
            type [Nat] as well by [T_Pred].

      - If the last rule in the derivation is [T_IsZero], then [t =
        iszero t1] with [|- t1 \in Nat] and [T = Bool].  There are only
        three rules which could have been the last rule in the
        derivation of [iszero t1 ==> t'].

          - If the last rule was [ST_IsZeroZero], then [t' = true]
            which has type [Bool].

          - If the last rule was [ST_IsZeroSucc], then [t' = false]
            which has type [Bool].

          - If the last rule was [ST_IsZero], then [t1] steps to some
            [t1'].  By the IH, [|- t1' \in Nat] as well, and hence [t' =
            iszero t1'] has type [Bool] by [T_IsZero].

    []
*)

(** **** Exercise: 3 stars (preservation_alternate_proof) *)
(** Now prove the same property again by induction on the
    _evaluation_ derivation instead of on the typing derivation.
    Begin by carefully reading and thinking about the first few
    lines of the above proof to make sure you understand what
    each one is doing.  The set-up for this proof is similar, but
    not exactly the same. *)

Theorem preservation' : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.
Proof with eauto.
  (* SOLUTION: *)
  intros t t' T HT HE.
  generalize dependent T.
  step_cases (induction HE) Case;
         (* in each case, invert the given typing derivation *)
         intros T HT; inversion HT; subst;
         (* deal with several easy or contradictory cases
            all at once *)
         try solve [assumption; solve by inversion]...
    Case "ST_PredSucc".
      inversion HT. subst. inversion H2. subst...  Qed.
(** [] *)

(* ###################################################################### *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we can see that a
    well-typed term can _never_ reach a stuck state.  *)

Definition multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
  |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP.  apply (preservation x y T HT H).
  unfold stuck. split; auto.   Qed.

(* ###################################################################### *)
(** ** Additional Exercises *)

(** **** Exercise: 2 stars (subject_expansion) *)
(** Having seen the subject reduction property, it is reasonable to
    wonder whether the opposity property -- subject _expansion_ --
    also holds.  That is, is it always the case that, if [t ==> t']
    and [|- t' \in T], then [|- t \in T]?  If so, prove it.  If
    not, give a counter-example.  (You do not need to prove your
    counter-example in Coq, but feel free to do so if you like.)

    (* SOLUTION: *)
       Subject expansion does not hold in this language (or most
       interesting languages).  For example, [tif tfalse
       ttrue tzero] is ill typed, but it evaluates to the
       well-typed term [tzero].
    []
*)

(** **** Exercise: 2 stars (variation1) *)
(** Suppose, that we add this new rule to the typing relation:
      | T_SuccBool : forall t,
           |- t \in TBool ->
           |- tsucc t \in TBool
   Which of the following properties remain true in the presence of
   this rule?  For each one, write either "remains true" or
   else "becomes false." If a property becomes false, give a
   counterexample.
      - Determinism of [step]

            Remains true
      - Progress

            Becomes false:  [tsucc ttrue] is well typed, but stuck.
      - Preservation

            Remains true
[]
*)

(** **** Exercise: 2 stars (variation2) *)
(** Suppose, instead, that we add this new rule to the [step] relation:
      | ST_Funny1 : forall t2 t3,
           (tif ttrue t2 t3) ==> t3
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

       - Determinism becomes false: [tif ttrue
         tzero (tsucc tzero)] can now evaluate in one step
         to either [tzero] or [tsucc tzero].
[]
*)

(** **** Exercise: 2 stars, optional (variation3) *)
(** Suppose instead that we add this rule:
      | ST_Funny2 : forall t1 t2 t2' t3,
           t2 ==> t2' ->
           (tif t1 t2 t3) ==> (tif t1 t2' t3)
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

       - Determinism again becomes false: [tif
         tfalse (tpred tzero) (tsucc tzero)] can now
         evaluate in one step to either [tsucc tzero] or
         [tif tfalse tzero (tsucc tzero)].  (There are
         several other correct counter-examples.)
[]
*)

(** **** Exercise: 2 stars, optional (variation4) *)
(** Suppose instead that we add this rule:
      | ST_Funny3 :
          (tpred tfalse) ==> (tpred (tpred tfalse))
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

   All remain true
[]
*)

(** **** Exercise: 2 stars, optional (variation5) *)
(** Suppose instead that we add this rule:

      | T_Funny4 :
            |- tzero \in TBool
   ]]
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

       - Progress becomes false: [tif tzero ttrue ttrue]
         has type [TBool], is a normal form, and is not a
         value.
[]
*)

(** **** Exercise: 2 stars, optional (variation6) *)
(** Suppose instead that we add this rule:

      | T_Funny5 :
            |- tpred tzero \in TBool
   ]]
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

       - Preservation becomes false: [tpred tzero] has type
         [TBool] and evaluates in one step to [tzero], which
         does not have type [TBool].
[]
*)

(** **** Exercise: 3 stars, optional (more_variations) *)
(** Make up some exercises of your own along the same lines as
    the ones above.  Try to find ways of selectively breaking
    properties -- i.e., ways of changing the definitions that
    break just one of the properties and leave the others alone.
    []
*)

(** **** Exercise: 1 star (remove_predzero) *)
(** The evaluation rule [E_PredZero] is a bit counter-intuitive: we
    might feel that it makes more sense for the predecessor of zero to
    be undefined, rather than being defined to be zero.  Can we
    achieve this simply by removing the rule from the definition of
    [step]?  Would doing so create any problems elsewhere?

(* SOLUTION: *)
    Yes, but doing this would break the progress property.
    A better way would be to raise an exception in this case, but this
    requires that we add exceptions to the language we're formalizing!
[] *)

(** **** Exercise: 4 stars, advanced (prog_pres_bigstep) *)
(** Suppose our evaluation relation is defined in the big-step style.
    What are the appropriate analogs of the progress and preservation
    properties?

(* SOLUTION: *) The type preservation property for the big-step
    semantics is similar to the one we gave for the small-step
    semantics: if a well-typed term evaluates to some final value,
    then this value has the same type as the original term.  The proof
    is similar to the one we gave.

    The situation with the progress property is more interesting.  A
    direct analog (if a term is well typed then it evaluates to some
    other term) makes a much stronger claim than the progress theorem
    we have given: it says that every well-typed term can be evaluated
    to some final value---that is, that evaluation always terminates
    on well-typed terms.  For arithmetic expressions, this happens to
    be the case, but for more interesting languages (languages
    involving general recursion, for example) it will often not be
    true.  For such languages, we simply have no progress property in
    the big-step style: in effect, there is no way to tell the
    difference between reaching an error state and failing to
    terminate.  This is one reason that language theorists generally
    prefer the small-step style.
[]
*)

(* $Date$ *)


(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import Psatz.
Require Import QArith.

Lemma plus_minus : forall x y,
  0 == x + y -> 0 ==  x -y -> 0 == x /\ 0 == y.
Proof.
  intros.
  psatzl Q.
Qed.

(* Other (simple) examples *)
Open Scope Q_scope.

Lemma binomial : forall x y:Q, ((x+y)^2 == x^2 + (2 # 1) *x*y + y^2).
Proof.
  intros.
  psatzl Q.
Qed.

Lemma hol_light19 : forall m n, (2 # 1) * m + n == (n + m) + m.
Proof.
  intros ; psatzl Q.
Qed.
Open Scope Z_scope.
Open Scope Q_scope.

Lemma vcgen_25 : forall
  (n : Q)
  (m : Q)
  (jt : Q)
  (j : Q)
  (it : Q)
  (i : Q)
  (H0 : 1 * it + (-2 # 1) * i + (-1 # 1) == 0)
  (H :  1 * jt + (-2 # 1) * j + (-1 # 1) == 0)
  (H1 : 1 * n + (-10 # 1) = 0)
  (H2 : 0 <= (-4028 # 1)  * i + (6222 # 1) * j + (705 # 1)  * m + (-16674 # 1))
  (H3 : 0 <= (-418 # 1) * i + (651 # 1) * j + (94 # 1) * m + (-1866 # 1))
  (H4 : 0 <= (-209 # 1) * i + (302 # 1) * j + (47 # 1) * m + (-839 # 1))
  (H5 : 0 <= (-1 # 1) * i + 1 * j + (-1 # 1))
  (H6 : 0 <= (-1 # 1) * j + 1 * m + (0 # 1))
  (H7 : 0 <= (1 # 1) * j + (5 # 1) * m + (-27 # 1))
  (H8 : 0 <= (2 # 1) * j + (-1 # 1) * m + (2 # 1))
  (H9 : 0 <= (7 # 1) * j + (10 # 1) * m + (-74 # 1))
  (H10 : 0 <= (18 # 1) * j + (-139 # 1) * m + (1188 # 1))
  (H11 : 0 <= 1  * i + (0 # 1))
  (H13 : 0 <= (121 # 1)  * i + (810 # 1)  * j + (-7465 # 1) * m + (64350 # 1)),
  (( 1# 1) == (-2 # 1) * i + it).
Proof.
  intros.
  psatzl Q.
Qed.

Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False.
Proof.
  intros.
  psatz Q 2.
Qed.

Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - (3 # 1) *x^2*y^2) >= 0.
Proof.
  intros ; psatz Q.
Qed.


Axiom todo : forall {A}, A.

(* 2.1 Equality *)

Definition sym (A:Type) (x y:A) (e:x=y) : y = x :=
	eq_ind x (fun y0 => y0=x) eq_refl y e.

Definition trans (A:Type) (x y z:A) (e1:x=y) (e2:y=z) : x=z :=
	eq_ind y (fun z0 => x=z0) e1 z e2 .

Definition congr (A B:Type) (f:A->B) (x y:A) (e:x=y) : f x = f y :=
	eq_ind x (fun y0 => f x = f y0) eq_refl y e.

Print eq_rect.

Lemma dcongr (A:Type) (B:A->Type) (f:forall x:A, B x) (x y:A) (e:x=y) :
  eq_rect x B (f x) y e = f y.
Proof.
case e.
unfold eq_rect.
reflexivity.
Qed.

(* 3 Universes *)

(* 4.1 *)

Check (forall (P:Prop),P).
Check (forall (P:Type),P).
Check (forall (PP:Prop->Prop), exists (P:Prop), PP P).
Fail Check (forall (PP:Type->Type), exists (P:Type), PP P).

Definition conj (A B:Prop) : Prop :=
  forall Q:Prop, (A->B->Q) -> Q.

Definition conj_i (A B: Prop) (a:A) (b:B) : conj A B :=
	fun Q (f:A->B->Q) => f a b.

Definition conj_e1 (A B:Prop) (p: conj A B) : A :=
	p A (fun A B => A).

Definition conj_e2 (A B:Prop) (p: conj A B) : B :=
	p B (fun A B => B).

Definition disj (A B:Prop) : Prop :=
	forall Q:Prop, (A->Q) -> (B->Q) -> Q.

Definition disj_i1 (A B:Prop) (a:A) : disj A B :=
	fun Q f f' => f a.

Definition disj_i2 (A B:Prop) (b:B) : disj A B :=
	fun Q f f' => f' b.

Definition disj_e (A B:Prop) (p: disj A B) (Q:Prop) (f:A->Q) (f':B->Q) : Q :=
	p Q f f'.

Definition ex (A:Type) (P: A -> Prop) : Type :=
	forall Q:Prop, (forall x:A, P x -> Q) -> Q.

Definition ex_i (A :Type) (P: A -> Prop) (a:A) (b:P a) : ex A P  :=
	fun Q (f:forall x:A, P x -> Q) => f a b.

Definition ex_e (A:Type) (P:A->Prop) (p: ex A P) (Q:Prop) (f:forall (a:A) (b:P a), Q) : Q :=
	 p Q f.

Definition equ (A:Type) (a b:A) : Type :=
	forall (P:A->Prop), P a -> P b.

Definition equ_refl (A:Type) (x:A) : equ A x x  :=
	fun P h => h
	.

Definition equ_ind : todo := todo.

Definition equ_sym : todo := todo.
Definition equ_trans : todo := todo.

Definition equ_congr : todo := todo.

(* 4.2 *)

Definition bool : Prop :=
  forall Q:Prop, Q->Q->Q.

Definition true : bool := todo.
Definition false : bool := todo.

Definition ifthenelse : todo := todo.

Definition band : todo := todo.
Lemma band_ff : todo.
Proof. apply todo. Qed.
Lemma band_ft : todo.
Proof. apply todo. Qed.
Lemma band_tf : todo.
Proof. apply todo. Qed.
Lemma band_tt : todo.
Proof. apply todo. Qed.

(* 4.3 *)

Definition nat : Prop :=
  forall Q:Prop, Q -> (Q->Q) -> Q.

Definition zero : nat := todo.

Definition succ (n:nat) : nat := todo.

(* iterate n times successor on m *)
Definition plus (n m:nat) : nat := todo.

Definition mult (n m:nat) : nat := todo.

Eval compute in (mult (succ (succ zero)) (succ (succ (succ zero)))).

(* 5. *)

Definition pnat : Type := todo.

Definition pzero : pnat := todo.

Definition psucc (n:pnat) : pnat := todo.


Inductive formula : Set :=
| atom : nat -> formula
| false_f : formula
| or_f : formula -> formula -> formula
| and_f : formula -> formula -> formula
| implies_f : formula -> formula -> formula.

Infix "/\f" := and_f (at level 60, right associativity).
Infix "\/f" := or_f (at level 65, right associativity).
Infix "->f" := implies_f (at level 70, right associativity).

(* Some variable constants for convenience *)
Notation X := (atom 0).
Notation Y := (atom 1).
Notation Z := (atom 2).

Inductive MID := bot | mid | top.

Definition sel {A} (m : MID) (x y z : A): A :=
  match m with
  | bot => x
  | mid => y
  | top => z
  end.

Definition meet (m n : MID): MID :=
  sel m (sel n bot bot bot)
        (sel n bot mid mid)
        (sel n bot mid top).

Definition join (m n : MID): MID :=
  sel m (sel n bot mid top)
        (sel n mid mid top)
        (sel n top top top).

Definition impl (m n : MID): MID :=
  sel m (sel n top top top)
        (sel n bot top top)
        (sel n bot mid top).

Definition map := nat -> MID.

Fixpoint valuation (c : formula) (m : map) : MID :=
  match c with
  | atom v => m v
  | false_f => bot
  | a \/f b => join (valuation a m) (valuation b m)
  | a /\f b => meet (valuation a m) (valuation b m)
  | a ->f b => impl (valuation a m) (valuation b m)
  end.

Definition MID_valid (c : formula) := forall m, valuation c m = top.

Definition substitution := nat -> formula.

Fixpoint subst (c : formula) (s : substitution) : formula :=
  match c with
  | atom v => s v
  | false_f => false_f
  | a \/f b => subst a s \/f subst b s
  | a /\f b => subst a s /\f subst b s
  | a ->f b => subst a s ->f subst b s
  end.

Inductive hilbert : formula -> Prop :=
| app_h : forall a b, hilbert (a ->f b) -> hilbert a -> hilbert b
| subst_h : forall a s, hilbert a -> hilbert (subst a s)
| k_h : hilbert (X ->f Y ->f X)
| s_h : hilbert ((X ->f Y ->f Z) ->f (X ->f Y) ->f (X ->f Z))
| fst_h : hilbert (X /\f Y ->f X)
| snd_h : hilbert (X /\f Y ->f Y)
| pair_h : hilbert (X ->f Y ->f X /\f Y)
| inl_h : hilbert (X ->f X \/f Y)
| inr_h : hilbert (Y ->f X \/f Y)
| either_h : hilbert ((X ->f Z) ->f (Y ->f Z) ->f (X \/f Y ->f Z))
| absurd_h : hilbert (false_f ->f X).

Definition LEM := X \/f (X ->f false_f).

Lemma hilbert_MID_sound : forall c, hilbert c -> MID_valid c.
Proof with (try easy).
  fix HH 1.
  intros.
  unfold MID_valid.
  induction H; intros.
  destruct a, b...
  all: simpl in *.
  all: multimatch goal with
  | H: forall m : map, _, H2: forall m : map, _ |- _ => pose proof (H m); pose proof (H2 m)
  | H: forall m : map, _ |- _ => pose proof (H m)
  | _ => idtac
  end; try easy.
  destruct (m n), (m n0)...
  destruct (m n)...
  all: multimatch goal with
  | |- join ?U ?I = top => destruct (join U I)
  | |- meet ?U ?I = top => destruct (meet U I)
  | _ => idtac
  end; try easy.
  all: multimatch goal with
  | [ u : nat |- _ ] => destruct (m u)
  | [ |- impl (valuation ?b1 ?m) (valuation ?b2 ?m) = top ] => destruct (impl (valuation b1 m) (valuation b2 m))
  | _ => idtac
  end; try easy.
  all: multimatch goal with
  | [ |- impl (valuation ?b1 ?m) (valuation ?b2 ?m) = top ] => destruct (impl (valuation b1 m) (valuation b2 m))
  | [ u : nat |- _ ] => destruct (m u)
  | _ => idtac
  end; try easy.
  all: multimatch goal with
  | H: join ?U ?I = top |- _ => destruct (join U I)
  | H: meet ?U ?I = top |- _ => destruct (meet U I)
  | [H: impl (valuation ?b1 ?m) (valuation ?b2 ?m) = top |- _ ] => destruct (impl (valuation b1 m) (valuation b2 m))
  | _ => idtac
  end; try easy.
  all: multimatch goal with
  | |- context [?m 2] => destruct (m 2)
  | _ => idtac
  end; try easy.
  all: multimatch goal with
  | |- context [?m 1] => destruct (m 1)
  | _ => idtac
  end; try easy.
  all: multimatch goal with
  | |- context [?m 0] => destruct (m 0)
  | _ => idtac
  end; try easy.

  pose (mbot (n : nat) := valuation (s n) m).
  pose proof (IHhilbert mbot).
  clear -H1.
  induction a; intros; try easy; simpl in *.
  assert (valuation a1 mbot = top \/ valuation a2 mbot = top).
  destruct (valuation a1 mbot), (valuation a2 mbot); try auto.
  destruct H.
  rewrite (IHa1 ltac:(easy)).
  destruct (valuation (subst a2 s) m); try easy.
  rewrite (IHa2 ltac:(easy)).
  destruct (valuation (subst a1 s) m); try easy.
  destruct (valuation a1 mbot), (valuation a2 mbot); try easy.
  rewrite (IHa1 eq_refl).
  rewrite (IHa2 eq_refl).
  reflexivity.

Lemma LEM_not_MID_valid : ~ MID_valid LEM.
Proof.
  intros H.
  unfold MID_valid, LEM in H.
  specialize (H (fun n => mid)).
  simpl in H.
  easy.
Qed.

Theorem hilbert_LEM_not_provable : ~ hilbert LEM.
Proof.
  (* This should not need modifying *)
  auto using LEM_not_MID_valid, hilbert_MID_sound.
Qed.


Require Import ssreflect ssrbool.
Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Export DecList.
Require Export DecSort.
Require Export mBidAsk.
Require Export Quantity.
Require Export mMatching.
Require Export MatchingAlter.

Section Bound.

(*-------------- buyers_above and sellers_above relationship and results------------------*)

Definition buyers_above (p: nat)(B: list Bid): list Bid :=
  filter (fun x:Bid => Nat.leb p (bp x))  B.

Lemma buyers_above_elim (p:nat)(B: list Bid)(x:Bid):
  In x (buyers_above p B)-> bp(x) >= p.
Proof. { unfold buyers_above. intros H.
         induction B.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (Nat.leb p a) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHB in H. exact. }
            { apply IHB in H. exact. }}} Qed.

Lemma buyers_above_intro (p:nat)(B: list Bid)(x:Bid):
 ( In x B /\ (Nat.leb p x)) -> In x (buyers_above p B).
Proof. { intros H. destruct H as [H1  H2].
         induction B.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (Nat.leb p a) eqn: Hpa. auto.
            apply IHB. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHB in H1b. simpl. destruct (Nat.leb p a) eqn: Hpa.
             eauto. exact. }}} Qed.

Definition sellers_above (p: nat)(A: list Ask): list Ask :=
  filter (fun x:Ask => Nat.leb p (sp x)) (A).

Lemma sellers_above_elim (p:nat)(A: list Ask)(x:Ask):
  In x (sellers_above p A)-> sp(x) >= p.
Proof. { unfold sellers_above. intros H.
         induction A.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (Nat.leb p a) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHA in H. exact. }
            { apply IHA in H. exact. }}} Qed.

Lemma sellers_above_intro (p:nat)(A: list Ask)(x:Ask):
 ( In x A /\ Nat.leb p x ) -> In x (sellers_above p A).
Proof. { intros H. destruct H as [H1  H2].
         induction A.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (Nat.leb p a) eqn: Hpa. auto.
             apply IHA. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHA in H1b. simpl. destruct (Nat.leb p a) eqn: Hpa.
             eauto. exact. }}} Qed.

Definition buyers_below (p: nat)(B: list Bid): list Bid :=
  filter (fun x:Bid => Nat.ltb (bp x) p) (B).

Lemma buyers_below_intro (p:nat)(B: list Bid)(x:Bid):
 ( In x B /\ Nat.ltb x p ) -> In x (buyers_below p B).
Proof. { intros H. destruct H as [H1  H2].
         induction B.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (Nat.ltb a p) eqn: Hpa. auto.
             apply IHB. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHB in H1b. simpl. destruct (Nat.ltb a p) eqn: Hpa.
             eauto. exact. }}} Qed.

Lemma buyers_below_elim (p:nat)(B: list Bid)(x:Bid):
  In x (buyers_below p B)-> bp(x) < p.
Proof.  { unfold sellers_above. intros H.
         induction B.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (Nat.ltb a p) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHB in H. exact. }
            { apply IHB in H. exact. }}} Qed.

Definition sellers_below (p: nat)(A: list Ask): list Ask :=
  filter (fun x:Ask => Nat.leb (sp x) p) (A).

Lemma sellers_below_intro (p:nat)(A: list Ask)(x:Ask):
 ( In x A /\ Nat.leb x p ) -> In x (sellers_below p A).
Proof. { intros H. destruct H as [H1  H2].
         induction A.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (Nat.leb a p) eqn: Hpa. auto.
             apply IHA. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHA in H1b. simpl. destruct (Nat.leb a p) eqn: Hpa.
             eauto. exact. }}} Qed.

Lemma sellers_below_elim (p:nat)(A: list Ask)(x:Ask):
  In x (sellers_below p A)-> sp(x) <= p.
Proof. { unfold sellers_below. intros H.
         induction A.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (Nat.leb a p) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHA in H. exact. }
            { apply IHA in H. exact. }}} Qed.

(*#########Theorem in the paper###############*)

Lemma maching_buyer_right_plus_seller_left (B:list Bid)(A:list Ask):
forall p M, (matching_in B A M) ->
QM(M) <= QB(buyers_above p (bids_of M)) + QA(sellers_below p (asks_of M)).
intros. induction M as [|m M']. simpl. auto.
simpl. assert(HM:matching_in B A (delete m (m::M'))).
       eauto. simpl in HM. replace (m_eqb m m) with true in HM.
       apply IHM' in HM.
       assert(tq m <= bq (bid_of m)).
       apply tqm_le_bqm with (M:=m::M')(B:=B)(A:=A).
       auto. auto.
       assert(tq m <= sq (ask_of m)).
       apply tqm_le_sqm with (M:=m::M')(B:=B)(A:=A).
       auto. auto.
       destruct (Nat.leb p (bid_of m)) eqn: Hpb;
       destruct (Nat.leb (ask_of m) p) eqn: Hpa.
       all:simpl. all: (try lia).
       { move /leP in Hpb. move /leP in Hpa.
         assert(ask_of m <= bid_of m).
         apply H. auto. lia.
       } eauto.
Qed.

(*Now we prove our main combinatorial result *)

Lemma buyers_above_nodup (B:list Bid) (Ndb: NoDup B) (p:nat):
NoDup (buyers_above p B).
Proof. induction B. simpl. constructor. simpl.
destruct (Nat.leb p a) eqn: Hpa. assert (H0:~In a B).
eauto. assert (H1:~In a (buyers_above p B)). eauto.
assert (H2: NoDup B). eauto. eapply IHB in H2. eauto.
assert (H2: NoDup B). eauto. eapply IHB in H2. eauto. Qed.

Lemma sellers_below_nodup (A:list Ask) (Nda: NoDup A) (p:nat):
NoDup (sellers_below p A).
Proof. induction A. simpl. constructor. simpl.
destruct (Nat.leb a p) eqn: Hpa. assert (H0:~In a A).
eauto. assert (H1:~In a (sellers_below p A)). eauto.
assert (H2: NoDup A). eauto. eapply IHA in H2. eauto.
assert (H2: NoDup A). eauto. eapply IHA in H2. eauto. Qed.

Definition Mbgep (p: nat)(M: list fill_type): list fill_type :=
  filter (fun x:fill_type => Nat.leb p (bp (bid_of x))) M.

Definition Mbltp (p: nat)(M: list fill_type): list fill_type :=
  filter (fun x:fill_type => Nat.ltb (bp (bid_of x)) p) M.

Lemma Mbgep_elim (p:nat)(M: list fill_type)(x:fill_type):
  In x (Mbgep p M)-> (bp (bid_of x)) >= p.
Proof. { unfold Mbgep. intros H.
         induction M.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (Nat.leb p (bid_of a)) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHM in H. exact. }
            { apply IHM in H. exact. }}} Qed.

Lemma Mbgep_intro (p:nat)(M: list fill_type)(x:fill_type):
 ( In x M /\ (Nat.leb p (bid_of x))) -> In x (Mbgep p M).
Proof. { intros H. destruct H as [H1  H2].
         induction M.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (Nat.leb p (bid_of a)) eqn: Hpa. auto.
             elim H2.
            apply IHM. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHM in H1b. simpl. destruct (Nat.leb p (bid_of a)) eqn: Hpa.
             eauto. exact. }}} Qed.

Lemma Mbltp_elim (p:nat)(M: list fill_type)(x:fill_type):
  In x (Mbltp p M)->  p> (bp (bid_of x)).
Proof. { unfold Mbltp. intros H.
         induction M.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (Nat.ltb (bid_of a) p) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHM in H. exact. }
            { apply IHM in H. exact. }}} Qed.

Lemma Mbltp_intro (p:nat)(M: list fill_type)(x:fill_type):
 ( In x M /\ (Nat.ltb (bid_of x) p)) -> In x (Mbltp p M).
Proof. { intros H. destruct H as [H1  H2].
         induction M.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (Nat.ltb (bid_of a) p) eqn: Hpa. auto.
             elim H2.
            apply IHM. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHM in H1b. simpl. destruct (Nat.ltb (bid_of a) p) eqn: Hpa.
             eauto. exact. }}} Qed.

Lemma Mbgep_bids_subsetBp (p:nat)(M: list fill_type)(B:list Bid):
bids_of M [<=] B -> bids_of ((Mbgep p M)) [<=] (buyers_above p B).
Proof. intros. unfold "[<=]". intros.
set (M1:=(Mbgep p M)). assert(exists x, In x M1/\a=bid_of x).
eauto. destruct H1 as [m H1]. destruct H1. apply Mbgep_elim in H1 as H3.
assert(In m M). eauto. assert(In (bid_of m) B). eauto.
assert(In a (buyers_above p B)). apply buyers_above_intro.
subst. split. auto. apply /leP. lia. auto. Qed.

Lemma Mbgep_ttqb (p:nat)(M: list fill_type)(b:Bid):
ttqb ((Mbgep p M)) b <= ttqb M b.
Proof. induction M as [| m M']. simpl. auto.
simpl.
destruct (Nat.leb p (bid_of m)) eqn: Hpm;destruct (b_eqb b (bid_of m)) eqn:Hbm.
{ simpl. rewrite Hbm. lia. }
{ simpl. rewrite Hbm. lia. }
{ lia. }
{ lia. } Qed.

Lemma Mbltp_asks_subsetAp (p:nat)(M: list fill_type)(A:list Ask):
All_matchable M -> asks_of M [<=] A -> asks_of ((Mbltp p M)) [<=] (sellers_below p A).
Proof.
intros. unfold "[<=]". intros.
set (M1:=(Mbltp p M)). assert(exists x, In x M1/\a=ask_of x).
eauto. destruct H2 as [m H2]. destruct H2. apply Mbltp_elim in H2 as H4.
assert(In m M). eauto. assert(In (ask_of m) A). eauto.
assert(In a (sellers_below p A)). apply sellers_below_intro.
subst. split. auto. apply /leP.
apply H in H5.
 lia. auto. Qed.

Lemma Mbltp_ttqa (p:nat)(M: list fill_type)(a:Ask):
ttqa ((Mbltp p M)) a <= ttqa M a.
Proof. induction M as [| m M']. simpl. auto.
simpl.
destruct (Nat.ltb (bid_of m) p) eqn: Hpm;destruct (a_eqb a (ask_of m)) eqn:Ham.
{ simpl. rewrite Ham. lia. }
{ simpl. rewrite Ham. lia. }
{ lia. }
{ lia. } Qed.

Lemma Mbgep_bound (p:nat)(M: list fill_type)(B:list Bid)(A:list Ask)
(NDB:NoDup B):
matching_in B A M -> QM((Mbgep p M)) <= QB(buyers_above p B).
Proof.
intros. rewrite <- QM_equal_QMb with (B:=(buyers_above p B)).
apply fill_size_vs_bid_size. apply buyers_above_nodup.
auto. intros.
assert(bids_of ((Mbgep p M)) [<=] (buyers_above p B)).
apply Mbgep_bids_subsetBp. apply H.
assert(ttqb (Mbgep p M) b <= ttqb M b).
apply Mbgep_ttqb. cut(ttqb M b <= bq b).
lia.
assert(In b (bids_of M)\/~In b (bids_of M)).
eauto. destruct H3.
apply H. auto. apply ttqb_elim in H3. lia.
apply buyers_above_nodup. auto. apply Mbgep_bids_subsetBp. apply H.
Qed.

Lemma Mbltp_bound (p:nat)(M: list fill_type)(B:list Bid)(A:list Ask)
(NDA:NoDup A):
matching_in B A M -> QM((Mbltp p M)) <= QA(sellers_below p A).
Proof.
intros. rewrite <- QM_equal_QMa with (A:=(sellers_below p A)).
apply fill_size_vs_ask_size. apply sellers_below_nodup. auto. intros.
assert(asks_of ((Mbltp p M)) [<=] (sellers_below p A)).
apply Mbltp_asks_subsetAp. apply H. apply H.
assert(ttqa (Mbltp p M) a <= ttqa M a).
apply Mbltp_ttqa. cut(ttqa M a <= sq a).
lia.
assert(In a (asks_of M)\/~In a (asks_of M)).
eauto. destruct H3.
apply H. auto. apply ttqa_elim in H3. lia.
apply sellers_below_nodup. auto. apply Mbltp_asks_subsetAp. apply H. apply H.
Qed.

Lemma M_bound_volume (p:nat)(M: list fill_type):
QM(M) = QM(Mbgep p M) + QM(Mbltp p M).
Proof. induction M. simpl. auto.
simpl.
destruct (Nat.leb p (bid_of a)) eqn:H1;destruct(Nat.ltb (bid_of a) p) eqn:H2.
{ move /leP in H1. move /leP in H2. lia. }
{ move /leP in H1. move /leP in H2. simpl. lia. }
{ move /leP in H1. move /leP in H2. simpl. lia. }
{ move /leP in H1. move /leP in H2. lia. } Qed.

Theorem bound_on_M
(M: list fill_type) (B:list Bid) (A:list Ask) (p:nat)
(NDB: NoDup B)(NDA: NoDup A):
(matching_in B A M) ->
QM(M)<= QB(buyers_above p B) + QA(sellers_below p A).
Proof. intros. apply Mbgep_bound with (p:=p) in H as H1.
apply Mbltp_bound with (p:=p) in H as H2.
assert(QM(M) = QM(Mbgep p M) + QM(Mbltp p M)).
apply M_bound_volume with (p:=p). lia. all:auto. Qed.

End Bound.


Require Export List.
Require Export Bool.
Require Export Lia.
Require Export Peano_dec.

Module Classic.

  Lemma axiom_of_choice (A : Set) (B : Set) :
    forall phi : A -> B -> Prop,
    (forall x : A, { y : B | phi x y }) ->
    { f : A -> B | forall x : A, phi x (f x) }.
  Proof.
    intros phi.
    intro H.
    apply (exist (fun f : A -> B => forall x : A, phi x (f x)) (fun x : A => proj1_sig (H x))).
    intros x.
    unfold proj1_sig.
    destruct (H x).
    apply p.
  Qed.

  Axiom ex_middle : forall P : Prop, P \/ ~P.

End Classic.

Module Ordering.

  Inductive ordering : Set :=
  | LT : ordering
  | EQ : ordering
  | GT : ordering
  .

  Fixpoint compareNats (lhs : nat) (rhs : nat) : ordering :=
    match lhs, rhs with
    | 0, 0 => EQ
    | 0, S rhs' => LT
    | S lhs', 0 => GT
    | S lhs', S rhs' => compareNats lhs' rhs'
    end
  .

  Lemma property_compareNats :
    forall lhs rhs : nat,
    (lhs < rhs /\ compareNats lhs rhs = LT) \/
    (lhs = rhs /\ compareNats lhs rhs = EQ) \/
    (lhs > rhs /\ compareNats lhs rhs = GT).
  Proof.
    intros lhs.
    induction lhs.
    - destruct rhs.
      * simpl.
        tauto.
      * simpl.
        assert (0 < S rhs).
          lia.
        tauto.
    - destruct rhs.
      * simpl.
        assert (S lhs > 0).
          lia.
        tauto.
      * simpl.
        assert
          ( lhs < rhs /\ compareNats lhs rhs = LT \/
            lhs = rhs /\ compareNats lhs rhs = EQ \/
            lhs > rhs /\ compareNats lhs rhs = GT
          ).
        apply (IHlhs rhs).
        intuition.
  Qed.

  Theorem property_LT :
    forall lhs rhs : nat,
    LT = compareNats lhs rhs <-> lhs < rhs.
  Proof.
    intros lhs rhs.
    assert
      ( lhs < rhs /\ compareNats lhs rhs = LT \/
        lhs = rhs /\ compareNats lhs rhs = EQ \/
        lhs > rhs /\ compareNats lhs rhs = GT
      ).
      apply (property_compareNats lhs rhs).
    constructor.
      intro.
      intuition.
      assert (LT = EQ).
        rewrite <- H0 in H2.
        apply H2.
      discriminate H.
      assert (LT = GT).
        rewrite <- H0 in H2.
        apply H2.
      discriminate H.
      intro.
      assert (~lhs = rhs).
        lia.
      assert (~lhs > rhs).
        lia.
      intuition.
  Qed.

  Theorem property_EQ :
    forall lhs rhs : nat,
    EQ = compareNats lhs rhs <-> lhs = rhs.
  Proof.
    intros lhs rhs.
    assert
      ( lhs < rhs /\ compareNats lhs rhs = LT \/
        lhs = rhs /\ compareNats lhs rhs = EQ \/
        lhs > rhs /\ compareNats lhs rhs = GT
      ).
      apply (property_compareNats lhs rhs).
    constructor.
      intro.
      intuition.
      assert (EQ = LT).
        rewrite <- H0 in H2.
        apply H2.
      discriminate H1.
      assert (EQ = GT).
        rewrite <- H0 in H2.
        apply H2.
      discriminate H.
      intro.
      assert (~lhs < rhs).
        lia.
      assert (~lhs > rhs).
        lia.
      intuition.
  Qed.

  Theorem property_GT :
    forall lhs rhs : nat,
    GT = compareNats lhs rhs <-> lhs > rhs.
  Proof.
    intros lhs rhs.
    assert
      ( lhs < rhs /\ compareNats lhs rhs = LT \/
        lhs = rhs /\ compareNats lhs rhs = EQ \/
        lhs > rhs /\ compareNats lhs rhs = GT
      ).
      apply (property_compareNats lhs rhs).
    constructor.
      intro.
      intuition.
      assert (GT = LT).
        rewrite <- H0 in H2.
        apply H2.
      discriminate H1.
      assert (GT = EQ).
        rewrite <- H0 in H2.
        apply H2.
      discriminate H.
      intro.
      assert (~lhs < rhs).
        lia.
      assert (~lhs = rhs).
        lia.
      intuition.
  Qed.

End Ordering.

Module ListTheory.

  Section General.

    Import ListNotations.

    Variable A : Type.

    Variable eq_A_dec : forall x y : A, {x = y} + {x <> y}.

    Variable B : Type.

    Fixpoint areAllDistinct (xs : list A) : Prop :=
      match xs with
      | [] => True
      | x :: xs' => not (In x xs') /\ areAllDistinct xs'
      end
    .

    Lemma len_append :
      forall (xs ys : list A),
      length (xs ++ ys) = length xs + length ys.
    Proof.
      intros xs ys.
      induction xs.
      - simpl.
        reflexivity.
      - simpl.
        lia.
    Qed.

    Lemma len_map :
      forall f : A -> B,
      forall xs : list A,
      length xs = length (map f xs).
    Proof.
      intros f xs.
      induction xs.
      - simpl.
        tauto.
      - simpl.
        lia.
    Qed.

    Lemma in_or_not_in :
      forall xs : list A,
      forall x : A,
      In x xs \/ ~ In x xs.
    Proof.
      intros xs.
      induction xs.
      simpl.
      tauto.
      simpl.
      intro x.
      destruct (eq_A_dec a x).
      tauto.
      destruct (IHxs x).
      tauto.
      tauto.
    Qed.

    Lemma in_append :
      forall x : A,
      forall (xs ys : list A),
      In x (xs ++ ys) <-> (In x xs \/ In x ys).
    Proof.
      intros x xs ys.
      constructor.
      - induction xs.
        * simpl.
          tauto.
        * simpl.
          tauto.
      - intro.
        induction xs.
        * simpl.
          destruct H.
          + elimtype False.
            apply H.
          + apply H.
        * simpl.
          destruct H.
          + destruct H.
            apply (or_introl H).
            apply or_intror.
            tauto.
          + tauto.
    Qed.

    Lemma in_map :
      forall f : A -> B,
      forall xs : list A,
      forall x : A,
      In x xs -> In (f x) (map f xs).
    Proof.
      intros f xs.
      induction xs.
      - simpl.
        tauto.
      - intros x.
        simpl.
        intro.
        destruct H.
        * subst.
          tauto.
        * apply (or_intror (IHxs x H)).
    Qed.

    Lemma in_middle :
      forall (x y : A),
      forall (xs ys : list A),
      In x (xs ++ y :: ys) <-> (x = y \/ In x (xs ++ ys)).
    Proof.
      intros x y xs ys.
      induction xs.
      - constructor.
        * simpl.
          intro.
          destruct H.
          apply or_introl.
          auto.
          tauto.
        * simpl.
          intro.
          destruct H.
          auto.
          auto.
      - constructor.
        * simpl.
          tauto.
        * simpl.
          tauto.
    Qed.

    Lemma in_map_in :
      forall f : A -> B,
      forall xs : list A,
      forall y : B,
      In y (map f xs) ->
      exists x : A, y = f x /\ In x xs.
    Proof.
      intros f xs.
      induction xs.
      - intros y.
        simpl.
        tauto.
      - intros y.
        simpl.
        intro.
        destruct H.
        * exists a.
          subst.
          tauto.
        * destruct (IHxs y H).
          exists x.
          tauto.
    Qed.

    Lemma in_map_inj :
      forall f : A -> B,
      (forall x1 x2 : A, f x1 = f x2 -> x1 = x2) ->
      forall xs : list A,
      forall x : A,
      In (f x) (map f xs) -> In x xs.
    Proof.
      intros f.
      intro.
      intros xs.
      induction xs.
      - intros x.
        simpl.
        tauto.
      - intros x.
        simpl.
        intro.
        destruct H0.
        * apply (or_introl (H a x H0)).
        * apply (or_intror (IHxs x H0)).
    Qed.

    Lemma split_middle :
      forall x : A,
      forall xs : list A,
      In x xs ->
      exists ls : list A,
      exists rs : list A,
      xs = ls ++ x :: rs.
    Proof.
      intros x xs.
      induction xs.
      - simpl.
        intro.
        elimtype False.
        apply H.
      - intro.
        destruct H.
        * exists [].
          exists xs.
          subst.
          simpl.
          reflexivity.
        * destruct (IHxs H) as [ls H0].
          destruct (H0) as [rs].
          exists (a :: ls).
          exists rs.
          subst.
          simpl.
          reflexivity.
    Qed.

    Theorem pigeon_hole :
      forall (xs xs' : list A),
      (forall x : A, In x xs -> In x xs') ->
      length xs' < length xs ->
      not (areAllDistinct xs).
    Proof.
      intros xs.
      induction xs.
      - intros xs'.
        simpl.
        intro.
        lia.
      - intros xs'.
        simpl.
        intro.
        assert (H0 : exists ls : list A, exists rs : list A, xs' = ls ++ a :: rs).
        apply (fun H0 : In a xs' => split_middle a xs' H0).
        apply (H a).
        simpl.
        tauto.
        destruct H0 as [ls H0].
        destruct H0 as [rs H0].
        subst.
        assert (H0 : length (ls ++ a :: rs) = length ls + length (a :: rs)).
        apply (len_append ls (a :: rs)).
        subst.
        rewrite H0.
        simpl.
        intro.
        intro.
        destruct H2.
        apply (IHxs (ls ++ rs)).
        * intros x.
          intro.
          apply (proj2 (in_append x ls rs)).
          destruct (eq_A_dec a x).
          + subst.
            elimtype False.
            apply (H2 H4).
          + apply (proj1 (in_append x ls rs)).
            assert (H6 : In x (ls ++ a :: rs)).
            apply (H x (or_intror H4)).
            assert (H7 : a = x \/ In x (ls ++ rs)).
            destruct (proj1 (in_middle x a ls rs)).
            apply H6.
            apply or_introl.
            subst.
            reflexivity.
            apply or_intror.
            apply H5.
            destruct H7.
            elimtype False.
            apply (n H5).
            apply H5.
        * assert (H4 : length (ls ++ rs) = length ls + length rs).
          apply (len_append ls rs).
          lia.
        * apply H3.
    Qed.

  End General.

  Section Nat.

    Import ListNotations.

    Lemma enum_exists :
      forall from : nat,
      forall to : nat,
      forall f_le_t : from <= to,
      exists enum : list nat,
      (from + length enum = to) /\
      (areAllDistinct nat enum) /\
      forall n : nat,
      In n enum <->
      (from <= n /\ n < to)
      .
    Proof.
      intros from to f_le_t.
      induction f_le_t as [| to].
      - exists [].
        constructor.
        simpl.
        lia.
        simpl.
        constructor.
        trivial.
        intros n.
        lia.
      - destruct IHf_le_t as [enum H].
        destruct H.
        exists (to :: enum).
        constructor.
        simpl.
        lia.
        simpl.
        destruct H0.
        constructor.
        constructor.
        intro.
        assert (from <= to < to).
        apply (proj1 (H1 to) H2).
        lia.
        apply H0.
        intros n.
        constructor.
        intro.
        destruct H2.
        subst.
        lia.
        assert (from <= n /\ n < to).
        apply (proj1 (H1 n) H2).
        lia.
        intro.
        destruct (eq_nat_dec to n).
        simpl.
        tauto.
        assert (from <= n /\ n < to).
        lia.
        simpl.
        apply or_intror.
        apply (proj2 (H1 n) H3).
    Qed.

    Theorem pigeon_hole_nat :
      forall size : nat,
      forall ns : list nat,
      (forall n : nat, In n ns <-> n < size) ->
      areAllDistinct nat ns ->
      length ns = size.
    Proof.
      intros size ns.
      destruct (enum_exists 0 size) as [enum H].
      lia.
      intro.
      intro.
      assert (not (length ns > size)).
      intro.
      apply (pigeon_hole nat eq_nat_dec ns enum).
      destruct H.
      destruct H3.
      intros n.
      assert (n < size <-> 0 <= n < size).
      lia.
      intro.
      apply (proj2 (H4 n)).
      apply (proj1 H5).
      apply (proj1 (H0 n) H6).
      destruct H.
      lia.
      apply H1.
      destruct H.
      destruct H3.
      assert (not (length ns < size)).
      intro.
      apply (pigeon_hole nat eq_nat_dec enum ns).
      intros n.
      assert (n < size <-> 0 <= n < size).
      lia.
      intro.
      apply (proj2 (H0 n)).
      apply (proj2 H6).
      apply (proj1 (H4 n) H7).
      lia.
      apply H3.
      lia.
    Qed.

  End Nat.

End ListTheory.

Module GraphTheory.

  Record Graph : Type :=
    { Vertex : Set
    ; Edge : Vertex -> Vertex -> Prop
    }
  .

  Section General.

    Import ListNotations.

    Import ListTheory.

    Variable g : Graph.

    Variable eq_gVertex_dec : forall v1 v2 : g.(Vertex), {v1 = v2} + {v1 <> v2}.

    Inductive Path : list g.(Vertex) -> g.(Vertex) -> g.(Vertex) -> Prop :=
    | PZ :
      forall beg : g.(Vertex),
      Path [beg] beg beg
    | PS :
      forall beg cur next : g.(Vertex),
      forall visiteds : list g.(Vertex),
      g.(Edge) cur next ->
      not (In next visiteds) ->
      Path visiteds beg cur ->
      Path (next :: visiteds) beg next
    .

    Inductive Walk : list g.(Vertex) -> g.(Vertex) -> g.(Vertex) -> Prop :=
    | WZ :
      forall beg : g.(Vertex),
      Walk [] beg beg
    | WS :
      forall trace : list g.(Vertex),
      forall beg cur next : g.(Vertex),
      g.(Edge) cur next ->
      Walk trace beg cur ->
      Walk (cur :: trace) beg next
    .

    Lemma subpath_exist :
      forall visiteds : list g.(Vertex),
      forall beg cur : g.(Vertex),
      Path visiteds beg cur ->
      forall prev : g.(Vertex),
      In prev visiteds ->
      exists visiteds' : list g.(Vertex),
      Path visiteds' beg prev.
    Proof.
      intros visiteds beg cur.
      intro.
      induction H.
      intros prev.
      intro.
      inversion H.
      exists [beg].
      subst.
      apply PZ.
      inversion H0.
      intros prev.
      intro.
      inversion H2.
      subst.
      exists (prev :: visiteds).
      apply (PS beg cur prev visiteds H H0 H1).
      apply (IHPath prev H3).
    Qed.

    Theorem walk_implies_path :
      forall trace : list g.(Vertex),
      forall beg cur : g.(Vertex),
      Walk trace beg cur ->
      exists visiteds,
      Path visiteds beg cur.
    Proof.
      intros trace beg cur.
      intro.
      induction H.
      exists [beg].
      apply (PZ beg).
      destruct IHWalk as [visiteds].
      destruct (in_or_not_in g.(Vertex) eq_gVertex_dec visiteds next).
      apply (subpath_exist visiteds beg cur H1 next H2).
      exists (next :: visiteds).
      apply (PS beg cur next visiteds H H2 H1).
    Qed.

    Proposition visiteds_are_all_distinct :
      forall visiteds : list g.(Vertex),
      forall beg cur : g.(Vertex),
      Path visiteds beg cur ->
      areAllDistinct g.(Vertex) visiteds.
    Proof.
      intros visiteds beg cur.
      intro.
      induction H.
      - subst.
        simpl.
        tauto.
      - subst.
        simpl.
        tauto.
    Qed.

  End General.

  Section Finite.

    Import ListNotations.

    Import ListTheory.

    Variable g : Graph.

    Variable eq_gVertex_dec : forall v1 v2 : g.(Vertex), {v1 = v2} + {v1 <> v2}.

    Variable size : nat.

    Variable can_enum_vertices : (exists vertices : list g.(Vertex), areAllDistinct g.(Vertex) vertices /\ length vertices = size /\ (forall v : g.(Vertex), In v vertices)).

    Proposition len_path_leq_size :
      forall visiteds : list g.(Vertex),
      forall beg cur : g.(Vertex),
      Path g visiteds beg cur ->
      length visiteds <= size.
    Proof.
      intros visiteds beg cur.
      intro.
      destruct can_enum_vertices as [vertices].
      assert (not (length visiteds > size)).
        intro.
        destruct H0.
        destruct H2.
        apply (pigeon_hole g.(Vertex) eq_gVertex_dec visiteds vertices).
          intros v.
          intro.
          apply (H3 v).
          lia.
          apply (visiteds_are_all_distinct g visiteds beg cur H).
        lia.
    Qed.

  End Finite.

End GraphTheory.

Module ETC.

  Fixpoint first_nat (p : nat -> bool) (n : nat) : nat :=
    match n with
    | 0 => 0
    | S n' => if p (first_nat p n') then first_nat p n' else n
    end
  .

  Theorem well_ordering_principle :
    forall p : nat -> bool,
    (exists n : nat, p n = true) ->
    (exists m : nat, p m = true /\ (forall i : nat, p i = true -> i >= m)).
  Proof.
    intros p.
    assert (forall x : nat, p x = true -> p (first_nat p x) = true).
      intros x.
      induction x.
      tauto.
      simpl.
      cut (let b := p (first_nat p x) in p (S x) = true -> p (if b then first_nat p x else S x) = true).
        simpl.
        tauto.
      intros.
      assert (b = true \/ b = false).
        destruct b.
          tauto.
          tauto.
      destruct H0.
      rewrite H0.
      unfold b in H0.
      apply H0.
      rewrite H0.
      apply H.
    assert (forall x : nat, first_nat p x <= x).
      intros x.
      induction x.
        simpl.
        lia.
        simpl.
        cut (let b := p (first_nat p x) in (if b then first_nat p x else S x) <= S x).
          simpl.
          tauto.
        intros.
        assert (b = true \/ b = false).
          destruct b.
            tauto.
            tauto.
        destruct H0.
          rewrite H0.
          lia.
          rewrite H0.
          lia.
    assert (forall x : nat, p (first_nat p x) = true -> (forall y : nat, x < y -> first_nat p x = first_nat p y)).
      intros x.
      intro.
      intros y.
      intro.
      induction H2.
        simpl.
        rewrite H1.
        tauto.
        simpl.
        rewrite <- IHle.
        rewrite H1.
        tauto.
    assert (forall x : nat, forall y : nat, p y = true -> first_nat p x <= y).
      intros x.
      intros y.
      intro.
      assert (x <= y \/ x > y).
        lia.
      destruct H3.
      assert (first_nat p x <= x <= y).
        constructor.
        apply (H0 x).
        apply H3.
        lia.
      assert (p (first_nat p y) = true).
        apply (H y).
        assert (first_nat p x <= x).
          apply (H0 x).
          apply H2.
      assert (first_nat p y = first_nat p x).
        apply (H1 y).
        apply H4.
        lia.
        rewrite <- H5.
        apply (H0 y).
    intro.
    destruct H3.
    exists (first_nat p x).
    constructor.
    apply (H x H3).
    intros i.
    intro.
    assert (first_nat p x <= i).
      apply (H2 x i H4).
    lia.
  Qed.

End ETC.


Require Export Relations Morphisms.

Require Import List.
Import ListNotations.

Set Primitive Projections.
Set Implicit Arguments.

Local Notation negate P := (fun x => ~P x).
Local Notation conjoin P Q := (fun x => P x /\ Q x).
Local Notation disjoin P Q := (fun x => P x \/ Q x).
Local Notation const x := (fun _ => x).
Local Notation "f ∘ g" := (fun x => f (g x)) (at level 30).

Module set.
  Section Basics.

    Variable V : Type.

    Record t := of { spec : (V -> Prop) }.

    Implicit Type a b c x y z : V.
    Implicit Type A B C X Y Z : t.

    Inductive elem x A : Prop := elem_ext : A.(spec) x -> elem x A.

    Definition eq A B := forall x, elem x A <-> elem x B.

    Definition subset A B := forall x, elem x A -> elem x B.

    Property eq_refl : Reflexive eq.
    Proof.
      unfold eq; intros A x.
      reflexivity.
    Qed.

    Property eq_sym : Symmetric eq.
    Proof.
      unfold eq; intros A B H1 x.
      specialize (H1 x).
      symmetry; assumption.
    Qed.

    Property eq_trans : Transitive eq.
    Proof.
      unfold  eq; intros A B C H1 H2 x.
      specialize (H1 x); specialize (H2 x).
      etransitivity; eassumption.
    Qed.

    Property subset_refl : Reflexive subset.
    Proof. cbv; auto. Qed.

    Property subset_trans : Transitive subset.
    Proof. cbv; auto. Qed.

    Global Add Relation t eq
      reflexivity proved by eq_refl
      symmetry proved by eq_sym
      transitivity proved by eq_trans
    as eq_rel.

    Global Add Relation t subset
      reflexivity proved by subset_refl
      transitivity proved by subset_trans
    as subset_rel.

    Property eq_subset A B : eq A B <-> subset A B /\ subset B A.
    Proof. cbv; do 2 split; apply H. Qed.

    Global Add Morphism elem : elem_morphism.
    Proof. intros x ? ? ?; revert x; assumption. Qed.

    Global Add Morphism subset : subset_morphism.
    Proof.
      now_show (Proper (eq ==> eq ==> iff) subset).
      unfold subset; solve_proper.
    Qed.

    Definition empty := of (fun x => False).

    Definition full := of (fun x => True).

    Definition union A B := of (disjoin A.(spec) B.(spec)).

    Definition intersection A B := of (conjoin A.(spec) B.(spec)).

    Definition complement A := of (negate A.(spec)).

  End Basics.

End set.

Notation set := set.t.

Declare Scope set_scope.
Bind Scope set_scope with set.
Delimit Scope set_scope with set.

Notation "x ∈ A" := (set.elem x A) (at level 70, right associativity) : set_scope.
Notation "x ∉ A" := (~set.elem x A) (at level 70, right associativity) : set_scope.
Notation "A ∋ x" := (set.elem x A) (at level 71, left associativity, only parsing) : set_scope.
Notation "A ∌ x" := (~set.elem x A) (at level 71, left associativity, only parsing) : set_scope.
Notation "A ⊆ B" := (set.subset A B) (at level 70, right associativity) : set_scope.
Notation "A ⊈ B" := (~set.subset A B) (at level 70, right associativity) : set_scope.
Notation "B ⊇ A" := (set.subset A B) (at level 71, left associativity, only parsing) : set_scope.
Notation "B ⊉ A" := (~set.subset A B) (at level 71, left associativity, only parsing) : set_scope.
Notation "A == B" := (set.eq A B) (at level 70, no associativity) : set_scope.
Notation "A =/= B" := (~set.eq A B) (at level 70, no associativity) : set_scope.
Notation "∅" := (set.empty _) : set_scope.
Notation "[ X ]" := (set.full X) : set_scope.
Notation "A ∪ B" := (set.union A B) (at level 50, left associativity) : set_scope.
Notation "A ∩ B" := (set.intersection A B) (at level 40, left associativity) : set_scope.
Notation "- A" := (set.complement A) : set_scope.


Add LoadPath "D:\sfsol".
Require Export Types.

Module STLC.

Inductive ty : Type :=
  | TBool : ty
  | TArrow : ty -> ty -> ty.

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "ttrue"
  | Case_aux c "tfalse" | Case_aux c "tif" ].

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Notation idB :=
  (tabs x TBool (tvar x)).

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if eq_id_dec x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if eq_id_dec x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

Inductive substi (s:tm) (x:id) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  | s_var2 : forall y, y<>x ->
      substi s x (tvar y) (tvar y)
  | s_tabs1 : forall t T,
      substi s x (tabs x T t) (tabs x T t)
  | s_tabs2 : forall y t T t', y<>x -> substi s x t t' ->
      substi s x (tabs y T t) (tabs y T t')
  | s_app : forall t1 t2 t1' t2', (substi s x t1 t1')->(substi s x t2 t2')->
      substi s x (tapp t1 t2) (tapp t1' t2')
  | s_true : substi s x ttrue ttrue
  | s_false : substi s x tfalse tfalse
  | s_tif : forall t1 t2 t3 t1' t2' t3', (substi s x t1 t1')->
      (substi s x t2 t2')->(substi s x t3 t3')->
      substi s x (tif t1 t2 t3) (tif t1' t2' t3').

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
  split; intros. generalize dependent t'.
    induction t; intros; simpl in H; subst; eauto 10;
      try destruct (eq_id_dec x0 i); subst;eauto.
    induction H; simpl; subst; try rewrite eq_id; eauto; try rewrite neq_id; eauto.
  Qed.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1 t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2" | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse" | Case_aux c "ST_If" ].

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl. Qed.

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl. Qed.

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl. Qed.

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_IfTrue.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl. Qed.

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize. Qed.

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  normalize.
Qed.

Lemma step_example3' :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof. normalize. Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof. normalize. Qed.

Lemma step_example5 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  eapply multi_step. eapply ST_App1. eapply ST_AppAbs. eauto.
  simpl. eapply multi_step. eapply ST_AppAbs. eauto. simpl.
  apply multi_refl. Qed.

Lemma step_example5' :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof. normalize. Qed.

Module PartialMap.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Definition extend {A:Type} (Γ : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Γ x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

End PartialMap.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      extend Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs"
  | Case_aux c "T_App" | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If" ].

Hint Constructors has_type.

Example typing_example_1 :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity. Qed.

Example typing_example_1' :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof. auto. Qed.

Example typing_example_2 :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using extend_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

Example typing_example_2_full :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  apply T_Abs.
  apply T_Abs.
  apply T_App with (TBool). apply T_Var. apply extend_eq.
  apply T_App with (TBool). apply T_Var. apply extend_eq.
  apply T_Var. apply extend_neq. destruct (eq_id_dec y x). inversion e. assumption.
  Qed.

Example typing_example_3 :
  exists T,
    empty |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto.
  exists (TArrow (TArrow TBool TBool) (TArrow (TArrow TBool TBool) (TArrow TBool TBool))).
  apply T_Abs.
  apply T_Abs.
  apply T_Abs.
  apply T_App with (TBool). apply T_Var...
  apply T_App with (TBool). apply T_Var...
  apply T_Var...
  Qed.

Example typing_nonexample_1 :
  ~ exists T,
      empty |-
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y)))) \in
        T.
Proof.
  intros Hc. inversion Hc.
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  inversion H1. Qed.

Lemma TarrowUneq : forall T1 T2,
  ~ (TArrow T1 T2 = T1).
Proof.
  induction T1; intros T2 contra; inversion contra.
  eapply IHT1_1. apply H0.
  Qed.

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |-
          (tabs x S
             (tapp (tvar x) (tvar x))) \in
          T).
Proof.
  intros Hc. inversion Hc. inversion H.
  inv H0. inv H6. inv H3. inv H2.
  inv H5. inversion H2.
  eapply TarrowUneq. apply H1.
  Qed.

End STLC.