(** * StlcProp: Properties of STLC *)

Require Import Maps.
Require Import Types.
Require Import Stlc.
Require Import Smallstep.
Module STLCProp.
Import STLC.

(** In this chapter, we develop the fundamental theory of the Simply
    Typed Lambda Calculus -- in particular, the type safety
    theorem. *)

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

(** As we saw for the simple calculus in the [Types] chapter, the
    first step in establishing basic properties of reduction and types
    is to identify the possible _canonical forms_ (i.e., well-typed
    closed values) belonging to each type.  For [Bool], these are the boolean
    values [ttrue] and [tfalse].  For arrow types, the canonical forms
    are lambda-abstractions.  *)

Lemma canonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma canonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x0. exists t0.  auto.
Qed.

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

(** As before, the _progress_ theorem tells us that closed, well-typed
    terms are not stuck: either a well-typed term is a value, or it
    can take a reduction step.  The proof is a relatively
    straightforward extension of the progress proof we saw in the
    [Types] chapter.  We'll give the proof in English first, then the
    formal version. *)

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

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

    - The last rule of the derivation cannot be [T_Var], since a
      variable is never well typed in an empty context.

    - The [T_True], [T_False], and [T_Abs] cases are trivial, since in
      each of these cases we can see by inspecting the rule that [t]
      is a value.

    - If the last rule of the derivation is [T_App], then [t] has the
      form [t1 t2] for som e[t1] and [t2], where we know that [t1] and
      [t2] are also well typed in the empty context; in particular,
      there exists a type [T2] such that [|- t1 \in T2 -> T] and [|-
      t2 \in T2].  By the induction hypothesis, either [t1] is a value
      or it can take a reduction step.

        - If [t1] is a value, then consider [t2], which by the other
          induction hypothesis must also either be a value or take a step.

            - Suppose [t2] is a value.  Since [t1] is a value with an
              arrow type, it must be a lambda abstraction; hence [t1
              t2] can take a step by [ST_AppAbs].

            - Otherwise, [t2] can take a step, and hence so can [t1
              t2] by [ST_App2].

        - If [t1] can take a step, then so can [t1 t2] by [ST_App1].

    - If the last rule of the derivation is [T_If], then [t = if t1
      then t2 else t3], where [t1] has type [Bool].  By the IH, [t1]
      either is a value or takes a step.

        - If [t1] is a value, then since it has type [Bool] it must be
          either [true] or [false].  If it is [true], then [t] steps
          to [t2]; otherwise it steps to [t3].

        - Otherwise, [t1] takes a step, and therefore so does [t] (by
          [ST_If]). *)

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  - (* T_Var *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  - (* T_App *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    + (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply canonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    + (* t1 steps *)
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  - (* T_If *)
    right. destruct IHHt1...

    + (* t1 is a value *)
      destruct (canonical_forms_bool t1); subst; eauto.

    + (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.

(** **** Exercise: 3 stars, optional (progress_from_term_ind)  *)
(** Show that progress can also be proved by induction on terms
    instead of induction on typing derivations. *)

Theorem progress' : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  induction t; intros T Ht; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

(** The other half of the type soundness property is the preservation
    of types during reduction.  For this, we need to develop some
    technical machinery for reasoning about variables and
    substitution.  Working from top to bottom (from the high-level
    property we are actually interested in to the lowest-level
    technical lemmas that are needed by various cases of the more
    interesting proofs), the story goes like this:

      - The _preservation theorem_ is proved by induction on a typing
        derivation, pretty much as we did in the [Types] chapter.  The
        one case that is significantly different is the one for the
        [ST_AppAbs] rule, whose definition uses the substitution
        operation.  To see that this step preserves typing, we need to
        know that the substitution itself does.  So we prove a...

      - _substitution lemma_, stating that substituting a (closed)
        term [s] for a variable [x] in a term [t] preserves the type
        of [t].  The proof goes by induction on the form of [t] and
        requires looking at all the different cases in the definition
        of substitition.  This time, the tricky cases are the ones for
        variables and for function abstractions.  In both cases, we
        discover that we need to take a term [s] that has been shown
        to be well-typed in some context [Gamma] and consider the same
        term [s] in a slightly different context [Gamma'].  For this
        we prove a...

      - _context invariance_ lemma, showing that typing is preserved
        under "inessential changes" to the context [Gamma] -- in
        particular, changes that do not affect any of the free
        variables of the term.  And finally, for this, we need a
        careful definition of...

      - the _free variables_ of a term -- i.e., those variables
        mentioned in a term and not in the scope of an enclosing
        function abstraction binding a variable of the same name.

   To make Coq happy, we need to formalize the story in the opposite
   order... *)

(* ================================================================= *)
(** ** Free Occurrences *)

(** A variable [x] _appears free in_ a term _t_ if [t] contains some
    occurrence of [x] that is not under an abstraction labeled [x].
    For example:
      - [y] appears free, but [x] does not, in [\x:T->U. x y]
      - both [x] and [y] appear free in [(\x:T->U. x y) x]
      - no variables appear free in [\x:T->U. \y:T. x y]

    Formally: *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif t1 t2 t3).

Hint Constructors appears_free_in.

(** A term in which no variables appear free is said to be _closed_. *)

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

(** **** Exercise: 1 star (afi)  *)
(** If the definition of [appears_free_in] is not crystal clear to
    you, it is a good idea to take a piece of paper and write out the
    rules in informal inference-rule notation.  (Although it is a
    rather low-level, technical definition, understanding it is
    crucial to understanding substitution and its properties, which
    are really the crux of the lambda-calculus.) *)
(** [] *)

(* ================================================================= *)
(** ** Substitution *)

(** To prove that substitution preserves typing, we first need a
    technical lemma connecting free variables and typing contexts: If
    a variable [x] appears free in a term [t], and if we know [t] is
    well typed in context [Gamma], then it must be the case that
    [Gamma] assigns a type to [x]. *)

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.

(** _Proof_: We show, by induction on the proof that [x] appears
      free in [t], that, for all contexts [Gamma], if [t] is well
      typed under [Gamma], then [Gamma] assigns some type to [x].

      - If the last rule used was [afi_var], then [t = x], and from
        the assumption that [t] is well typed under [Gamma] we have
        immediately that [Gamma] assigns a type to [x].

      - If the last rule used was [afi_app1], then [t = t1 t2] and [x]
        appears free in [t1].  Since [t] is well typed under [Gamma],
        we can see from the typing rules that [t1] must also be, and
        the IH then tells us that [Gamma] assigns [x] a type.

      - Almost all the other cases are similar: [x] appears free in a
        subterm of [t], and since [t] is well typed under [Gamma], we
        know the subterm of [t] in which [x] appears is well typed
        under [Gamma] as well, and the IH gives us exactly the
        conclusion we want.

      - The only remaining case is [afi_abs].  In this case [t =
        \y:T11.t12], and [x] appears free in [t12]; we also know that
        [x] is different from [y].  The difference from the previous
        cases is that whereas [t] is well typed under [Gamma], its
        body [t12] is well typed under [(Gamma, y:T11)], so the IH
        allows us to conclude that [x] is assigned some type by the
        extended context [(Gamma, y:T11)].  To conclude that [Gamma]
        assigns a type to [x], we appeal to lemma [update_neq], noting
        that [x] and [y] are different variables. *)

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  induction H;
         intros; try solve [inversion H0; eauto].
  - (* afi_abs *)
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite update_neq in H7; assumption.
Qed.

(** Next, we'll need the fact that any term [t] which is well typed in
    the empty context is closed (it has no free variables). *)

(** **** Exercise: 2 stars, optional (typable_empty__closed)  *)
Corollary typable_empty__closed : forall t T,
    empty |- t \in T  ->
    closed t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Sometimes, when we have a proof [Gamma |- t : T], we will need to
    replace [Gamma] by a different context [Gamma'].  When is it safe
    to do this?  Intuitively, it must at least be the case that
    [Gamma'] assigns the same types as [Gamma] to all the variables
    that appear free in [t]. In fact, this is the only condition that
    is needed. *)

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.

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

      - If the last rule in the derivation was [T_Var], then [t = x]
        and [Gamma x = T].  By assumption, [Gamma' x = T] as well, and
        hence [Gamma' |- t \in T] by [T_Var].

      - If the last rule was [T_Abs], then [t = \y:T11. t12], with [T
        = T11 -> T12] and [Gamma, y:T11 |- t12 \in T12].  The
        induction hypothesis is that, for any context [Gamma''], if
        [Gamma, y:T11] and [Gamma''] assign the same types to all the
        free variables in [t12], then [t12] has type [T12] under
        [Gamma''].  Let [Gamma'] be a context which agrees with
        [Gamma] on the free variables in [t]; we must show [Gamma' |-
        \y:T11. t12 \in T11 -> T12].

        By [T_Abs], it suffices to show that [Gamma', y:T11 |- t12 \in
        T12].  By the IH (setting [Gamma'' = Gamma', y:T11]), it
        suffices to show that [Gamma, y:T11] and [Gamma', y:T11] agree
        on all the variables that appear free in [t12].

        Any variable occurring free in [t12] must be either [y] or
        some other variable.  [Gamma, y:T11] and [Gamma', y:T11]
        clearly agree on [y].  Otherwise, note that any variable other
        than [y] that occurs free in [t12] also occurs free in [t =
        \y:T11. t12], and by assumption [Gamma] and [Gamma'] agree on
        all such variables; hence so do [Gamma, y:T11] and [Gamma',
        y:T11].

      - If the last rule was [T_App], then [t = t1 t2], with [Gamma |-
        t1 \in T2 -> T] and [Gamma |- t2 \in T2].  One induction
        hypothesis states that for all contexts [Gamma'], if [Gamma']
        agrees with [Gamma] on the free variables in [t1], then [t1]
        has type [T2 -> T] under [Gamma']; there is a similar IH for
        [t2].  We must show that [t1 t2] also has type [T] under
        [Gamma'], given the assumption that [Gamma'] agrees with
        [Gamma] on all the free variables in [t1 t2].  By [T_App], it
        suffices to show that [t1] and [t2] each have the same type
        under [Gamma'] as under [Gamma].  But all free variables in
        [t1] are also free in [t1 t2], and similarly for [t2]; hence
        the desired result follows from the induction hypotheses. *)

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  induction H; intros; auto.
  - (* T_Var *)
    apply T_Var. rewrite <- H0...
  - (* T_Abs *)
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [update Gamma x T11] *)
    unfold update. unfold t_update. destruct (beq_id x0 x1) eqn: Hx0x1...
    rewrite beq_id_false_iff in Hx0x1. auto.
  - (* T_App *)
    apply T_App with T11...
Qed.

(** Now we come to the conceptual heart of the proof that reduction
    preserves types -- namely, the observation that _substitution_
    preserves types.

    Formally, the so-called _Substitution Lemma_ says this: Suppose we
    have a term [t] with a free variable [x], and suppose we've been
    able to assign a type [T] to [t] under the assumption that [x] has
    some type [U].  Also, suppose that we have some other term [v] and
    that we've shown that [v] has type [U].  Then, since [v] satisfies
    the assumption we made about [x] when typing [t], we should be
    able to substitute [v] for each of the occurrences of [x] in [t]
    and obtain a new term that still has type [T]. *)

(** _Lemma_: If [Gamma,x:U |- t \in T] and [|- v \in U], then [Gamma |-
    [x:=v]t \in T]. *)

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     update Gamma x U |- t \in T ->
     empty |- v \in U   ->
     Gamma |- [x:=v]t \in T.

(** One technical subtlety in the statement of the lemma is that
    we assign [v] the type [U] in the _empty_ context -- in other
    words, we assume [v] is closed.  This assumption considerably
    simplifies the [T_Abs] case of the proof (compared to assuming
    [Gamma |- v \in U], which would be the other reasonable assumption
    at this point) because the context invariance lemma then tells us
    that [v] has type [U] in any context at all -- we don't have to
    worry about free variables in [v] clashing with the variable being
    introduced into the context by [T_Abs].

    The substitution lemma can be viewed as a kind of "commutation"
    property.  Intuitively, it says that substitution and typing can
    be done in either order: we can either assign types to the terms
    [t] and [v] separately (under suitable contexts) and then combine
    them using substitution, or we can substitute first and then
    assign a type to [ [x:=v] t ] -- the result is the same either
    way.

    _Proof_: We show, by induction on [t], that for all [T] and
    [Gamma], if [Gamma,x:U |- t \in T] and [|- v \in U], then [Gamma
    |- [x:=v]t \in T].

      - If [t] is a variable there are two cases to consider,
        depending on whether [t] is [x] or some other variable.

          - If [t = x], then from the fact that [Gamma, x:U |- x \in
            T] we conclude that [U = T].  We must show that [[x:=v]x =
            v] has type [T] under [Gamma], given the assumption that
            [v] has type [U = T] under the empty context.  This
            follows from context invariance: if a closed term has type
            [T] in the empty context, it has that type in any context.

          - If [t] is some variable [y] that is not equal to [x], then
            we need only note that [y] has the same type under [Gamma,
            x:U] as under [Gamma].

      - If [t] is an abstraction [\y:T11. t12], then the IH tells us,
        for all [Gamma'] and [T'], that if [Gamma',x:U |- t12 \in T']
        and [|- v \in U], then [Gamma' |- [x:=v]t12 \in T'].

        The substitution in the conclusion behaves differently
        depending on whether [x] and [y] are the same variable.

        First, suppose [x = y].  Then, by the definition of
        substitution, [[x:=v]t = t], so we just need to show [Gamma |-
        t \in T].  But we know [Gamma,x:U |- t : T], and, since [y]
        does not appear free in [\y:T11. t12], the context invariance
        lemma yields [Gamma |- t \in T].

        Second, suppose [x <> y].  We know [Gamma,x:U,y:T11 |- t12 \in
        T12] by inversion of the typing relation, from which
        [Gamma,y:T11,x:U |- t12 \in T12] follows by the context
        invariance lemma, so the IH applies, giving us [Gamma,y:T11 |-
        [x:=v]t12 \in T12].  By [T_Abs], [Gamma |- \y:T11. [x:=v]t12
        \in T11->T12], and by the definition of substitution (noting
        that [x <> y]), [Gamma |- \y:T11. [x:=v]t12 \in T11->T12] as
        required.

      - If [t] is an application [t1 t2], the result follows
        straightforwardly from the definition of substitution and the
        induction hypotheses.

      - The remaining cases are similar to the application case.

    One more technical note: This proof is a rare case where an
    induction on terms, rather than typing derivations, yields a
    simpler argument.  The reason for this is that the assumption
    [update Gamma x U |- t \in T] is not completely generic, in the
    sense that one of the "slots" in the typing relation -- namely the
    context -- is not just a variable, and this means that Coq's
    native induction tactic does not give us the induction hypothesis
    that we want.  It is possible to work around this, but the needed
    generalization is a little tricky.  The term [t], on the other
    hand, _is_ completely generic. *)

Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  induction t; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  - (* tvar *)
    rename i into y. destruct (beq_idP x y) as [Hxy|Hxy].
    + (* x=y *)
      subst.
      rewrite update_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      apply T_Var. rewrite update_neq in H2...
  - (* tabs *)
    rename i into y. apply T_Abs.
    destruct (beq_idP x y) as [Hxy | Hxy].
    + (* x=y *)
      subst.
      eapply context_invariance...
      intros x Hafi. unfold update, t_update.
      destruct (beq_id y x) eqn: Hyx...
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_idP y z) as [Hyz | Hyz]; subst; trivial.
      rewrite <- beq_id_false_iff in Hxy.
      rewrite Hxy...
Qed.

(* ================================================================= *)
(** ** Main Theorem *)

(** We now have the tools we need to prove preservation: if a closed
    term [t] has type [T] and takes a step to [t'], then [t']
    is also a closed term with type [T].  In other words, the small-step
    reduction relation preserves types. *)

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

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

    - We can immediately rule out [T_Var], [T_Abs], [T_True], and
      [T_False] as the final rules in the derivation, since in each of
      these cases [t] cannot take a step.

    - If the last rule in the derivation was [T_App], then [t = t1
      t2].  There are three cases to consider, one for each rule that
      could have been used to show that [t1 t2] takes a step to [t'].

        - If [t1 t2] takes a step by [ST_App1], with [t1] stepping to
          [t1'], then by the IH [t1'] has the same type as [t1], and
          hence [t1' t2] has the same type as [t1 t2].

        - The [ST_App2] case is similar.

        - If [t1 t2] takes a step by [ST_AppAbs], then [t1 =
          \x:T11.t12] and [t1 t2] steps to [[x:=t2]t12]; the
          desired result now follows from the fact that substitution
          preserves types.

    - If the last rule in the derivation was [T_If], then [t = if t1
      then t2 else t3], and there are again three cases depending on
      how [t] steps.

        - If [t] steps to [t2] or [t3], the result is immediate, since
          [t2] and [t3] have the same type as [t].

        - Otherwise, [t] steps by [ST_If], and the desired conclusion
          follows directly from the induction hypothesis. *)

Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  induction HT;
       intros t' HE; subst Gamma; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

(** **** Exercise: 2 stars, recommended (subject_expansion_stlc)  *)
(** An exercise in the [Types] chapter asked about the subject
    expansion property for the simple language of arithmetic and
    boolean expressions.  Does this property hold for STLC?  That is,
    is it always the case that, if [t ==> t'] and [has_type t' T],
    then [empty |- t \in T]?  If so, prove it.  If not, give a
    counter-example not involving conditionals.

(* FILL IN HERE *)
[]
*)

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

(** **** Exercise: 2 stars, optional (type_soundness)  *)
(** Put progress and preservation together and show that a well-typed
    term can _never_ reach a stuck state.  *)

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

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Uniqueness of Types *)

(** **** Exercise: 3 stars (types_unique)  *)
(** Another nice property of the STLC is that types are unique: a
    given term (in a given context) has at most one type. *)
(** Formalize this statement and prove it. *)

(* FILL IN HERE *)
(** [] *)

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

(** **** Exercise: 1 star (progress_preservation_statement)  *)
(** Without peeking at their statements above, write down the progress
    and preservation theorems for the simply typed lambda-calculus. *)
(** [] *)

(** **** Exercise: 2 stars (stlc_variation1)  *)
(** Suppose we add a new term [zap] with the following reduction rule

                         ---------                  (ST_Zap)
                         t ==> zap

and the following typing rule:

                      ----------------               (T_Zap)
                      Gamma |- zap : T

    Which of the following properties of the STLC remain true in
    the presence of these rules?  For each property, write either
    "remains true" or "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation2)  *)
(** Suppose instead that we add a new term [foo] with the following
    reduction rules:

                       -----------------                (ST_Foo1)
                       (\x:A. x) ==> foo

                         ------------                   (ST_Foo2)
                         foo ==> true

    Which of the following properties of the STLC 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]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation3)  *)
(** Suppose instead that we remove the rule [ST_App1] from the [step]
    relation. Which of the following properties of the STLC 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]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars, optional (stlc_variation4)  *)
(** Suppose instead that we add the following new rule to the
    reduction relation:

            ----------------------------------        (ST_FunnyIfTrue)
            (if true then t1 else t2) ==> true

    Which of the following properties of the STLC 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]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation5)  *)
(** Suppose instead that we add the following new rule to the typing
    relation:

                 Gamma |- t1 \in Bool->Bool->Bool
                     Gamma |- t2 \in Bool
                 ------------------------------          (T_FunnyApp)
                    Gamma |- t1 t2 \in Bool

    Which of the following properties of the STLC 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]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation6)  *)
(** Suppose instead that we add the following new rule to the typing
    relation:

                     Gamma |- t1 \in Bool
                     Gamma |- t2 \in Bool
                    ---------------------               (T_FunnyApp')
                    Gamma |- t1 t2 \in Bool

    Which of the following properties of the STLC 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]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation7)  *)
(** Suppose we add the following new rule to the typing relation
    of the STLC:

                         ------------------- (T_FunnyAbs)
                         |- \x:Bool.t \in Bool

    Which of the following properties of the STLC 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]

      - Progress

      - Preservation

[]
*)

End STLCProp.

(* ================================================================= *)
(** ** Exercise: STLC with Arithmetic *)

(** To see how the STLC might function as the core of a real
    programming language, let's extend it with a concrete base
    type of numbers and some constants and primitive
    operators. *)

Module STLCArith.

(** To types, we add a base type of natural numbers (and remove
    booleans, for brevity). *)

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

(** To terms, we add natural number constants, along with
    successor, predecessor, multiplication, and zero-testing. *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tnat  : nat -> tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tmult : tm -> tm -> tm
  | tif0  : tm -> tm -> tm -> tm.

(** **** Exercise: 4 stars (stlc_arith)  *)
(** Finish formalizing the definition and properties of the STLC extended
    with arithmetic.  Specifically:

    - Copy the whole development of STLC that we went through above (from
      the definition of values through the Type Soundness theorem), and
      paste it into the file at this point.

    - Extend the definitions of the [subst] operation and the [step]
      relation to include appropriate clauses for the arithmetic operators.

    - Extend the proofs of all the properties (up to [soundness]) of
      the original STLC to deal with the new syntactic forms.  Make
      sure Coq accepts the whole file. *)

(* FILL IN HERE *)
(** [] *)

End STLCArith.

(** $Date: 2016-07-13 12:41:41 -0400 (Wed, 13 Jul 2016) $ *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable eF_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_3_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable cR_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defparallelogram_1 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_2 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable lemma_parallelNC_3 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Variable lemma_NCdistinct_4 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable proposition_34_5 : (forall A B C D : Universe, (pG_ A C D B -> (cong_ A B C D /\ (cong_ A C B D /\ (congA_ C A B B D C /\ (congA_ A B D D C A /\ cong_3_ C A B B D C)))))).
Variable lemma_congruencesymmetric_6 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruencetransitive_7 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable lemma_parallelsymmetric_8 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).
Variable lemma_collinearparallel2_9 : (forall A B C D E F : Universe, ((par_ A B C D /\ (col_ C D E /\ (col_ C D F /\ E <> F))) -> par_ A B E F)).
Variable lemma_crisscross_10 : (forall A B C D : Universe, ((par_ A C B D /\ ~(cR_ A B C D)) -> cR_ A D B C)).
Variable defcross_11 : (forall A B C D : Universe, (exists X : Universe, (cR_ A B C D -> (betS_ A X B /\ betS_ C X D)))).
Variable defcross2_12 : (forall A B C D X : Universe, ((betS_ A X B /\ betS_ C X D) -> cR_ A B C D)).
Variable axiom_betweennesssymmetry_13 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable proposition_33_14 : (forall A B C D M : Universe, ((par_ A B C D /\ (cong_ A B C D /\ (betS_ A M D /\ betS_ B M C))) -> (par_ A C B D /\ cong_ A C B D))).
Variable lemma_parallelflip_15 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable proposition_35_16 : (forall A B C D E F : Universe, ((pG_ A B C D /\ (pG_ E B C F /\ (col_ A D E /\ col_ A D F))) -> eF_ A B C D E B C F)).
Variable lemma_collinear4_17 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_collinearorder_18 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_inequalitysymmetric_19 : (forall A B : Universe, (A <> B -> B <> A)).
Variable axiom_EFpermutation_20 : (forall A B C D Ca Cb Cc Cd : Universe, (eF_ A B C D Ca Cb Cc Cd -> (eF_ A B C D Cb Cc Cd Ca /\ (eF_ A B C D Cd Cc Cb Ca /\ (eF_ A B C D Cc Cd Ca Cb /\ (eF_ A B C D Cb Ca Cd Cc /\ (eF_ A B C D Cd Ca Cb Cc /\ (eF_ A B C D Cc Cb Ca Cd /\ eF_ A B C D Ca Cd Cc Cb)))))))).
Variable axiom_EFsymmetric_21 : (forall A B C D Ca Cb Cc Cd : Universe, (eF_ A B C D Ca Cb Cc Cd -> eF_ Ca Cb Cc Cd A B C D)).
Variable axiom_EFtransitive_22 : (forall A B C D P Q R S Ca Cb Cc Cd : Universe, ((eF_ A B C D Ca Cb Cc Cd /\ eF_ Ca Cb Cc Cd P Q R S) -> eF_ A B C D P Q R S)).
Variable lemma_congruenceflip_23 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).

Theorem proposition_36_24 : (forall A B C D E F G H : Universe, ((pG_ A B C D /\ (pG_ E F G H /\ (col_ A D E /\ (col_ A D H /\ (col_ B C F /\ (col_ B C G /\ cong_ B C F G)))))) -> eF_ A B C D E F G H)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** Examples.Add : A Von Neumann adder.  *)
Require Import Common Core Front ZArith.

Fixpoint pow2 k := (match k with O => 1 | S p => pow2 p + pow2 p end)%nat.

Notation "[2^ n ]" := (pow2 n).

(** A divide and conquer adder (Von Neumann)  *)
Section s.

  Variable V : type -> Type.
  Open Scope Z_scope.
  Fixpoint add {Phi} n (x : expr V (Tint [2^ n])) (y : expr V (Tint [2^ n]))
    :        action Phi V (Ttuple [Tbool; Tbool; Tint [2^ n]; Tint [2^ n]]) :=
    match n
       return
       expr V (Tint [2^ n]) ->
       expr V (Tint [2^ n]) ->
       action Phi V (Ttuple [Tbool; Tbool; Tint [2^ n]; Tint [2^ n]])
    with
      | 0%nat => fun x y =>
                ret [tuple ((x = #i 1) || (y = #i 1)), (* propagate *)
                     ((x = #i 1) && (y = #i 1)),       (* generate *)
                     x + y,                            (* s *)
                     x + y + #i 1 ]%expr               (* t *)
      | S n => fun x y =>
                (
                  do xL <~ low  x;
                  do xH <~ high x;
                  do yL <~ low  y;
                  do yH <~ high y;
                  do rL <- add n xL yL;
                  do rH <- add n xH yH;
                  do (pL, gL, sL, tL) <~ rL;
                  do (pH, gH, sH, tH) <~ rH;
                  do sH' <~ (Emux (gL) (tH) (sH))%expr;
                  do tH' <~ (Emux (pL) (tH) (sH))%expr;
                  do pH' <~ (gH || (pH && pL))%expr;
                  do gH' <~ (gH || (pH && gL))%expr;
                  ret [tuple pH',
                       gH',
                       combineLH sL sH',
                       combineLH tL tH']
                )
          end%expr%action x y.
End s.

Arguments Front.Close {Var} Phi {T U} c.

Definition generator n : Action ([Tinput (Tint [2^n]); Tinput (Tint [2^n])]%list) (Ttuple [ B; B; Int [2^n]; Int [2^n]])%list.
  intros V.
  apply (Front.Close ([Tinput (Tint [2^n])]%list)).
  intros x.
  apply (Front.Close ([]%list)).
  intros y.
  apply (add _ _ (Evar x) (Evar y)) .
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_rightangleNC_1 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable lemma_NCdistinct_2 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable lemma_collinearorder_3 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_8_2_4 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Variable lemma_collinearright_5 : (forall A B C D : Universe, ((per_ A B D /\ (col_ A B C /\ C <> B)) -> per_ C B D)).
Variable lemma_8_7_6 : (forall A B C : Universe, (per_ C B A -> ~(per_ A C B))).
Variable lemma_collinear4_7 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_inequalitysymmetric_8 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_legsmallerhypotenuse_9 : (forall A B C : Universe, (per_ A B C -> (lt_ A B A C /\ lt_ B C A C))).
Variable cn_equalityreverse_10 : (forall A B : Universe, cong_ A B B A).
Variable lemma_lessthancongruence2_11 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ A B E F) -> lt_ E F C D)).
Variable lemma_lessthantransitive_12 : (forall A B C D E F : Universe, ((lt_ A B C D /\ lt_ C D E F) -> lt_ A B E F)).
Variable axiom_betweennesssymmetry_13 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable cn_congruencereflexive_14 : (forall A B : Universe, cong_ A B A B).
Variable deflessthan_15 : (forall A B C D : Universe, (exists X : Universe, (lt_ A B C D -> (betS_ C X D /\ cong_ C X A B)))).
Variable deflessthan2_16 : (forall A B C D X : Universe, ((betS_ C X D /\ cong_ C X A B) -> lt_ A B C D)).
Variable lemma_trichotomy2_17 : (forall A B C D : Universe, (lt_ A B C D -> ~(lt_ C D A B))).
Variable defcollinear_18 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_19 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_20 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_21 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_22 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_23 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_24 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_ray4_1_25 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_26 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_27 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_ray5_28 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_tworays_29 : (forall A B C : Universe, ((out_ A B C /\ out_ B A C) -> betS_ A C B)).

Theorem lemma_altitudeofrighttriangle_30 : (forall A B C M Xp : Universe, ((per_ B A C /\ (per_ A M Xp /\ (col_ B C Xp /\ col_ B C M))) -> betS_ B M C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Lists.List.
Require Import Coq.Program.Basics.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Setoids.Setoid.
Require Import DschingisKhan.Prelude.PreludeInit.
Require Import DschingisKhan.Prelude.PreludeMath.
Require Import DschingisKhan.Math.BasicPosetTheory.

Module BasicGeneralTopology.

  Import MathProps MathClasses BasicPosetTheory.

  Create HintDb topology_hints.

  Class Topology_axiom {A : Type} (isOpen : ensemble A -> Prop) : Prop :=
    { full_isOpen
      : isOpen full
    ; unions_isOpen (Xs : ensemble (ensemble A))
      (every_member_of_Xs_isOpen : forall X : ensemble A, << X_in_Xs : member X Xs >> -> isOpen X)
      : isOpen (unions Xs)
    ; intersection_isOpen (XL : ensemble A) (XR : ensemble A)
      (XL_isOpen : isOpen XL)
      (XR_isOpen : isOpen XR)
      : isOpen (intersection XL XR)
    ; isOpen_compatWith_eqProp (X : ensemble A) (X' : ensemble A)
      (X_isOpen : isOpen X)
      (X_eq_X' : X == X')
      : isOpen X'
    }
  .

  Class isTopologicalSpace (A : Type) : Type :=
    { isOpen (O : ensemble A) : Prop
    ; TopologicalSpace_obeysTopology_axiom :> Topology_axiom isOpen
    }
  .

  Global Add Parametric Morphism {A : Type} (requiresTopology : isTopologicalSpace A) :
    (isOpen (isTopologicalSpace := requiresTopology)) with signature (eqProp ==> iff)
    as eqProp_lifts_isOpen.
  Proof. iis; ii; eapply isOpen_compatWith_eqProp; eauto with *. Qed.

  Lemma fullOpen {A : Type} {requiresTopology : isTopologicalSpace A}
    : isOpen (@full A).
  Proof. eapply full_isOpen; eauto. Qed.

  Lemma unionsOpen {A : Type} {requiresTopology : isTopologicalSpace A} (Os : ensemble (ensemble A))
    (every_member_of_Os_isOpen : forall O : ensemble A, member O Os -> isOpen O)
    : isOpen (@unions A Os).
  Proof. eapply unions_isOpen; eauto. Qed.

  Lemma intersectionOpen {A : Type} {requiresTopology : isTopologicalSpace A} (O1 : ensemble A) (O2 : ensemble A)
    (O1_isOpen : isOpen O1)
    (O2_isOpen : isOpen O2)
    : isOpen (@intersection A O1 O2).
  Proof. eapply intersection_isOpen; eauto. Qed.

  Lemma emptyOpen {A : Type} {requiresTopology : isTopologicalSpace A}
    : isOpen (@empty A).
  Proof.
    eapply isOpen_compatWith_eqProp.
    - eapply unions_isOpen with (Xs := empty). ii; desnw.
      apply in_empty_iff in X_in_Xs. tauto.
    - intros z. rewrite in_unions_iff. split.
      + intros [X [z_in_X []]].
      + intros [].
  Qed.

  Global Hint Resolve fullOpen unionsOpen intersectionOpen emptyOpen : topology_hints.

  Definition isContinuousMap {dom : Type} {cod : Type} {dom_isTopology : isTopologicalSpace dom} {cod_isTopology : isTopologicalSpace cod} (f : dom -> cod) : Prop :=
    forall Y : ensemble cod, << TGT_OPEN : isOpen Y >> -> << SRC_OPEN : isOpen (preimage f Y) >>
  .

  Section SUBTOPOLOGY.

  Context {A : Type} (phi : A -> Prop).

  Let Subspace : Type := @sig A phi.

  Context {requiresTopology : isTopologicalSpace A}.

  Definition isOpen_inSubspace (O_repr : ensemble Subspace) : Prop :=
    exists O : ensemble A, isFilterReprOf phi O_repr O /\ isOpen O
  .

  Local Hint Unfold isOpen_inSubspace : core.

  Global Instance Subtopology
    : Topology_axiom isOpen_inSubspace.
  Proof with (now vm_compute in *; firstorder) || (eauto with *).
    split.
    - exists (full). split...
    - ii. exists (unions (bind Xs (fun O_repr : ensemble Subspace => fun O : ensemble A => isFilterReprOf phi O_repr O /\ isOpen O))). split... eapply unions_isOpen...
    - intros X1 X2 [O1 [O1_repr O1_open]] [O2 [O2_repr O2_open]]. exists (intersection O1 O2). split...
    - intros X X' [O [O_repr O_open]] X_eq_X'...
  Qed.

  End SUBTOPOLOGY.

  Local Instance SubspaceTopology {A : Type} {requiresTopology : isTopologicalSpace A} (phi : A -> Prop) : isTopologicalSpace (@sig A phi) :=
    { isOpen := @isOpen_inSubspace A phi requiresTopology
    ; TopologicalSpace_obeysTopology_axiom := @Subtopology A phi requiresTopology
    }
  .

  Lemma proj1_sig_isContinuousMap_fromSubspaceTopology {A : Type} {requiresTopology : isTopologicalSpace A} (X : ensemble A)
    : isContinuousMap (dom := @sig A X) (cod := A) (@proj1_sig A X).
  Proof with eauto with *. ii; desnw; unnw. exists (Y). split... eapply isFilterReprOf_iff... Qed.

End BasicGeneralTopology.


Require Import Nat.
Require Import PeanoNat.

Ltac inv H := inversion H; subst; clear H.
(* destruct a match in a hypothesis *)
Ltac dmh := match goal with | H : context[match ?x with | _ => _ end] |- _ => destruct x eqn:?E end.
(* destruct a match in the goal *)
Ltac dmg := match goal with | |- context[match ?x with | _ => _ end] => destruct x eqn:?E end.
Ltac dm := (first [dmh | dmg]); auto.

Lemma false_not_true : forall(b : bool),
    b = false <-> not(b = true).
Proof.
  intros b. split.
  - intros H. destruct b.
    + discriminate.
    + unfold not. intros C. discriminate.
  - intros H. destruct b.
    + contradiction.
    + reflexivity.
Qed.

Ltac inj_all :=
  match goal with
  | H:context [ (_, _) = (_, _) ] |- _
    => injection H; intros; subst; clear H
  | H:context [ Some _ = Some _ ] |- _
    => injection H; intros; subst; clear H
  end.

Ltac eqb_eq_all :=
  match goal with
  | H:context [ (_ =? _) = _ ] |- _ => try(rewrite false_not_true in H); rewrite Nat.eqb_eq in H
  end.

Ltac ltb_lt_all :=
  match goal with
  | H:context [ (_ <? _) = _ ] |- _ => try(rewrite false_not_true in H); rewrite Nat.ltb_lt in H
  end.


(* Code for Software Foundations, Chapter 6: Tactics: More Basic Tactics *)

Require Import Arith.
Require Import List.
Require Import Poly.

(* silly_ex *)

Theorem silly_ex :
  (forall n, Nat.even n = true -> Nat.odd (S n) = true) -> Nat.even 3 = true -> Nat.odd 4 = true.
Proof.
  intros h1 h2.
  apply h1.
  apply h2.
Qed.

(* apply_exercise1 *)

Theorem rev_exercise1 :
  forall l l' : list nat, l = rev l' -> l' = rev l.
Proof.
  intros l l'.
  (* Theorem rev_involutive :
    forall (X : Type) (l : list X), rev (rev l) = l. *)
  pattern l.
  rewrite <- rev_involutive.
  intros h1.
  rewrite h1.
  rewrite rev_involutive.
  reflexivity.
Qed.

(* apply_rewrite *)

(* The difference between "rewrite" and "apply":
  + apply: match current goal with argument's inclusion, generate new
    subgoals from it's hypotheses.
  + rewrite: rewrite from equation. *)

(* apply_with_exercise *)

Definition minus_two (n : nat) : nat :=
  match n with
    | O        => O
    | S O      => O
    | S (S n') => n'
  end.

Theorem trans_eq_exercise :
  forall n m o p, m = minus_two o -> n + p = m -> n + p = minus_two o.
Proof.
  intros n m o p h1 h2.
  rewrite h2.
  rewrite h1.
  reflexivity.
Qed.

(* inversion_exercise *)

Theorem inversion_ex1 :
  forall n m o : nat, n::m::nil = o::o::nil -> n::nil = m::nil.
Proof.
  intros n m o.
  inversion 1; reflexivity.
Qed.

Theorem inversion_ex2 :
  forall n m : nat, n::nil = m::nil -> n = m.
Proof.
  intros n m.
  inversion 1; reflexivity.
Qed.

Theorem inversion_ex3 :
  forall (X : Type) (x y z : X) (l j : list X), x :: y :: l = z :: j -> y :: l = x :: j -> x = y.
Proof.
  intros X x y z l j.
  inversion 1.
  inversion 1.
  reflexivity.
Qed.

Theorem inversion_ex4 :
  forall n : nat, S n = O -> 2 + 2 = 5.
Proof.
  intros n.
  inversion 1.
Qed.

Theorem inversion_ex5 :
  forall n m : nat, false = true -> n::nil = m::nil.
Proof.
  intros n m.
  inversion 1.
Qed.

Theorem inversion_ex6 :
  forall (X : Type) (x y z : X) (l j : list X), x::y::l = nil -> y::l = z::j -> x = z.
Proof.
  intros X x y z l j.
  inversion 1.
Qed.

(* plus_n_n_injective *)

Theorem plus_n_n_injective :
  forall n m : nat, n + n = m + m -> n = m.
Proof.
  induction n, m.
  + simpl; reflexivity.
  + simpl; inversion 1.
  + simpl; inversion 1.
  + intros h1.
    simpl in h1.
    apply Nat.succ_inj in h1.
    pattern (n + S n) in h1; rewrite plus_comm in h1.
    pattern (m + S m) in h1; rewrite plus_comm in h1.
    simpl in h1.
    apply Nat.succ_inj in h1.
    apply eq_S.
    apply IHn.
    assumption.
Qed.

(* beq_nat_true *)

Theorem beq_nat_true :
  forall n m, beq_nat n m = true -> n = m.
Proof.
  induction n.
  + induction m.
    - simpl; reflexivity.
    - simpl; inversion 1.
  + induction m.
    - simpl; inversion 1.
    - intros h1.
      simpl in h1.
      apply IHn in h1.
      rewrite h1; reflexivity.
Qed.

(* gen_dep_practice *)

Theorem nth_error_after_last :
  forall (n : nat) (X : Type) (l : list X), length l = n -> nth_error l n = None.
Proof.
  intros n X l.
  (* NOTE: PAY attention to the order of "generalize dependent" and "induction".
    WHY?
    If use "generalize" after "induction", the hypothesis can be proved under
    base condition still keeps it was after "induction", before "generalize".
    But in an opposite manner, the conclusion under base condition will contain
    the term introduced by "generalize". *)
  generalize dependent n.
  induction l.
  + intros n h1.
    rewrite <- h1.
    reflexivity.
  + intros n h1.
    simpl in h1.
    rewrite <- h1.
    simpl; apply IHl; reflexivity.
Qed.

(* app_length_cons *)

Theorem app_length_cons :
  forall (X : Type) (l1 l2 : list X) (x : X) (n : nat),
    length (l1 ++ (x :: l2)) = n -> S (length (l1 ++ l2)) = n.
Proof.
  intros X l1 l2 x n.
  induction l1.
  + simpl.
    intros; assumption.
  + simpl.
    intros h1.
    assert (length_app_succ : length (l1 ++ x :: l2) = S (length (l1 ++ l2))).
    - rewrite List.app_length.
      simpl.
      rewrite <- plus_n_Sm.
      rewrite List.app_length.
      reflexivity.
    - rewrite <- h1.
      rewrite length_app_succ.
      reflexivity.
Qed.

(* app_length_twice *)

Theorem app_length_twice :
  forall (X : Type) (n : nat) (l : list X), length l = n -> length (l ++ l) = n + n.
Proof.
  intros X n l h1.
  rewrite List.app_length.
  repeat rewrite h1.
  reflexivity.
Qed.

Lemma app_length :
  forall (X : Type) (l1 l2 : list X), length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1.
  - simpl; reflexivity.
  - simpl; rewrite IHl1; reflexivity.
Qed.

(* double induction *)
Theorem double_induction :
  forall (P : nat -> nat -> Prop),
    P O O -> (
      forall m, P m O -> P (S m) O) -> (
        forall n, P O n -> P O (S n)) -> (
          forall m n, P m n -> P (S m) (S n)) -> (
            forall m n, P m n).
Proof.
  intros P h1 h2 h3 h4.
  induction m.
  + induction n.
    - apply h1.
    - apply h3; apply IHn.
  + induction n.
    - apply h2; apply (IHm O).
    - apply h4.
      apply IHm.
Qed.

(* combine_split *)

Theorem combine_split :
  forall X Y (l : list (X * Y)) l1 l2, split l = (l1, l2) -> combine l1 l2 = l.
Proof.
  induction l as [|(x, y) l'].
  + intros l1 l2 h1.
    simpl in h1.
    inversion h1.
    simpl; reflexivity.
  + simpl.
    destruct (split l') as [xs ys]. (* The KEY step! *)
    intros l1 l2 h1.
    inversion h1.
    simpl.
    rewrite IHl'; reflexivity.
Qed.

(* destruct_eqn_practice *)

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool), f (f (f b)) = f b.
Proof.
  intros f b.

  assert(case_h1 : f true = true -> f false = true -> f (f (f b)) = f b).
  intros h1 h2.
  case b.
  repeat rewrite h1; reflexivity.
  rewrite h2; repeat rewrite h1; reflexivity.

  assert(case_h2 : f true = true -> f false = false -> f (f (f b)) = f b).
  intros h1 h2.
  case b.
  repeat rewrite h1; reflexivity.
  repeat rewrite h2; reflexivity.

  assert(case_h3 : f true = false -> f false = true -> f (f (f b)) = f b).
  intros h1 h2.
  case b.
  rewrite h1; rewrite h2; rewrite h1; reflexivity.
  rewrite h2; rewrite h1; rewrite h2; reflexivity.

  assert(case_h4 : f true = false -> f false = false -> f (f (f b)) = f b).
  intros h1 h2.
  case b.
  rewrite h1; repeat rewrite h2; reflexivity.
  repeat rewrite h2; reflexivity.

  destruct (f true).
  + destruct (f false).
    - apply case_h1; reflexivity.
    - apply case_h2; reflexivity.
  + destruct (f false).
    - apply case_h3; reflexivity.
    - apply case_h4; reflexivity.
Qed.

(* beq_nat_sym *)

Theorem beq_nat_sym :
  forall n m, beq_nat n m = beq_nat m n.
Proof.
  induction n, m.
  + reflexivity.
  + reflexivity.
  + reflexivity.
  + simpl; apply IHn.
Qed.

(* beq_nat_trans *)

Theorem beq_nat_trans :
  forall n m p, beq_nat n m = true -> beq_nat m p = true -> beq_nat n p = true.
Proof.
  induction n, m, p; try (simpl; reflexivity).
  + trivial.
  + trivial.
  + trivial.
  + inversion 1.
  + trivial.
  + simpl; apply IHn.
Qed.

(* split_combine *)

Theorem split_combine :
  forall (X : Type) (l1 l2 : list X), length l1 = length l2 -> split (combine l1 l2) = (l1, l2).
Proof.
  induction l1, l2.
  + simpl; reflexivity.
  + simpl; inversion 1.
  + simpl; inversion 1.
  + simpl.
    intros h1.
    apply eq_add_S in h1.
    rewrite IHl1.
    - reflexivity.
    - assumption.
Qed.

(* filter_exercise *)

Theorem filter_exercise :
  forall (X : Type) (test : X -> bool) (x : X) (l lf : list X),
    filter test l = x :: lf -> test x = true.
Proof.
  induction l.
  + inversion 1.
  + intros lf h1.
    simpl in h1.
    (* destruct term "eqn:naming_intro_pattern" *)
    destruct (test a) as [] _eqn:h2.
    - inversion h1 as [eq_a_x].
      rewrite eq_a_x in h2.
      assumption.
    - apply (IHl lf); assumption.
Qed.

(* forall_exists_challenge *)

Fixpoint forallb {X : Type} (p : X -> bool) (l : list X) {struct l} : bool :=
  match l with
    | nil   => true
    | x::xs => andb (p x) (forallb p xs)
  end.

Fixpoint existsb {X : Type} (p : X -> bool) (l : list X) {struct l} : bool :=
  match l with
    | nil   => false
    | x::xs => if p x then true else existsb p xs
  end.

Definition existsb' {X : Type} (p : X -> bool) (l : list X) : bool :=
  negb (forallb (fun x => negb (p x)) l).

Theorem existsb_eq :
  forall (X : Type) (p : X -> bool) (l : list X), existsb p l = existsb' p l.
Proof.
  intros X p l.
  unfold existsb'.
  induction l.
  + simpl; reflexivity.
  + simpl.
    destruct (p a) as [] eqn:pred_a.
    simpl; reflexivity.
    simpl; rewrite <- IHl; reflexivity.
Qed.


Require Import Arith Bool List DepList.

Module Tree_Idx.
  Inductive tree (A : Type) : Type :=
  | Leaf : A -> tree A
  | Node : tree A -> tree A -> tree A.

  Arguments Leaf {A} _.
  Arguments Node {A} _ _.

  Inductive Path {A} (a : A) : tree A -> Type :=
  | Empty : Path a (Leaf a)
  | Left : forall l r, Path a l -> Path a (Node l r)
  | Right : forall l r, Path a r -> Path a (Node l r).

  Inductive htree {A} B idx : Type :=
  | Tf : (forall (a : A), Path a idx -> B a) -> htree B idx.

  Definition map {A B C D idx}
             (f : forall a, B a -> C a -> D a)
             (t1 : htree B idx)
             (t2 : htree C idx)
    : htree D idx :=
    match t1, t2 with
    | Tf f1, Tf f2 => @Tf A D idx (fun a p => f a (f1 a p) (f2 a p))
    end.
End Tree_Idx.

Module Tree_Rec.
  Inductive tree (A : Type) : Type :=
  | Leaf : A -> tree A
  | Node : tree A -> tree A -> tree A.

  Arguments Leaf {A} _.
  Arguments Node {A} _ _.

  Fixpoint htree {A} (B : A -> Type) (idx : tree A) : Type :=
    match idx with
    | Leaf a => B a
    | Node l r => htree B l * htree B r
    end%type.

  Fixpoint Path {A : Type} a (idx : tree A) : Type :=
    match idx with
    | Leaf a' => a' = a
    | Node l r => Path a l + Path a r
    end%type.

  Fixpoint get {A} B idx (t : htree B idx) {a : A} (p : Path a idx) : B a :=
    match idx return htree B idx -> Path a idx -> B a with
    | Node li ri => fun t p =>
                      match t with
                      | pair l r => match p with
                                    | inl p' => get B li l p'
                                    | inr p' => get B ri r p'
                                    end
                      end
    | Leaf _ => fun t p =>
                  match p with
                  | eq_refl => t
                  end
    end t p.

  Fixpoint map {A B C D} {idx : tree A}
           (f : forall a, B a -> C a -> D a)
           (t1 : htree B idx)
           (t2 : htree C idx)
    : htree D idx :=
    match idx return htree B idx -> htree C idx -> htree D idx
    with
    | Leaf a => fun t1 t2 => f a t1 t2
    | Node l r => fun t1 t2 => (map f (fst t1) (fst t2), map f (snd t1) (snd t2))
    end t1 t2.
End Tree_Rec.

Module Tree_Ind.
  Inductive tree (A : Type) : Type :=
  | Leaf : A -> tree A
  | Node : tree A -> tree A -> tree A.

  Arguments Leaf {A} _.
  Arguments Node {A} _ _.

  Inductive htree {A : Type} (B : A -> Type) : tree A -> Type :=
  | L : forall (a : A) (x : B a), htree B (Leaf a)
  | N : forall (T1 T2 : tree A) (t1 : htree B T1) (t2 : htree B T2), htree B (Node T1 T2).

  Arguments L {A} {B} {a}  _.
  Arguments N {A} {B} {T1} {T2} _ _.

  Inductive Path {A} (a : A) : tree A -> Type :=
  | Empty : Path a (Leaf a)
  | Left : forall l r, Path a l -> Path a (Node l r)
  | Right : forall l r, Path a r -> Path a (Node l r).

  Fixpoint get {A B idx a} (t : htree B idx) (p : Path a idx) : B a :=
    match p in Path _ idx return @htree A B idx -> B a
    with
    | Empty => fun t =>
                 match t in htree _ idx return match idx with
                                               | Leaf a => B a
                                               | Node _ _ => unit
                                               end
                 with
                 | L _ x => x
                 | N _ _ _ _ => tt
                 end
    | Left tl _ p' => fun t =>
                        match t in htree _ idx return match idx with
                                                      | Leaf _ => unit
                                                      | Node tl _ => Path a tl -> B a
                                                      end
                        with
                        | L _ _ => tt
                        | N _ _ l _ => fun p' => get l p'
                        end p'
    | Right _ _ p' => fun t =>
                        match t in htree _ idx return match idx with
                                                      | Leaf _ => unit
                                                      | Node _ tr => Path a tr -> B a
                                                      end
                        with
                        | L _ _ => tt
                        | N _ _ _ r => fun p' => get r p'
                        end p'
    end t.

  Fixpoint map {A B C D} {idx : tree A}
           (f : forall a, B a -> C a -> D a)
           (t1 : htree B idx)
           (t2 : htree C idx)
    : htree D idx :=
    match t1 in htree _ idx return htree C idx -> htree D idx
    with
    | L _ x => fun t2 =>
                 match t2 in htree _ idx return match idx with
                                                | Leaf a => B a -> htree D idx
                                                | _ => unit
                                                end
                 with
                 | L a y => fun x => L (f a x y)
                 | _ => tt
                 end x
    | N tl tr l r => fun t2 =>
                       match t2 in htree _ idx return match idx with
                                                      | Leaf _ => unit
                                                      | Node tl tr => htree B tl -> htree B tr -> htree D idx
                                                      end
                       with
                       | L _ _ => tt
                       | N _ _ l' r' => fun l r => N (map f l l') (map f r r')
                       end l r
    end t2.
End Tree_Ind.

Module Interpreter.
  Inductive ty : Set :=
  | Bool : ty
  | Sum : ty -> ty -> ty.

  Fixpoint denote (t : ty) : Set :=
    match t with
    | Bool => bool
    | Sum t1 t2 => denote t1 + denote t2
    end%type.

  Definition var := nat.

  Definition binding := prod var ty.

  Definition bindings := list binding.

  Inductive P : bindings -> ty -> Set :=
  | PVar : forall T x, P (pair x T :: nil) T
  | PConst : bool -> P nil Bool
  | PLeft : forall bs T1 T2, P bs T1 -> P bs (Sum T1 T2)
  | PRight : forall bs T1 T2, P bs T2 -> P bs (Sum T1 T2).

  Definition Patterns (bs : list bindings) (T : ty) :=
    hlist (fun b => P b T) bs.

  Inductive Exp : bindings -> ty -> Set :=
  | Var : forall bs T v, member (v, T) bs -> Exp bs T
  | Const : forall bs, bool -> Exp bs Bool
  | Left : forall bs T1 T2, Exp bs T1 -> Exp bs (Sum T1 T2)
  | Right : forall bs T1 T2, Exp bs T2 -> Exp bs (Sum T1 T2)
  | Case : forall bs T1 T2
                  (pbs : list bindings)
                  (patterns : Patterns pbs T1),
      (forall b, member b pbs -> Exp (b ++ bs) T2)
      -> Exp bs T2
      -> Exp bs T1
      -> Exp bs T2.

  Definition PExps (bs : bindings) (pbs : list bindings) (T : ty) :=
    hlist (fun b => Exp (b ++ bs) T) pbs.

  Definition bindingType (b : binding) : Set :=
    denote (snd b).

  Definition Env (bs : bindings):=
    hlist bindingType bs.

  Fixpoint patternMatch {pbs T} (p : P pbs T) (v : denote T) {bs} (G : Env bs)
    : option (Env (pbs ++ bs)) :=
    match p in P pbs T return denote T -> Env bs -> option (Env (pbs ++ bs))
    with
    | PVar T x => fun v G => Some (@HCons binding bindingType (x, T) bs v G)
    | PConst b => fun v G => if bool_dec b v then Some G else None
    | PLeft _ _ _ p' => fun v G => match v with
                                   | inl x => patternMatch p' x G
                                   | _ => None
                                   end
    | PRight _ _ _ p' => fun v G => match v with
                                    | inr x => patternMatch p' x G
                                    | _ => None
                                    end
    end v G.

  Definition Matched (bs : bindings) (pbs : list bindings) :=
    fun b => prod (member b pbs) (Env (b ++ bs)).

  Fixpoint matched {bs pbs T}
           (patterns : Patterns pbs T)
           (G : Env bs)
           (v : denote T)
    : option (sigT (Matched bs pbs)) :=
    match patterns with
    | HCons b pbs' p patterns' =>
      match patternMatch p v G with
      | Some G' => Some (existT _ b (@HFirst bindings b pbs', G'))
      | None => match matched patterns' G v with
                | Some (existT b (m, G'))
                  => Some (existT _ b (HNext m, G'))
                | None => None
                end
      end
    | _ => None
    end.

  Fixpoint eval {T bs} (e : Exp bs T) (G : Env bs) {struct e} : denote T :=
    match e in Exp bs T return Env bs -> denote T
    with
    | Var _ _ v m => fun G => hget G m
    | Const _ b => fun _ => b
    | Left _ _ _ e' => fun G => inl (eval e' G)
    | Right _ _ _ e' => fun G => inr (eval e' G)
    | Case bs T1 T2 pbs patterns exps def e' =>
      fun G =>
        match matched patterns G (eval e' G) with
        | Some (existT b (m, G')) => eval (exps b m) G'
        | None => eval def G
        end
    end G.
End Interpreter.


Require Import Arith.
Require Import List.
Require Import ListSet.

Inductive Ty : Set :=
| Bas : nat -> Ty
| Arr : Ty -> Ty -> Ty.
Notation "T ⇒ S" := (Arr T S) (at level 30, right associativity).

Inductive Term : Set :=
| v : nat -> Term
| ƛ : Ty -> Term -> Term
| app : Term -> Term -> Term.
Notation "t · s" := (app t s) (at level 20, left associativity).

Fixpoint Free (n : nat) (A : Set) : Set :=
  match n with
    | O => A
    | S n' => Term -> Free n' A
  end.

Notation "[]" := nil.
Notation "[ x ]" := (cons x nil).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).

Fixpoint idx (A : Set) (n : nat) (G : list A) : option A :=
  match G with
    | [] => None
    | (x::t) => match n with
                  | O => Some x
                  | S n' => idx A n' t
                end
  end.
Implicit Arguments idx [A].

Definition Ctx := list Ty.

(* Note : is \colon, using TeX mode, and not : *)
Reserved Notation "Γ ⊢ t @ A" (at level 70, no associativity).
Inductive Derivation : Ctx -> Term -> Ty -> Set :=
| VarIntro : forall Γ n A,
  idx n Γ = Some A ->
  Γ ⊢ (v n) @ A
| ImpIntro : forall Γ t A B,
  A::Γ ⊢ t @ B ->
  Γ ⊢ ƛ A t @ A ⇒ B
| ImpElim : forall Γ f t A B,
  Γ ⊢ f @ A ⇒ B ->
  Γ ⊢ t @ A ->
  Γ ⊢ f · t @ B
 where "Γ ⊢ r @ A " := (Derivation Γ r A) : type_scope.

Fixpoint shiftat (d : nat) (x : Term) {struct x} : Term :=
  match x with
    | v m => if le_lt_dec d m then v (S m) else v m
    | ƛ A t => ƛ A (shiftat (S d) t)
    | r · s => (shiftat d r) · (shiftat d s)
  end.
Definition shift := shiftat 0.

Definition sub : forall (t : Term) (n : nat) (u : Term), Term.
Proof.
  refine
    (fix sub (t : Term) (n : nat) (u : Term) :=
      match t with
        | v m => match le_lt_dec n m with
                   | left p =>
                     match eq_nat_dec n m with
                       | left _ => u
                       | right p' =>
                         (match m as m' return (m = m' -> Term) with
                            | 0 => (fun p'' => False_rec _ _ )
                            | S m' => (fun _ => v m')
                          end) (refl_equal m)
                     end
                   | right _ => v m
                 end
        | ƛ A t => ƛ A (sub t (S n) (shift u))
        | r · s => (sub r n u) · (sub s n u)
      end) ; subst ; auto.
  destruct n. apply le_n_O_eq in p. apply p'. reflexivity.
  inversion p.
Defined.

Lemma GammaClose : forall Γ a t A B,
  A::Γ ⊢ t @ B -> [] ⊢ a @ A -> Γ ⊢ (sub t 0 a) @ B).

Lemma GammaClosure : forall Γ t A,
  Γ ⊢ t @ A -> Free (length Γ) ([] ⊢ t @ A).
Proof.
  induction Γ ; intros.

  (* [] *)
  simpl. auto.

  (* a::Γ *)
  simpl.
  intros.
  apply IHΓ.


Require Import Coq.Arith.EqNat.
Require Import Coq.Init.Nat.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.

Require Import Hapsl.Bool.Bool.
Require Import Hapsl.Ascii.Equality.

(* Returns true if one character is exactly one more than another, otherwise
   returns false. *)
Definition consecutive_up (c1 c2 : ascii) : bool :=
  eqb (nat_of_ascii c1) ((nat_of_ascii c2) - 1).

(* Returns true if one character is exactly one less than another, otherwise
   returns false. *)
Definition consecutive_down (c1 c2 : ascii) : bool :=
  eqb (nat_of_ascii c1) ((nat_of_ascii c2) + 1).

(* Returns the maximum number of times consecutive characters in a string
   satisfy a function. *)
Fixpoint sequence_of (s : string) (f : ascii->ascii->bool) (a : nat) : nat :=
  match s with
  | EmptyString => a
  | String c1 s1 =>
    match s1 with
    | EmptyString => a
    | String c2 s2 =>
      if f c1 c2 then
        sequence_of s1 f (a + 1)
      else
        max a (sequence_of s1 f 0)
    end
  end.

(* Returns the maximum number of times consecutive characters in a string are
   one more than their predecessor. *)
Definition sequence_up (s : string) : nat :=
  sequence_of s consecutive_up 0.

(* Returns the maximum number of times consecutive characters in a string are
   one less than their predecessor. *)
Definition sequence_down (s : string) : nat :=
  sequence_of s consecutive_down 0.

(* Returns the maximum number of times consecutive characters in a string are
   the same as their predecessor. *)
Definition sequence_eq (s : string) : nat :=
  sequence_of s beq_ascii 0.


Require Import Coq.funind.FunInd.

Definition iszero (n : nat) : bool :=
  match n with
  | O => true
  | _ => false
  end.

Functional Scheme iszero_ind := Induction for iszero Sort Prop.

Lemma toto : forall n : nat, n = 0 -> iszero n = true.
intros x eg.
 functional induction iszero x; simpl.
trivial.
inversion eg.
Qed.

Function ftest (n m : nat) : nat :=
  match n with
  | O => match m with
         | O => 0
         | _ => 1
         end
  | S p => 0
  end.
(* MS: FIXME: apparently can't define R_ftest_complete. Rest of the file goes through. *)

Lemma test1 : forall n m : nat, ftest n m <= 2.
intros n m.
 functional induction ftest n m; auto.
Qed.

Lemma test2 : forall m n, ~ 2 = ftest n m.
Proof.
intros n m;intro H.
functional inversion H ftest.
Qed.

Lemma test3 : forall n m, ftest n m = 0 -> (n = 0 /\ m = 0)  \/ n <> 0.
Proof.
functional inversion 1 ftest;auto.
Qed.

Require Import Arith.
Lemma test11 : forall m : nat, ftest 0 m <= 2.
intros m.
 functional induction ftest 0 m.
auto.
auto.
auto with *.
Qed.

Function lamfix (m n : nat) {struct n } : nat :=
  match n with
    | O => m
    | S p => lamfix m p
  end.

(* Parameter v1 v2 : nat. *)

Lemma lamfix_lem : forall v1 v2 : nat, lamfix v1 v2 = v1.
intros v1 v2.
 functional induction lamfix v1 v2.
trivial.
assumption.
Defined.

(* polymorphic function *)
Require Import List.

Functional Scheme app_ind := Induction for app Sort Prop.

Lemma appnil : forall (A : Set) (l l' : list A), l' = nil -> l = l ++ l'.
intros A l l'.
 functional induction app A l l';  intuition.
 rewrite <- H0; trivial.
Qed.

Require Export Arith.

Function trivfun (n : nat) : nat :=
  match n with
  | O => 0
  | S m => trivfun m
  end.

(* essaie de parametre variables non locaux:*)

Parameter varessai : nat.

Lemma first_try : trivfun varessai = 0.
 functional induction trivfun varessai.
trivial.
assumption.
Defined.

 Functional Scheme triv_ind := Induction for trivfun Sort Prop.

Lemma bisrepetita : forall n' : nat, trivfun n' = 0.
intros n'.
 functional induction trivfun n'.
trivial.
assumption.
Qed.

Function iseven (n : nat) : bool :=
  match n with
  | O => true
  | S (S m) => iseven m
  | _ => false
  end.

Function funex (n : nat) : nat :=
  match iseven n with
  | true => n
  | false => match n with
             | O => 0
             | S r => funex r
             end
  end.

Function nat_equal_bool (n m : nat) {struct n} : bool :=
  match n with
  | O => match m with
         | O => true
         | _ => false
         end
  | S p => match m with
           | O => false
           | S q => nat_equal_bool p q
           end
  end.

Require Export Div2.
Require Import Nat.
Functional Scheme div2_ind := Induction for div2 Sort Prop.
Lemma div2_inf : forall n : nat, div2 n <= n.
intros n.
 functional induction div2 n.
auto.
auto.

apply le_S.
apply le_n_S.
exact IHn0.
Qed.

(* reuse this lemma as a scheme:*)

Function nested_lam (n : nat) : nat -> nat :=
  match n with
  | O => fun m : nat => 0
  | S n' => fun m : nat => m + nested_lam n' m
  end.

Lemma nest : forall n m : nat, nested_lam n m = n * m.
intros n m.
 functional induction nested_lam n m; simpl;auto.
Qed.

Function essai (x : nat) (p : nat * nat) {struct x} : nat :=
  let (n, m) := (p: nat*nat) in
  match n with
  | O => 0
  | S q => match x with
           | O => 1
           | S r => S (essai r (q, m))
           end
  end.

Lemma essai_essai :
 forall (x : nat) (p : nat * nat), let (n, m) := p in 0 < n -> 0 < essai x p.
intros x p.
 functional induction essai x p; intros.
inversion H.
auto with arith.
 auto with arith.
Qed.

Function plus_x_not_five'' (n m : nat) {struct n} : nat :=
  let x := nat_equal_bool m 5 in
  let y := 0 in
  match n with
  | O => y
  | S q =>
      let recapp := plus_x_not_five'' q m in
      match x with
      | true => S recapp
      | false => S recapp
      end
  end.

Lemma notplusfive'' : forall x y : nat, y = 5 -> plus_x_not_five'' x y = x.
intros a b.
 functional induction plus_x_not_five'' a b; intros hyp; simpl; auto.
Qed.

Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true.
intros n m.
 functional induction nat_equal_bool n m; simpl; intros hyp; auto.
rewrite <- hyp in y; simpl in y;tauto.
inversion hyp.
Qed.

Lemma iseq_eq' : forall n m : nat, nat_equal_bool n m = true -> n = m.
intros n m.
 functional induction nat_equal_bool n m; simpl; intros eg; auto.
inversion eg.
inversion eg.
Qed.

Inductive istrue : bool -> Prop :=
    istrue0 : istrue true.

Functional Scheme add_ind := Induction for add Sort Prop.

Lemma inf_x_plusxy' : forall x y : nat, x <= x + y.
intros n m.
 functional induction add n m; intros.
auto with arith.
auto with arith.
Qed.

Lemma inf_x_plusxy'' : forall x : nat, x <= x + 0.
intros n.
unfold plus.
 functional induction plus n 0; intros.
auto with arith.
apply le_n_S.
assumption.
Qed.

Lemma inf_x_plusxy''' : forall x : nat, x <= 0 + x.
intros n.
 functional induction plus 0 n; intros; auto with arith.
Qed.

Function mod2 (n : nat) : nat :=
  match n with
  | O => 0
  | S (S m) => S (mod2 m)
  | _ => 0
  end.

Lemma princ_mod2 : forall n : nat, mod2 n <= n.
intros n.
 functional induction mod2 n; simpl; auto with arith.
Qed.

Function isfour (n : nat) : bool :=
  match n with
  | S (S (S (S O))) => true
  | _ => false
  end.

Function isononeorfour (n : nat) : bool :=
  match n with
  | S O => true
  | S (S (S (S O))) => true
  | _ => false
  end.

Lemma toto'' : forall n : nat, istrue (isfour n) -> istrue (isononeorfour n).
intros n.
 functional induction isononeorfour n; intros istr; simpl;
 inversion istr.
apply istrue0.
destruct n. inversion istr.
destruct n. tauto.
destruct n. inversion istr.
destruct n. inversion istr.
destruct n. tauto.
simpl in *. inversion H0.
Qed.

Lemma toto' : forall n m : nat, n = 4 -> istrue (isononeorfour n).
intros n.
 functional induction isononeorfour n; intros m istr; inversion istr.
apply istrue0.
rewrite H in y; simpl in y;tauto.
Qed.

Function ftest4 (n m : nat) : nat :=
  match n with
  | O => match m with
         | O => 0
         | S q => 1
         end
  | S p => match m with
           | O => 0
           | S r => 1
           end
  end.

Lemma test4 : forall n m : nat, ftest n m <= 2.
intros n m.
 functional induction ftest n m; auto with arith.
Qed.

Lemma test4' : forall n m : nat, ftest4 (S n) m <= 2.
intros n m.
assert ({n0 | n0 = S n}).
exists (S n);reflexivity.
destruct H as [n0 H1].
rewrite <- H1;revert H1.
 functional induction ftest4 n0 m.
inversion 1.
inversion 1.

auto with arith.
auto with arith.
Qed.

Function ftest44 (x : nat * nat) (n m : nat) : nat :=
  let (p, q) := (x: nat*nat) in
  match n with
  | O => match m with
         | O => 0
         | S q => 1
         end
  | S p => match m with
           | O => 0
           | S r => 1
           end
  end.

Lemma test44 :
 forall (pq : nat * nat) (n m o r s : nat), ftest44 pq n (S m) <= 2.
intros pq n m o r s.
 functional induction ftest44 pq n (S m).
auto with arith.
auto with arith.
auto with arith.
auto with arith.
Qed.

Function ftest2 (n m : nat) {struct n} : nat :=
  match n with
  | O => match m with
         | O => 0
         | S q => 0
         end
  | S p => ftest2 p m
  end.

Lemma test2' : forall n m : nat, ftest2 n m <= 2.
intros n m.
 functional induction ftest2 n m; simpl; intros; auto.
Qed.

Function ftest3 (n m : nat) {struct n} : nat :=
  match n with
  | O => 0
  | S p => match m with
           | O => ftest3 p 0
           | S r => 0
           end
  end.

Lemma test3' : forall n m : nat, ftest3 n m <= 2.
intros n m.
 functional induction ftest3 n m.
intros.
auto.
intros.
auto.
intros.
simpl.
auto.
Qed.

Function ftest5 (n m : nat) {struct n} : nat :=
  match n with
  | O => 0
  | S p => match m with
           | O => ftest5 p 0
           | S r => ftest5 p r
           end
  end.

Lemma test5 : forall n m : nat, ftest5 n m <= 2.
intros n m.
 functional induction ftest5 n m.
intros.
auto.
intros.
auto.
intros.
simpl.
auto.
Qed.

Function ftest7 (n : nat) : nat :=
  match ftest5 n 0 with
  | O => 0
  | S r => 0
  end.

Lemma essai7 :
 forall (Hrec : forall n : nat, ftest5 n 0 = 0 -> ftest7 n <= 2)
   (Hrec0 : forall n r : nat, ftest5 n 0 = S r -> ftest7 n <= 2)
   (n : nat), ftest7 n <= 2.
intros hyp1 hyp2 n.
 functional induction ftest7 n; auto.
Qed.

Function ftest6 (n m : nat) {struct n} : nat :=
  match n with
  | O => 0
  | S p => match ftest5 p 0 with
           | O => ftest6 p 0
           | S r => ftest6 p r
           end
  end.

Lemma princ6 :
 (forall n m : nat, n = 0 -> ftest6 0 m <= 2) ->
 (forall n m p : nat,
  ftest6 p 0 <= 2 -> ftest5 p 0 = 0 -> n = S p -> ftest6 (S p) m <= 2) ->
 (forall n m p r : nat,
  ftest6 p r <= 2 -> ftest5 p 0 = S r -> n = S p -> ftest6 (S p) m <= 2) ->
 forall x y : nat, ftest6 x y <= 2.
intros hyp1 hyp2 hyp3 n m.
generalize hyp1 hyp2 hyp3.
clear hyp1 hyp2 hyp3.
 functional induction ftest6 n m; auto.
Qed.

Lemma essai6 : forall n m : nat, ftest6 n m <= 2.
intros n m.
 functional induction ftest6 n m; simpl; auto.
Qed.

(* Some tests with modules *)
Module M.
Function test_m (n:nat) : nat :=
  match n with
    | 0 => 0
    | S n =>  S (S (test_m n))
  end.

Lemma test_m_is_double :  forall n, div2 (test_m n) = n.
Proof.
intros n.
functional induction (test_m n).
reflexivity.
simpl;rewrite IHn0;reflexivity.
Qed.
End M.
(* We redefine a new Function with the same name *)
Function test_m (n:nat) : nat :=
  pred n.

Lemma test_m_is_pred : forall n, test_m n = pred n.
Proof.
intro n.
functional induction (test_m n). (* the test_m_ind to use is the last defined  saying that test_m = pred*)
reflexivity.
Qed.

(* Checks if the dot notation are correctly treated in infos *)
Lemma M_test_m_is_double : forall n, div2 (M.test_m n) = n.
intro n.
(* here we should apply M.test_m_ind *)
functional induction (M.test_m n).
reflexivity.
simpl;rewrite IHn0;reflexivity.
Qed.

Import M.
(* Now test_m is the one which defines double *)

Lemma test_m_is_double : forall n, div2 (M.test_m n) = n.
intro n.
(* here we should apply M.test_m_ind *)
functional induction (test_m n).
reflexivity.
simpl;rewrite IHn0;reflexivity.
Qed.


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

Import EqNotations.
Import ListNotations.

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

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

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

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

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

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

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

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

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

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

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

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

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

Instance PreOrder_pairR A B RA RB
         `(PreOrder A RA) `(PreOrder B RB) : PreOrder (pairR RA RB).
Proof.
  constructor.
  { intro p; split; reflexivity. }
  { intros p1 p2 p3 R12 R23; destruct R12; destruct R23; split.
    - transitivity (fst p2); assumption.
    - transitivity (snd p2); assumption. }
Qed.

(* The non-dependent product ordered type, where pairs are related pointwise *)
Definition OTpair (A B:OType) : OType :=
  {|
    ot_Type := ot_Type A * ot_Type B;
    ot_R := pairR (ot_R A) (ot_R B);
    ot_PreOrder := PreOrder_pairR A B _ _ (ot_PreOrder A) (ot_PreOrder B)
  |}.

(* The sort-of pointwise relation on sum types *)
Inductive sumR {A B} (RA:relation A) (RB:relation B) : A+B -> A+B -> Prop :=
| sumR_inl a1 a2 : RA a1 a2 -> sumR RA RB (inl a1) (inl a2)
| sumR_inr b1 b2 : RB b1 b2 -> sumR RA RB (inr b1) (inr b2).

Instance PreOrder_sumR A B RA RB
         `(PreOrder A RA) `(PreOrder B RB) : PreOrder (sumR RA RB).
Proof.
  constructor.
  { intro s; destruct s; constructor; reflexivity. }
  { intros s1 s2 s3 R12 R23. destruct R12; inversion R23.
    - constructor; transitivity a2; assumption.
    - constructor; transitivity b2; assumption. }
Qed.

(*
Definition sumR {A B} (RA:relation A) (RB:relation B) : relation (A+B) :=
  fun sum1 sum2 =>
    match sum1, sum2 with
    | inl x, inl y => RA x y
    | inl x, inr y => False
    | inr x, inl y => False
    | inr x, inr y => RB x y
    end.

Instance PreOrder_sumR A B RA RB
         `(PreOrder A RA) `(PreOrder B RB) : PreOrder (sumR RA RB).
Proof.
  constructor.
  { intro s; destruct s; simpl; reflexivity. }
  { intros s1 s2 s3 R12 R23.
    destruct s1; destruct s2; destruct s3;
      try (elimtype False; assumption); simpl.
    - transitivity a0; assumption.
    - transitivity b0; assumption. }
Qed.
*)

(* The non-dependent sum ordered type, where objects are only related if they
are both "left"s or both "right"s *)
Definition OTsum (A B : OType) : OType :=
  {|
    ot_Type := ot_Type A + ot_Type B;
    ot_R := sumR (ot_R A) (ot_R B);
    ot_PreOrder := PreOrder_sumR _ _ _ _ (ot_PreOrder A) (ot_PreOrder B)
  |}.

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

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

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

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

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

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

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

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

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

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

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

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

(* pfun_app is always Proper *)
Instance Proper_pfun_app A B :
  Proper (ot_R (OTarrow A B) ==> ot_R A ==> ot_R B) (@pfun_app A B).
Proof.
  intros f1 f2 Rf a1 a2 Ra. apply Rf; assumption.
Qed.

(* pfun_app is always Proper w.r.t. ot_equiv *)
Instance Proper_pfun_app_equiv A B :
  Proper (ot_equiv (OTarrow A B) ==> ot_equiv A ==> ot_equiv B) (@pfun_app A B).
Proof.
  intros f1 f2 Rf a1 a2 Ra; destruct Rf; destruct Ra.
  split; apply Proper_pfun_app; assumption.
Qed.

(***
 *** Building Proper Functions
 ***)

Class ProperPair (A:OType) (x y:A) : Prop :=
  proper_pair_pf : ot_R A x y.

Definition ot_Lambda {A B:OType} (f: A -> B)
           {prp:forall x y, ProperPair A x y -> ProperPair B (f x) (f y)}
  : OTarrow A B :=
  {| pfun_app := f; pfun_Proper := prp |}.

Instance ProperPair_refl (A:OType) (x:A) : ProperPair A x x.
Proof.
  unfold ProperPair. reflexivity.
Qed.

Instance ProperPair_pfun_app (A B:OType) (fl fr:OTarrow A B) argl argr
         (prpf:ProperPair (OTarrow A B) fl fr)
         (prpa:ProperPair A argl argr)
 : ProperPair B (pfun_app fl argl) (pfun_app fr argr).
Proof.
  apply prpf; assumption.
Qed.

Instance ProperPair_ot_lambda (A B:OType) (f g:A -> B) prpl prpr
         (pf: forall x y, ProperPair A x y -> ProperPair B (f x) (g y)) :
  ProperPair (OTarrow A B) (@ot_Lambda A B f prpl) (@ot_Lambda A B g prpr).
Proof.
  intros xl xr Rx; apply pf; assumption.
Qed.

(***
 *** Ordered Terms for Pair Operations
 ***)

Program Definition ofst {A B:OType} : OTarrow (OTpair A B) A :=
  @ot_Lambda (OTpair A B) A fst _.
Next Obligation.
  destruct H. assumption.
Qed.

Program Definition osnd {A B:OType} : OTarrow (OTpair A B) B :=
  @ot_Lambda (OTpair A B) _ snd _.
Next Obligation.
  destruct H. assumption.
Qed.

Program Definition opair {A B:OType} : OTarrow A (OTarrow B (OTpair A B)) :=
  @ot_Lambda
    A _
    (fun x =>
       @ot_Lambda
         B (OTpair A B)
         (fun y => pair x y)
         _)
    _.
Next Obligation.
  split; [ reflexivity | assumption ].
Qed.
Next Obligation.
  apply ProperPair_ot_lambda; intros. split; assumption.
Qed.

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

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

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

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

Notation "( x ,o, y )" :=
  (opair @o@ x @o@ y)
    (no associativity, at level 0).

(* FIXME: why don't these work?
Notation "'ofun' ( x : A ) =o> t" :=
  (@ot_Lambda A _ (fun x => t))
    (at level 100, right associativity, x at level 99) : pterm_scope.

Notation "'ofun' x =o> t" :=
  (ot_Lambda (fun x => t))
    (at level 100, right associativity, x at level 99) : pterm_scope.
 *)

Notation ofun := ot_Lambda.

(***
 *** Automation for Ordered Terms
 ***)

(* Don't unfold ot_Lambda when simplifying  *)
Arguments ot_Lambda A B f prp : simpl never.

Instance Proper_ot_R_ot_R A :
  Proper (Basics.flip (ot_R A) ==> ot_R A ==> Basics.impl) (ot_R A).
Proof.
  intros x1 x2 Rx y1 y2 Ry R.
  transitivity x1; [ assumption | ]; transitivity y1; assumption.
Qed.

Instance Proper_ot_equiv_ot_R A :
  Proper (ot_equiv A ==> ot_equiv A ==> iff) (ot_R A).
Proof.
  intros x1 x2 Rx y1 y2 Ry; destruct Rx; destruct Ry; split; intro R.
  transitivity x1; [ assumption | ]; transitivity y1; assumption.
  transitivity x2; [ assumption | ]; transitivity y2; assumption.
Qed.

Instance Proper_ot_R_pfun_app A B :
  Proper (ot_R (A -o> B) ==> ot_R A ==> ot_R B) (@pfun_app A B).
Proof.
  intros f1 f2 Rf x1 x2 Rx. apply Rf; apply Rx.
Qed.

Instance Proper_ot_R_pfun_app_partial A B f :
  Proper (ot_R A ==> ot_R B) (@pfun_app A B f).
Proof.
  apply pfun_Proper.
Qed.

Create HintDb OT.

(* Split ot_equiv equalities into the left and right cases *)
Definition split_ot_equiv A (x y : ot_Type A)
           (pf1: x <o= y) (pf2 : y <o= x) : x =o= y :=
  conj pf1 pf2.

Hint Resolve split_ot_equiv : OT.

(* Extensionality for ot_R *)
Definition ot_arrow_ext (A B:OType) (f1 f2 : A -o> B)
           (pf:forall x y, x <o= y -> f1 @o@ x <o= f2 @o@ y) : f1 <o= f2 := pf.

Hint Resolve ot_arrow_ext : OT.

(* Add the above rules to the OT rewrite set *)
(* Hint Rewrite @mkOTerm_apply @ot_unlift_iso_OTForType_refl_id : OT. *)

(* Eta-equality for pairs *)
Lemma ot_pair_eta (A B:OType) (x : A *o* B) :
  @ot_equiv (A *o* B) (fst x , snd x) x.
  split; split; reflexivity.
Qed.

Hint Rewrite ot_pair_eta : OT.

(* Tactic to apply rewrites in the OT rewrite set *)
Ltac rewrite_OT := rewrite_strat (topdown (hints OT)).

(* General tactic to try to prove theorems about ordered terms *)
(*
Ltac prove_OT :=
  repeat first [simpl_mkOTerm_refl | simpl_mkOTerm_apply];
  try rewrite_OT;
  lazymatch goal with
  | |- ot_equiv _ _ _ => split
  | |- _ => idtac
  end.
  (* repeat (apply ot_arrow_ext; intros). *)
 *)

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

Module OTExamples.

Definition ex1 : OTProp -o> OTProp := ot_Lambda (fun p => p).
(* Eval compute in (pfun_app ex1 : Prop -> Prop). *)

Definition ex2 {A} : (A -o> A) := ot_Lambda (fun p => p).
(* Eval simpl in (fun A:OType => pfun_app (@ex2 A) : A -> A). *)

Definition ex3 {A} : (A -o> A -o> A) :=
  ot_Lambda (fun p1 => ot_Lambda (fun p2 => p1)).
(* Eval simpl in (fun (A:OType) x => pfun_app (pfun_app (@ex3 A) x)). *)

Definition ex4 {A B} : (A *o* B -o> A) := ot_Lambda (fun p => ofst @o@ p).
(* Eval simpl in (fun (A B:OType) => pfun_app ex4 : A * B -> A). *)

Definition ex5 {A B} : A *o* B -o> B *o* A :=
  ot_Lambda (fun p => (osnd @o@ p ,o, ofst @o@ p)).
(* Eval simpl in (fun (A B:OType) => pfun_app ex5 : A *o* B -> B *o* A). *)

Definition ex6 {A B C} : A *o* B *o* C -o> C *o* A :=
  ot_Lambda (fun triple => (osnd @o@ triple ,o, ofst @o@ (ofst @o@ triple))).

Definition ex7 {A B C} : (A *o* B -o> C) -o> C -o> A -o> B -o> C :=
  ot_Lambda (fun (f:(A *o* B -o> C)) =>
               ot_Lambda
                 (fun (c:C) =>
                    ot_Lambda
                      (fun a =>
                         ot_Lambda (fun b => f @o@ (a ,o, b))))).

End OTExamples.


Require Import List Orders Nat.
Require Import Coq.Structures.OrdersFacts.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Sorting.Sorted.
Require Import Sorticoq.SortedList.
Import ListNotations.

Module SelectionSort (Import O: UsualOrderedTypeFull').

Include (OrderedTypeFacts O).

Definition A := O.t.

Fixpoint SelectMin (l: list A) (d: A) : A :=
  match l with
  | [] => d
  | h::t => let y := (SelectMin t h) in match (O.compare d y) with
    | Lt => d
    | _ => y
    end
  end.

Fixpoint delete (x: A) (l: list A) : list A :=
  match l with
  | [] => []
  | h::t => match (O.compare x h) with
    | Eq => t
    | _ => h::(delete x t)
    end
  end.

Fixpoint SelectionSortHelp (l: list A) (n: nat) : list A :=
  match l, n with
  | [], _ => []
  | _, 0 => l
  | h::t, S n' => let y := (SelectMin t h) in
    y::(SelectionSortHelp (delete y l) n')
  end.

Definition SelectionSort (l: list A) :=
  SelectionSortHelp l (length l).

Hint Constructors LocallySorted.
Hint Extern 1 (?x <= ?y) => apply le_lteq; OrderTac.order.

Ltac convert_compare :=
  repeat match goal with
  | H: compare ?x ?y = Lt |- _ => apply compare_lt_iff in H
  | H: compare ?x ?y = Gt |- _ => apply compare_gt_iff in H
  | H: compare ?x ?y = Eq |- _ => apply compare_eq in H
  end.

Lemma le_trans: @transitive O.t le.
Proof.
  unfold transitive.
  intros. apply le_lteq in H. apply le_lteq in H0.
  apply le_lteq. intuition; order.
Qed.

Lemma SelectMin_is_min: forall l a,
  forall x, In x (a::l) -> (SelectMin l a) <= x.
Proof.
  intro l; induction l; intros; simpl; auto.
  - inversion H; auto. inversion H0.
  - simpl in H. destruct H as [H | [H | H]];
    remember (compare _ _) as c; symmetry in Heqc; destruct c; convert_compare;
    subst; auto;
    try match goal with
    | |- SelectMin l ?x <= ?y => apply IHl
    | H: ?x < ?y |- ?x <= ?z => apply (le_trans x y z)
    end; simpl; auto; apply IHl; simpl; auto.
Qed.

Ltac do_compare :=
  let C := fresh in let eqnC := fresh in remember (compare _ _) as C eqn:eqnC;
  symmetry in eqnC; destruct C; convert_compare.

Lemma SelectMin_In: forall l a,
  In (SelectMin l a) (a::l).
Proof.
  intro l; induction l; simpl; auto.
  intros; do_compare; auto.
  simpl in IHl. auto.
Qed.

Lemma SelectMin_In2: forall l a,
  (SelectMin l a) <> a ->
  In (SelectMin l a) l.
Proof.
  intros. assert (In (SelectMin l a) (a::l)) by apply SelectMin_In.
  destruct H0. rewrite <- H0 in H. contradiction. exact H0.
Qed.

Lemma delete_length: forall l a,
  In a l ->
  S (length (delete a l)) = length l.
Proof.
  intro l; induction l; simpl; intros; auto.
  - contradiction.
  - do_compare; auto; intuition; try order.
  all: simpl; apply eq_S; apply IHl; assumption.
Qed.

Lemma delete_Permutation: forall l a,
  In a l ->
  Permutation l (a::delete a l).
Proof.
  induction l; intros; simpl in *.
  - contradiction.
  - do_compare; intuition; subst; try order; auto.
    all: transitivity (a::a0::delete a0 l); auto; apply perm_swap.
Qed.

Opaque delete.

Lemma SelectionSort_Permutation_t: forall l n,
  length l = n -> Permutation l (SelectionSort l).
Proof.
  intros; generalize dependent l.
  induction n; unfold SelectionSort; intros; auto.
  - apply length_zero_iff_nil in H. subst. auto.
  - destruct l eqn: E; simpl; auto.
    assert (length (delete (SelectMin l0 a) (a::l0)) = length l0).
      assert (Hy: In (SelectMin l0 a) (a::l0)) by apply SelectMin_In; simpl in Hy.
      Transparent delete. simpl. do_compare; intuition; try order;
      simpl; apply delete_length; assumption.
    rewrite <- H0.
    change (SelectionSortHelp ?l (length ?l)) with (SelectionSort l).
    transitivity (SelectMin l0 a :: (delete (SelectMin l0 a) (a::l0))).
    apply delete_Permutation. apply SelectMin_In.
    constructor. apply IHn. rewrite H0. simpl in H. auto.
Qed.

Lemma SelectionSort_Permutation: forall l,
  Permutation l (SelectionSort l).
Proof.
  intros. apply (SelectionSort_Permutation_t l (length l)). reflexivity.
Qed.

Hint Extern 2 (Permutation (SelectionSort ?l) ?l) =>
  apply Permutation_sym; apply SelectionSort_Permutation.

Lemma delete_length2: forall l a,
  SelectMin l a <> a ->
  length (a :: delete (SelectMin l a) l) = length l.
Proof.
  intros. simpl; apply delete_length.
  apply SelectMin_In2; assumption.
Qed.

Lemma In_delete: forall l a x,
  In x (delete a l) -> In x l.
Proof.
  induction l; simpl; auto; intros; do_compare; auto.
  all: simpl in H; intuition; apply IHl in H0; auto.
Qed.

Lemma SelectionSort_LocallySorted_t: forall l n,
  length l = n -> LocallySorted le (SelectionSort l).
Proof.
  intros; generalize dependent l.
  induction n; unfold SelectionSort; intros; simpl; auto.
  + apply length_zero_iff_nil in H. subst; simpl; auto.
  + destruct l. inversion H. simpl.
  do_compare;
  try assert (length (a::(delete (SelectMin l a) l)) = length l) by
      (apply delete_length2; order);
  repeat (match goal with
  | |- context[SelectionSortHelp ?x (length ?x)] =>
    change (SelectionSortHelp ?l (length ?l)) with (SelectionSort l)
  | H: context[SelectionSortHelp ?x (length ?x)] |- _ =>
    change (SelectionSortHelp ?l (length ?l)) with (SelectionSort l) in H
  | |- LocallySorted le (SelectMin ?l ?x :: _) =>
    apply LocallySorted_hd_relation; intros
  | |- SelectMin ?l ?a <= ?x =>
    apply SelectMin_is_min
  | H: length ?x = length ?l |- context[length l] =>
    rewrite <- H
  | H: length ?x = length ?l |- _ =>
    try match goal with
    | H2: In ?t (SelectionSortHelp x (length l)) |- _ =>
      rewrite <- H in H2
    end
  end; auto).
  - apply Permutation_in with (l' := l) in H0; simpl; auto.
  - apply Permutation_in with (l' := (a::delete (SelectMin l a) l)) in H2; simpl; auto.
    simpl in H2; intuition. apply In_delete in H3. auto.
  - apply IHn. rewrite H0. auto.
  - apply Permutation_in with (l' := (a::delete (SelectMin l a) l)) in H2; simpl; auto.
    simpl in H2; intuition. apply In_delete in H3. auto.
  - apply IHn. rewrite H0. auto.
Qed.

Lemma SelectionSort_LocallySorted: forall l,
  LocallySorted le (SelectionSort l).
Proof.
  intros. apply SelectionSort_LocallySorted_t with (n:=length l). reflexivity.
Qed.

Lemma SelectionSort_is_sorting_algo:
  is_sorting_algo le SelectionSort.
Proof.
  unfold is_sorting_algo; intros; split.
  - apply SelectionSort_Permutation.
  - apply Sorted_LocallySorted_iff. apply SelectionSort_LocallySorted.
Qed.

End SelectionSort.

(**
   An example
*)

Require Import ZArith.

Module Import ZSort := SelectionSort Z.

Example SortingExample: [2%Z; 4%Z; 4%Z; 6%Z; 8%Z] =
  (SelectionSort [4%Z; 2%Z; 8%Z; 4%Z; 6%Z]).
Proof.
  compute. reflexivity.
Qed.