(** * Stlc: The Simply Typed Lambda-Calculus *)

Require Import SF.Maps.
Require Import SF.Smallstep.
Require Import SF.Types.

(* ###################################################################### *)
(** * The Simply Typed Lambda-Calculus *)

(** The simply typed lambda-calculus (STLC) is a tiny core
    calculus embodying the key concept of _functional abstraction_,
    which shows up in pretty much every real-world programming
    language in some form (functions, procedures, methods, etc.).

    We will follow exactly the same pattern as in the previous chapter
    when formalizing this calculus (syntax, small-step semantics,
    typing rules) and its main properties (progress and preservation).
    The new technical challenges arise from the mechanisms of
    _variable binding_ and _substitution_.  It which will take some
    work to deal with these. *)

(* ###################################################################### *)
(** ** Overview *)

(** The STLC is built on some collection of _base types_:
    booleans, numbers, strings, etc.  The exact choice of base types
    doesn't matter much -- the construction of the language and its
    theoretical properties work out the same no matter what we
    choose -- so for the sake of brevity let's take just [Bool] for
    the moment.  At the end of the chapter we'll see how to add more
    base types, and in later chapters we'll enrich the pure STLC with
    other useful constructs like pairs, records, subtyping, and
    mutable state.

    Starting from boolean constants and conditionals, we add three
    things:
        - variables
        - function abstractions
        - application

    This gives us the following collection of abstract syntax
    constructors (written out first in informal BNF notation -- we'll
    formalize it below). *)
(**

       t ::= x                       variable
           | \x:T1.t2                abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional

*)

(** The [\] symbol in a function abstraction [\x:T1.t2] is generally
    written as a Greek letter "lambda" (hence the name of the
    calculus).  The variable [x] is called the _parameter_ to the
    function; the term [t2] is its _body_.  The annotation [:T1]
    specifies the type of arguments that the function can be applied
    to. *)

(** Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

      - [(\x:Bool. x) true]

        The identity function for booleans, applied to the boolean [true].

      - [\x:Bool. if x then false else true]

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true]. *)
(**
      - [\x:Bool. \y:Bool. x]

        A two-argument function that takes two booleans and returns
        the first one.  (As in Coq, a two-argument function is really
        a one-argument function whose body is also a one-argument
        function.)

      - [(\x:Bool. \y:Bool. x) false true]

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].

        As in Coq, application associates to the left -- i.e., this
        expression is parsed as [((\x:Bool. \y:Bool. x) false) true].

      - [\f:Bool->Bool. f (f true)]

        A higher-order function that takes a _function_ [f] (from
        booleans to booleans) as an argument, applies [f] to [true],
        and applies [f] again to the result.

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)]

        The same higher-order function, applied to the constantly
        [false] function. *)

(** As the last several examples show, the STLC is a language of
    _higher-order_ functions: we can write down functions that take
    other functions as arguments and/or return other functions as
    results.

    The STLC doesn't provide any primitive syntax for defining _named_
    functions -- all functions are "anonymous."  We'll see in chapter
    [MoreStlc] that it is easy to add named functions to what we've
    got -- indeed, the fundamental naming and binding mechanisms are
    exactly the same.

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**

      T ::= Bool
          | T1 -> T2

    For example:

      - [\x:Bool. false] has type [Bool->Bool]

      - [\x:Bool. x] has type [Bool->Bool]

      - [(\x:Bool. x) true] has type [Bool]

      - [\x:Bool. \y:Bool. x] has type [Bool->Bool->Bool]
                              (i.e., [Bool -> (Bool->Bool)])

      - [(\x:Bool. \y:Bool. x) false] has type [Bool->Bool]

      - [(\x:Bool. \y:Bool. x) false true] has type [Bool] *)

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

(** We begin by formalizing the syntax of the STLC. *)

Module STLC.

(* ################################### *)
(** *** Types *)

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

(* ################################### *)
(** *** Terms *)

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

(** Note that an abstraction [\x:T.t] (formally, [tabs x T t]) is
    always annotated with the type [T] of its parameter, in contrast
    to Coq (and other functional languages like ML, Haskell, etc.),
    which use _type inference_ to fill in missing annotations.  We're
    not considering type inference here. *)

(** Some examples... *)

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

(** [idB = \x:Bool. x] *)

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

(** [idBB = \x:Bool->Bool. x] *)

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

(** [idBBBB = \x:(Bool->Bool) -> (Bool->Bool). x] *)

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

(** [k = \x:Bool. \y:Bool. x] *)

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

(** [notB = \x:Bool. if x then false else true] *)

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

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)

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

(** To define the small-step semantics of STLC terms, we begin,
    as always, by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

(* ################################### *)
(** *** Values *)

(** To define the values of the STLC, we have a few cases to consider.

    First, for the boolean part of the language, the situation is
    clear: [true] and [false] are the only values.  An [if]
    expression is never a value. *)

(** Second, an application is clearly not a value: It represents a
    function being invoked on some argument, which clearly still has
    work left to do. *)

(** Third, for abstractions, we have a choice:

      - We can say that [\x:T. t1] is a value only when [t1] is a
        value -- i.e., only if the function's body has been
        reduced (as much as it can be without knowing what argument it
        is going to be applied to).

      - Or we can say that [\x:T. t1] is always a value, no matter
        whether [t1] is one or not -- in other words, we can say that
        reduction stops at abstractions.

    Coq, in its built-in functional programming langauge Gallina,
    makes the first choice -- for example,

         Compute (fun x:bool => 3 + 4)

    yields [fun x:bool => 7].

    Most real-world functional programming languages make the second
    choice -- reduction of a function's body only begins when the
    function is actually applied to an argument.  We also make the
    second choice here. *)

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

Hint Constructors value.

(** Finally, we must consider what constitutes a _complete_ program.

    Intuitively, a "complete program" must not refer to any undefined
    variables.  We'll see shortly how to define the _free_ variables
    in a STLC term.  A complete program is _closed_ -- that is, it
    contains no free variables.

    Having made the choice not to reduce under abstractions, we don't
    need to worry about whether variables are values, since we'll
    always be reducing programs "from the outside in," and that means
    the [step] relation will always be working with closed terms.  *)

(* ###################################################################### *)
(** *** Substitution *)

(** Now we come to the heart of the STLC: the operation of
    substituting one term for a variable in another term.  This
    operation is used below to define the operational semantics of
    function application, where we will need to substitute the
    argument term for the function parameter in the function's body.
    For example, we reduce

       (\x:Bool. if x then true else x) false

    to

       if false then true else false

    by substituting [false] for the parameter [x] in the body of the
    function.

    In general, we need to be able to substitute some given term [s]
    for occurrences of some variable [x] in another term [t].  In
    informal discussions, this is usually written [ [x:=s]t ] and
    pronounced "substitute [x] with [s] in [t]." *)

(** Here are some examples:

      - [[x:=true] (if x then x else false)]
           yields [if true then true else false]

      - [[x:=true] x] yields [true]

      - [[x:=true] (if x then x else y)] yields [if true then true else y]

      - [[x:=true] y] yields [y]

      - [[x:=true] false] yields [false] (vacuous substitution)

      - [[x:=true] (\y:Bool. if y then x else false)]
           yields [\y:Bool. if y then true else false]

      - [[x:=true] (\y:Bool. x)] yields [\y:Bool. true]

      - [[x:=true] (\y:Bool. y)] yields [\y:Bool. y]

      - [[x:=true] (\x:Bool. x)] yields [\x:Bool. x]

    The last example is very important: substituting [x] with [true] in
    [\x:Bool. x] does _not_ yield [\x:Bool. true]!  The reason for
    this is that the [x] in the body of [\x:Bool. x] is _bound_ by the
    abstraction: it is a new, local name that just happens to be
    spelled the same as some global name [x]. *)

(** Here is the definition, informally...

       [x:=s]x               = s
       [x:=s]y               = y                      if x <> y
       [x:=s](\x:T11. t12)   = \x:T11. t12
       [x:=s](\y:T11. t12)   = \y:T11. [x:=s]t12      if x <> y
       [x:=s](t1 t2)         = ([x:=s]t1) ([x:=s]t2)
       [x:=s]true            = true
       [x:=s]false           = false
       [x:=s](if t1 then t2 else t3) =
                       if [x:=s]t1 then [x:=s]t2 else [x:=s]t3

*)

(** ... and formally: *)

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

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

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

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on closed terms (i.e., terms like [\x:Bool. x] that include
    binders for all of the variables they mention), we can avoid this
    extra complexity here, but it must be dealt with when formalizing
    richer languages. *)

(** **** Exercise: 3 stars (substi)  *)
(** The definition that we gave above uses Coq's [Fixpoint] facility
    to define substitution as a _function_.  Suppose, instead, we
    wanted to define substitution as an inductive _relation_ [substi].
    We've begun the definition by providing the [Inductive] header and
    one of the constructors; your job is to fill in the rest of the
    constructors and prove that the relation you've defined coincides
    with the function given above. *)

Inductive substi (s:tm) (x:id) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  (* FILL IN HERE *)
.

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################### *)
(** *** Reduction *)

(** The small-step reduction relation for STLC now follows the
    same pattern as the ones we have seen before.  Intuitively, to
    reduce a function application, we first reduce its left-hand
    side (the function) until it becomes an abstraction; then we
    reduce its right-hand side (the argument) until it is also a
    value; and finally we substitute the argument for the bound
    variable in the body of the abstraction.  This last rule, written
    informally as

      (\x:T.t12) v2 ==> [x:=v2]t12

    is traditionally called "beta-reduction". *)

(**
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'

*)
(** ... plus the usual rules for booleans:

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

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

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

*)

(** Formally: *)

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

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

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

Hint Constructors step.

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

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

(** Example:

      ((\x:Bool->Bool. x) (\x:Bool. x)) ==>* (\x:Bool. x)

    i.e.,

      (idBB idB) ==>* idB

*)

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

(** Example:

      ((\x:Bool->Bool. x) ((\x:Bool->Bool. x) (\x:Bool. x)))
            ==>* (\x:Bool. x)

    i.e.,

      (idBB (idBB idB)) ==>* idB.

*)

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

(** Example:

      ((\x:Bool->Bool. x) (\x:Bool. if x then false
                                    else true)) true)
            ==>* false

    i.e.,

       ((idBB notB) ttrue) ==>* tfalse.

*)

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

(** Example:

((\x:Bool -> Bool. x) ((\x:Bool. if x then false
                               else true) true))
      ==>* false

i.e.,

  (idBB (notB ttrue)) ==>* tfalse.

*)

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

(** We can use the [normalize] tactic defined in the [Types] chapter
    to simplify these proofs. *)

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

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

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

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

(** **** Exercise: 2 stars (step_example3)  *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example5 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma step_example5_with_normalize :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

(** Next we consider the typing relation of the STLC. *)

(* ################################### *)
(** *** Contexts *)

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place _typing judgment_, informally
    written [Gamma |- t \in T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition context := partial_map ty.

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

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x \in T

                      Gamma , x:T11 |- t12 \in T12
                     ----------------------------                       (T_Abs)
                     Gamma |- \x:T11.t12 \in T11->T12

                        Gamma |- t1 \in T11->T12
                          Gamma |- t2 \in T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 \in T12

                         --------------------                          (T_True)
                         Gamma |- true \in Bool

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

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

    We can read the three-place relation [Gamma |- t \in T] as:
    "to the term [t] we can assign the type [T] using as types for
    the free variables of [t] the ones specified in the context
    [Gamma]." *)

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

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

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

Hint Constructors has_type.

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

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

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

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

(** Another example:

       empty |- \x:A. \y:A->A. y (y x))
             \in A -> (A->A) -> A.

*)

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

(** **** Exercise: 2 stars, optional (typing_example_2_full)  *)
(** Prove the same result without using [auto], [eauto], or
    [eapply] (or [...]). *)

Example typing_example_2_full :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (typing_example_3)  *)
(** Formally prove the following typing derivation holds: *)
(**
       empty |- \x:Bool->B. \y:Bool->Bool. \z:Bool.
                   y (x z)
             \in T.

*)

Example typing_example_3 :
  exists T,
    empty |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,

    ~ exists T,
        empty |- \x:Bool. \y:Bool, x y : T.

*)

Example typing_nonexample_1 :
  ~ exists T,
      empty |-
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y)))) \in
        T.
Proof.
  intros Hc. inversion Hc.
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  inversion H1.  Qed.

(** **** Exercise: 3 stars, optional (typing_nonexample_3)  *)
(** Another nonexample:

    ~ (exists S, exists T,
          empty |- \x:S. x x \in T).

*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |-
          (tabs x S
             (tapp (tvar x) (tvar x))) \in
          T).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

End STLC.

(** $Date: 2016-05-26 17:51:14 -0400 (Thu, 26 May 2016) $ *)


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *)

Require Import Raux Defs Generic_fmt Float_prop Digits Bracket.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Fcalc_div.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

(** Computes a mantissa of precision p, the corresponding exponent,
    and the position with respect to the real quotient of the
    input floating-point numbers.

The algorithm performs the following steps:
- Shift dividend mantissa so that it has at least p2 + p digits.
- Perform the Euclidean division.
- Compute the position according to the division remainder.

Complexity is fine as long as p1 <= 2p and p2 <= p.
*)

Lemma mag_div_F2R :
  forall m1 e1 m2 e2,
  (0 < m1)%Z -> (0 < m2)%Z ->
  let e := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in
  (e <= mag beta (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) <= e + 1)%Z.
Proof.
intros m1 e1 m2 e2 Hm1 Hm2.
rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
rewrite <- (mag_F2R_Zdigits beta m2 e2) by now apply Zgt_not_eq.
apply mag_div.
now apply F2R_neq_0, Zgt_not_eq.
now apply F2R_neq_0, Zgt_not_eq.
Qed.

Definition Fdiv_core m1 e1 m2 e2 e :=
  let (m1', m2') :=
    if Zle_bool e (e1 - e2)%Z
    then (m1 * Zpower beta (e1 - e2 - e), m2)%Z
    else (m1, m2 * Zpower beta (e - (e1 - e2)))%Z in
  let '(q, r) :=  Z.div_eucl m1' m2' in
  (q, new_location m2' r loc_Exact).

Theorem Fdiv_core_correct :
  forall m1 e1 m2 e2 e,
  (0 < m1)%Z -> (0 < m2)%Z ->
  let '(m, l) := Fdiv_core m1 e1 m2 e2 e in
  inbetween_float beta m e (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) l.
Proof.
intros m1 e1 m2 e2 e Hm1 Hm2.
unfold Fdiv_core.
match goal with |- context [if ?b then ?b1 else ?b2] => set (m12 := if b then b1 else b2) end.
case_eq m12 ; intros m1' m2' Hm.
assert ((F2R (Float beta m1 e1) / F2R (Float beta m2 e2) = IZR m1' / IZR m2' * bpow e)%R /\ (0 < m2')%Z) as [Hf Hm2'].
{ unfold F2R, Zminus ; simpl.
  destruct (Zle_bool e (e1 - e2)) eqn:He' ; injection Hm ; intros ; subst.
  - split ; try easy.
    apply Zle_bool_imp_le in He'.
    rewrite mult_IZR, IZR_Zpower by omega.
    unfold Zminus ; rewrite 2!bpow_plus, 2!bpow_opp.
    field.
    repeat split ; try apply Rgt_not_eq, bpow_gt_0.
    now apply IZR_neq, Zgt_not_eq.
  - apply Z.leb_gt in He'.
    split ; cycle 1.
    { apply Z.mul_pos_pos with (1 := Hm2).
      apply Zpower_gt_0 ; omega. }
    rewrite mult_IZR, IZR_Zpower by omega.
    unfold Zminus ; rewrite bpow_plus, bpow_opp, bpow_plus, bpow_opp.
    field.
    repeat split ; try apply Rgt_not_eq, bpow_gt_0.
    now apply IZR_neq, Zgt_not_eq. }
clearbody m12 ; clear Hm Hm1 Hm2.
generalize (Z_div_mod m1' m2' (Z.lt_gt _ _ Hm2')).
destruct (Z.div_eucl m1' m2') as (q, r).
intros (Hq, Hr).
rewrite Hf.
unfold inbetween_float, F2R. simpl.
rewrite Hq, 2!plus_IZR, mult_IZR.
apply inbetween_mult_compat.
  apply bpow_gt_0.
destruct (Z_lt_le_dec 1 m2') as [Hm2''|Hm2''].
- replace 1%R with (IZR m2' * /IZR m2')%R.
  apply new_location_correct ; try easy.
  apply Rinv_0_lt_compat.
  now apply IZR_lt.
  constructor.
  field.
  now apply IZR_neq, Zgt_not_eq.
  field.
  now apply IZR_neq, Zgt_not_eq.
- assert (r = 0 /\ m2' = 1)%Z as [-> ->] by (clear -Hr Hm2'' ; omega).
  unfold Rdiv.
  rewrite Rmult_1_l, Rplus_0_r, Rinv_1, Rmult_1_r.
  now constructor.
Qed.

Definition Fdiv (x y : float beta) :=
  let (m1, e1) := x in
  let (m2, e2) := y in
  let e' := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in
  let e := Z.min (Z.min (fexp e') (fexp (e' + 1))) (e1 - e2) in
  let '(m, l) := Fdiv_core m1 e1 m2 e2 e in
  (m, e, l).

Theorem Fdiv_correct :
  forall x y,
  (0 < F2R x)%R -> (0 < F2R y)%R ->
  let '(m, e, l) := Fdiv x y in
  (e <= cexp beta fexp (F2R x / F2R y))%Z /\
  inbetween_float beta m e (F2R x / F2R y) l.
Proof.
intros [m1 e1] [m2 e2] Hm1 Hm2.
apply gt_0_F2R in Hm1.
apply gt_0_F2R in Hm2.
unfold Fdiv.
generalize (mag_div_F2R m1 e1 m2 e2 Hm1 Hm2).
set (e := Zminus _ _).
set (e' := Z.min (Z.min (fexp e) (fexp (e + 1))) (e1 - e2)).
intros [H1 H2].
generalize (Fdiv_core_correct m1 e1 m2 e2 e' Hm1 Hm2).
destruct Fdiv_core as [m' l].
apply conj.
apply Z.le_trans with (1 := Z.le_min_l _ _).
unfold cexp.
destruct (Zle_lt_or_eq _ _ H1) as [H|H].
- replace (fexp (mag _ _)) with (fexp (e + 1)).
  apply Z.le_min_r.
  clear -H1 H2 H ; apply f_equal ; omega.
- replace (fexp (mag _ _)) with (fexp e).
  apply Z.le_min_l.
  clear -H1 H2 H ; apply f_equal ; omega.
Qed.

End Fcalc_div.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** Basic operations on floats: alignment, addition, multiplication *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_float_prop.

Section Float_ops.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Definition Falign (f1 f2 : float beta) :=
  let '(Float _ m1 e1) := f1 in
  let '(Float _ m2 e2) := f2 in
  if Zle_bool e1 e2
  then (m1, (m2 * Zpower beta (e2 - e1))%Z, e1)
  else ((m1 * Zpower beta (e1 - e2))%Z, m2, e2).

Theorem Falign_spec :
  forall f1 f2 : float beta,
  let '(m1, m2, e) := Falign f1 f2 in
  F2R f1 = F2R (Float beta m1 e) /\ F2R f2 = F2R (Float beta m2 e).
Proof.
unfold Falign.
intros (m1, e1) (m2, e2).
generalize (Zle_cases e1 e2).
case (Zle_bool e1 e2) ; intros He ; split ; trivial.
now rewrite <- F2R_change_exp.
rewrite <- F2R_change_exp.
apply refl_equal.
omega.
Qed.

Theorem Falign_spec_exp:
  forall f1 f2 : float beta,
  snd (Falign f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros (m1,e1) (m2,e2).
unfold Falign; simpl.
generalize (Zle_cases e1 e2);case (Zle_bool e1 e2); intros He.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
Qed.

Definition Fopp (f1: float beta) :=
  let '(Float _ m1 e1) := f1 in
  Float beta (-m1)%Z e1.

Theorem F2R_opp :
  forall f1 : float beta,
  (F2R (Fopp f1) = -F2R f1)%R.
intros (m1,e1).
apply F2R_Zopp.
Qed.

Definition Fabs (f1: float beta) :=
  let '(Float _ m1 e1) := f1 in
  Float beta (Zabs m1)%Z e1.

Theorem F2R_abs :
  forall f1 : float beta,
  (F2R (Fabs f1) = Rabs (F2R f1))%R.
intros (m1,e1).
apply F2R_Zabs.
Qed.

Definition Fplus (f1 f2 : float beta) :=
  let '(m1, m2 ,e) := Falign f1 f2 in
  Float beta (m1 + m2) e.

Theorem F2R_plus :
  forall f1 f2 : float beta,
  F2R (Fplus f1 f2) = (F2R f1 + F2R f2)%R.
Proof.
intros f1 f2.
unfold Fplus.
generalize (Falign_spec f1 f2).
destruct (Falign f1 f2) as ((m1, m2), e).
intros (H1, H2).
rewrite H1, H2.
unfold F2R. simpl.
rewrite Z2R_plus.
apply Rmult_plus_distr_r.
Qed.

Theorem Fplus_same_exp :
  forall m1 m2 e,
  Fplus (Float beta m1 e) (Float beta m2 e) = Float beta (m1 + m2) e.
Proof.
intros m1 m2 e.
unfold Fplus.
simpl.
now rewrite Zle_bool_refl, Zminus_diag, Zmult_1_r.
Qed.

Theorem Fexp_Fplus :
  forall f1 f2 : float beta,
  Fexp (Fplus f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros f1 f2.
unfold Fplus.
rewrite <- Falign_spec_exp.
now destruct (Falign f1 f2) as ((p,q),e).
Qed.

Definition Fminus (f1 f2 : float beta) :=
  Fplus f1 (Fopp f2).

Theorem F2R_minus :
  forall f1 f2 : float beta,
  F2R (Fminus f1 f2) = (F2R f1 - F2R f2)%R.
Proof.
intros f1 f2; unfold Fminus.
rewrite F2R_plus, F2R_opp.
ring.
Qed.

Theorem Fminus_same_exp :
  forall m1 m2 e,
  Fminus (Float beta m1 e) (Float beta m2 e) = Float beta (m1 - m2) e.
Proof.
intros m1 m2 e.
unfold Fminus.
apply Fplus_same_exp.
Qed.

Definition Fmult (f1 f2 : float beta) :=
  let '(Float _ m1 e1) := f1 in
  let '(Float _ m2 e2) := f2 in
  Float beta (m1 * m2) (e1 + e2).

Theorem F2R_mult :
  forall f1 f2 : float beta,
  F2R (Fmult f1 f2) = (F2R f1 * F2R f2)%R.
Proof.
intros (m1, e1) (m2, e2).
unfold Fmult, F2R. simpl.
rewrite Z2R_mult, bpow_plus.
ring.
Qed.

End Float_ops.


(*|
######################################################
Matching expression context under ``forall`` with Ltac
######################################################

:Link: https://stackoverflow.com/q/45389615
|*)

(*|
Question
********

Say I have the following definitions in Coq:
|*)

Inductive Compare := Lt | Eq | Gt.

Fixpoint compare (x y : nat) : Compare :=
  match x, y with
  | 0, 0   => Eq
  | 0, S _ => Lt
  | S _, 0 => Gt
  | S x', S y' => compare x' y'
  end.

(*| Now consider this lemma: |*)

Lemma foo : forall (x : nat),
    (forall z, match compare x z with
               | Lt => False
               | Eq => False
               | Gt => False
               end) -> nat -> False.
Proof.
  intros x H y.

(*| At this point proof state looks like this: |*)

  Show. (* .unfold .messages *)

(*|
I'd like to write Ltac ``match goal`` that will detect that:

a) there is a hypothesis ``x : nat`` that is used as an argument to
   ``compare`` somewhere inside a quantified hypothesis ``H``
b) and there is some other hypothesis of type ``nat`` - namely ``y`` -
   that can be used to specialize the quantified hypothesis.
c) and once we have those two things specialize ``H`` to ``y``

I tried doing it like this:

.. code-block:: coq

    match goal with
    | [ X : nat, Y : nat, H : forall (z : nat), context[compare X z] |- _ ] =>
        specialize (H Y)
    end.

But there are at least two things that are wrong with this code:

1. Using ``context`` under a ``forall`` seems disallowed.
2. I can't figure out a correct way to pass ``X`` as argument to
   ``compare`` in a way that it is recognized as something that exists
   as a hypothesis.
|*)

(*|
Answer (Yves)
*************

If you want to check that ``X`` occurs in the quantified hypothesis
``H``, it suffices to check that it occurs in ``H`` after it is
instantiated with any value that does not contain ``X``. For instance,
you can instantiate ``H`` with ``Y`` by simply writing the application
of ``H`` as a function to ``Y``. Here is my proposal:
|*)

  match goal with
  | X : nat, H : _, Y : nat |- _ =>
      match type of (H Y) with
      | context[X] => specialize (H Y)
      end
  end.

(*|
This Ltac text really checks that ``H`` is a function. If you want to
be more precise and state that ``H`` should really be a universal
quantification (or a product type), then you can check that the type
of ``(H Y)`` also contains ``Y``, as in the following fragment:
|*)

  Undo. (* .none *)
  match goal with
  | X : nat, H : _, Y : nat |- _ =>
      match type of (H Y) with
      | context[X] =>
          match type of (H Y) with
          | context[Y] => specialize (H Y)
          end
      end
  end.

(*|
----

**Q:** Can you explain the meaning of ``match type``? Is this
documented anywhere in Coq manual?

**A:** Here you have the combination of two constructs of the Ltac
language. ``match ... with`` and ``type of``. If you write ``match H
with`` you only look at the symbol ``H``, on the other hand, if you
want to observe the hypothesis statement, you have to look at its
type. This is documented in section 9 of the manual.
|*)

(*|
Answer (Daniel Schoepe)
***********************

This doesn't quite do what you are asking for, but it's somewhat
close:
|*)

  Undo. (* .none *)
  match goal with
  | [ X : nat, Y : nat, H : context[compare ?a _] |- _ ] =>
      match type of H with
      | forall (z : nat), _ =>
          match a with
          | X => specialize (H Y)
          end
      end
  end.

(*|
However, this does not check that the second argument to ``compare``
matches the ``z`` that is bound by the ``forall``.
|*)


Require Import CSPEC.
Require Import String.
Require Import Equalities.
Require Import Relations.Relation_Operators.
Require Import RelationClasses.
Require Import Morphisms.
Require Import Sumbool.
Require Import ProofIrrelevance.

Import ListNotations.
Open Scope string.

(** Declarative spec for a FS interface with concurrent operations, modeled
 after POCS notes.  The file system is represented as set of links.  To allow
 for concurrent operations a directory may contain a link with the same name
 twice, but for different nodes.  For example, we model a rename as a link
 followed by an unlink.  Thus, a lookup after link and before unlink may observe
 a duplicate name, but each name has a different node. Similarly, there may be
 several ".." entries pointing to different parents. *)

(** Data types *)

Inductive Node :=
| DirNode : forall (dirnum : nat), Node
| FileNode : forall (filenum : nat), Node
| SymlinkNode : forall (target : list string), Node.

Record Link := mkLink {
  LinkFrom : nat;   (* Always a DirNode *)
  LinkTo : Node;
  LinkName : string
}.

Instance Node_equal_dec : EqualDec Node.
Proof.
  unfold EqualDec.
  decide equality;
    match goal with
    | [ |- {?x = ?y} + {_} ] =>
      destruct (x == y); eauto
    end.
Defined.

Lemma Link_equal_dec : EqualDec Link.
  unfold EqualDec.
  decide equality;
    match goal with
    | [ |- {?x = ?y} + {_} ] =>
      destruct (x == y); eauto
    end.
Defined.

Instance Node_Ordering : Ordering Node.
Proof.
  eapply (injection_Ordering (nat + nat + list string)).
  typeclasses eauto.
  unshelve econstructor; intros.
  destruct H; [ left; left | left; right | right ]; eauto.
  destruct x, y; simpl in *; congruence.
Defined.

Instance Link_Ordering : Ordering Link.
Proof.
  eapply (injection_Ordering (nat * Node * string)%type).
  typeclasses eauto.

  unshelve econstructor; intros.
  exact (H.(LinkFrom), H.(LinkTo), H.(LinkName)).
  destruct x, y; simpl in *; congruence.
Defined.

Definition eq_string (s1 s2 : string) :=
  if string_dec s1 s2 then true else false.

Definition proper_name n := n <> "." /\ n <> "..".
Definition proper_link l := proper_name (LinkName l).
Definition proper_links g := FSet.For_all proper_link g.

Inductive PFSet: forall ls, Prop :=
| LSProperNames: forall ls,
    proper_links ls ->
    PFSet ls.

Definition File := string.
Definition Files := list File.

Record FS := mkFS {
  FSRoot : nat;     (* root DirNode *)
  FSLinks : FSet.t Link;
  FSFiles : Files;  (* [filenum]s point into this list *)
}.

Definition Pathname := list string.

(** [path_evaluates] is used to specify lookup *)

Inductive valid_link : forall (fs : FS) (dir : nat) (name : string) (target : Node), Prop :=
| ValidLink : forall fs dir name target,
    FSet.In (mkLink dir target name) (FSLinks fs) ->
    valid_link fs dir name target
| ValidDot : forall fs dir,
    valid_link fs dir "." (DirNode dir)
| ValidDotDot : forall fs dir name parent,
    FSet.In (mkLink parent (DirNode dir) name) (FSLinks fs) ->
    valid_link fs dir ".." (DirNode parent)
| ValidDotDotRoot : forall fs dir,
    dir = FSRoot fs ->
    valid_link fs dir ".." (DirNode dir).

Inductive path_evaluates : forall (fs : FS) (start : Node) (pn : Pathname) (target : Node), Prop :=
| PathEvalEmpty : forall fs start,
  path_evaluates fs start nil start
| PathEvalFileLink : forall fs startdir name inum,
  valid_link fs startdir name (FileNode inum)  ->
  path_evaluates fs (DirNode startdir) ([name]) (FileNode inum)
| PathEvalDirLink : forall fs startdir name inum pn namenode,
  valid_link fs startdir name (DirNode inum) ->
  path_evaluates fs (DirNode inum) pn namenode ->
  path_evaluates fs (DirNode startdir) (name :: pn) namenode
| PathEvalSymlink : forall fs startdir name sympath symtarget pn target,
  valid_link fs startdir name (SymlinkNode sympath) ->
  path_evaluates fs (DirNode startdir) sympath symtarget ->
  path_evaluates fs symtarget pn target ->
  path_evaluates fs (DirNode startdir) (name :: pn) target.

Definition path_eval_root (fs : FS) (pn : Pathname) (target : Node) : Prop :=
  path_evaluates fs (DirNode (FSRoot fs)) pn target.

Hint Constructors valid_link : model.
Hint Constructors path_evaluates : model.

Lemma path_evaluates_cons': forall fs startdir name pn node,
    path_evaluates fs startdir (name::pn) node ->
    exists node',
      path_evaluates fs startdir [name] node' /\
      path_evaluates fs node' pn node.
Proof.
  intros.
  inversion H; subst; eexists; eauto with model.
Qed.

Lemma path_evaluates_cons: forall fs startdir name pn node node',
    path_evaluates fs (DirNode startdir) [name] node' ->
    path_evaluates fs node' pn node ->
    exists node'',
      path_evaluates fs (DirNode startdir) (name::pn) node''.
Proof.
  intros.
  inversion H; subst; clear H.
  - eexists.
    inversion H0; subst; clear H0.
    constructor; eauto.
  - eexists.
    eapply PathEvalDirLink; eauto.
    inversion H7; subst; clear H7.
    eauto.
  - eexists.
    inversion H8; subst; clear H8.
    eapply PathEvalSymlink; eauto.
Qed.

Definition does_not_exist (fs : FS) dirnum name :=
  ~ exists n, FSet.In (mkLink dirnum n name) (FSLinks fs).

Definition file_handle_unused (fs : FS) h :=
  ~ exists d name, FSet.In (mkLink d (FileNode h) name) (FSLinks fs).

Definition file_handle_valid (fs : FS) h :=
  h < Datatypes.length (FSFiles fs).

Definition upd_file h data (fs : FS) :=
  mkFS (FSRoot fs) (FSLinks fs) (list_upd (FSFiles fs) h data).

Definition add_link dir node name (fs : FS) :=
  mkFS (FSRoot fs) (FSet.add (mkLink dir node name) (FSLinks fs)) (FSFiles fs).

Definition del_link dir node name (fs : FS) :=
  mkFS (FSRoot fs) (FSet.remove (mkLink dir node name) (FSLinks fs)) (FSFiles fs).

Definition create_file dir h name (fs : FS) :=
  add_link dir (FileNode h) name (upd_file h "" fs).

Definition create_file_write dir h name data (fs : FS) :=
  add_link dir (FileNode h) name (upd_file h data fs).

Definition valid_dir dir (fs : FS) :=
  exists pn, path_eval_root fs pn (DirNode dir).

Definition match_readdir from l :=
  beq_nat from (LinkFrom l).

Definition readdir fs dir :=
  FSet.filter (match_readdir dir) (FSLinks fs).

Definition readdir_names fs dir :=
  map LinkName (FSet.elements (readdir fs dir)).

(* if pn exists, then it is unique *)
Definition maybe_unique_pathname (fs : FS) startdir pn :=
  forall node node',
    path_evaluates fs startdir pn node ->
    path_evaluates fs startdir pn node' ->
    node' = node.

Definition maybe_unique_pathname_root (fs : FS) pn :=
  forall node node',
    path_eval_root fs pn node ->
    path_eval_root fs pn node' ->
    node' = node.

(* pn exists and it is unique. *)
Definition unique_pathname (fs : FS) startdir pn :=
  exists node,
    path_evaluates fs startdir pn node /\
    forall node',
      path_evaluates fs startdir pn node' -> node' = node.

Definition unique_pathname_root (fs : FS) pn :=
  exists node,
    path_eval_root fs pn node /\
    forall node',
      path_eval_root fs pn node' -> node' = node.

Lemma unique_pathname_path_evaluates_eq: forall fs startdir pn node node',
    unique_pathname fs startdir pn ->
    path_evaluates fs startdir pn node ->
    path_evaluates fs startdir pn node' ->
    node = node'.
Proof.
  intros.
  unfold unique_pathname in *.
  deex.
  specialize (H2 node H0) as H2x; subst.
  specialize (H2 node' H1) as H2x; subst.
  reflexivity.
Qed.

Lemma unique_pathname_valid_link_eq: forall fs dirnum name inum inum',
    unique_pathname fs (DirNode dirnum) [name] ->
    valid_link fs dirnum name (DirNode inum) ->
    valid_link fs dirnum name (DirNode inum') ->
    DirNode inum = DirNode inum'.
Proof.
  intros.
  unfold unique_pathname in *.
  deex.
  specialize (H2 (DirNode inum)) as H2x; subst.
  specialize (H2 (DirNode inum')) as H2y; subst.
  destruct H2x.
  econstructor.
  eapply H0.
  constructor.
  destruct H2y.
  econstructor.
  eapply H1.
  constructor.
  reflexivity.
Qed.

Lemma unique_pathname_path_evaluates_cons_eq: forall fs startdir name pn' node node' node'',
    path_evaluates fs (DirNode startdir) [name] node' ->
    path_evaluates fs node' pn' node ->
    unique_pathname fs (DirNode startdir) [name] ->
    unique_pathname fs node' pn' ->
    path_evaluates fs (DirNode startdir) (name :: pn') node'' ->
    node = node''.
Proof.
  intros.
  eapply path_evaluates_cons' in H3 as Hcons.
  deex.
  assert (node'0 = node').
  eapply unique_pathname_path_evaluates_eq in H; eauto.
  subst.
  assert (node = node'').
  eapply unique_pathname_path_evaluates_eq in H2; eauto.
  subst.
  reflexivity.
Qed.

(* Proper pathname: no symlinks, no dots, no dot-dots *)
Inductive proper_pathname : forall (fs : FS) (startdir : nat) (pn : Pathname), Prop :=
| ProperPathNil : forall fs startdir,
  proper_pathname fs startdir []
| ProperPathCons : forall fs startdir name namedir pn,
  proper_name name ->
  valid_link fs startdir name (DirNode namedir) ->
  proper_pathname fs namedir pn ->
  proper_pathname fs startdir (name :: pn)
| ProperPathConsMissing : forall fs startdir name pn,
  proper_name name ->
  (~ exists target, valid_link fs startdir name target) ->
  proper_pathname fs startdir (name :: pn).

Definition proper_pathname_root fs pn :=
  proper_pathname fs (FSRoot fs) pn.

(* A stronger version of unique_pathname, requiring all intermediate nodes match *)
Inductive stable_pathname : forall (fs: FS) (startdir: Node) (pn: Pathname), Prop :=
| StablePathNil: forall fs startdir, stable_pathname fs (DirNode startdir) []
| StablePathCons: forall fs startdir name pn' node node',
    path_evaluates fs (DirNode startdir) [name] node' ->
    path_evaluates fs node' pn' node ->
    unique_pathname fs (DirNode startdir) [name] ->
    unique_pathname fs node' pn' ->
    stable_pathname fs (DirNode startdir) (name::pn').

(* sanity check *)
Lemma stable_pathname_unique_pathname: forall fs startdir pn,
    stable_pathname fs startdir pn ->
    unique_pathname fs startdir pn.
Proof.
  intros.
  inversion H; subst; clear H.
  - eexists.
    split.
    constructor.
    intros.
    inversion H; auto.
  - unfold unique_pathname.
    eapply path_evaluates_cons in H1 as Hcons; eauto.
    deex.
    eapply unique_pathname_path_evaluates_cons_eq in H as Hx; eauto.
    subst.
    exists node''.
    split; eauto.
    intros.
    eapply unique_pathname_path_evaluates_cons_eq in H4 as Hx; eauto.
Qed.

Definition unique_dirent (fs : FS) dir name :=
  forall target target0,
    valid_link fs dir name target ->
    valid_link fs dir name target0 ->
    target0 = target.

Definition unique_dirents (fs : FS) :=
  forall dir name target target0,
    valid_link fs dir name target ->
    valid_link fs dir name target0 ->
    target0 = target.

Lemma unique_dirent_link_eq: forall fs startdir name node node',
    unique_dirent fs startdir name ->
    valid_link fs startdir name node ->
    valid_link fs startdir name node' ->
    node = node'.
Proof.
  intros.
  edestruct H; eauto.
Qed.

Definition fs_invariant (fs : FS) := proper_links (FSLinks fs).

Lemma fs_proper_name: forall fs startdir node name,
    fs_invariant fs ->
    FSet.In (mkLink startdir node name) (FSLinks fs) ->
    proper_name name.
Proof.
  intros.
  unfold fs_invariant in *.
  unfold proper_links in *.
  eapply FSet.For_all_in in H; eauto.
  auto.
Qed.

Lemma fs_invariant_add_link: forall fs dirnum name node,
    fs_invariant fs ->
    proper_name name ->
    does_not_exist fs dirnum name ->
    fs_invariant (add_link dirnum node name fs).
Proof.
  intros.
  unfold fs_invariant in *.
  unfold proper_links in *.
  unfold proper_link in *.
  eapply FSet.add_forall; eauto.
Qed.

Hint Resolve FSet.add_incr.

Lemma path_evaluates_add_link : forall fs startdir dirnum name dirpn n node,
  path_evaluates fs startdir dirpn node ->
  path_evaluates (add_link dirnum n name fs) startdir dirpn node.
Proof.
  unfold add_link in *.
  simpl in *.
  intros.
  induction H.
  + constructor.
  + eapply PathEvalFileLink; eauto.
    edestruct H; eauto with model.
    - constructor; simpl; auto.
    - eapply ValidDotDot.
      eapply FSet.add_incr; eauto.
  + eapply PathEvalDirLink; eauto.
    edestruct H; eauto with model.
    - constructor; simpl; eauto.
    - eapply ValidDotDot.
      apply FSet.add_incr; eauto.
  + inversion H; subst.
    eapply PathEvalSymlink; simpl; eauto.
    constructor.
    apply FSet.add_incr; eauto.
Qed.

Lemma valid_link_does_not_exist: forall fs dirnum name node,
    proper_name name ->
    valid_link fs dirnum name node ->
    does_not_exist fs dirnum name ->
    False.
Proof.
  intros.
  inversion H0; subst; clear H0.
  - destruct H1; eexists; eauto.
  - destruct H; congruence.
  - destruct H; congruence.
  - destruct H; congruence.
Qed.

Lemma path_evaluates_does_not_exist: forall fs dirnum name,
    proper_name name ->
    path_evaluates fs (DirNode dirnum) [name] (DirNode dirnum) ->
    does_not_exist fs dirnum name ->
    False.
Proof.
  intros.
  inversion H0; subst; clear H0.
  inversion H8; subst; clear H8.
  eapply valid_link_does_not_exist; eauto.
  inversion H9; subst; clear H9.
  eapply valid_link_does_not_exist; eauto.
Qed.

Lemma valid_link_add_file_link': forall fs startdir name name0 dirnum node node' inum,
    valid_link fs startdir name0 node ->
    proper_name name  ->
    does_not_exist fs dirnum name ->
    valid_link (add_link dirnum (FileNode inum) name fs) startdir name0 node' ->
    valid_link fs startdir name0 node'.
Proof.
  intros.
  inversion H2; subst; clear H2; eauto with model.
  - apply FSet.add_in' in H3; intuition eauto with model.
    inversion H2; subst; clear H2.
    exfalso; eapply valid_link_does_not_exist; eauto.
  - eapply ValidDotDot.
    apply FSet.add_in' in H3; auto.
    intuition idtac; eauto.
    inversion H2.
Qed.

Lemma path_evaluates_add_link' : forall fs startdir dirnum name dirpn finum node,
  fs_invariant fs ->
  stable_pathname fs startdir dirpn ->
  path_evaluates fs startdir dirpn (DirNode dirnum) ->
  does_not_exist fs dirnum name  ->
  proper_name name ->
  path_evaluates (add_link dirnum (FileNode finum) name fs) startdir dirpn node ->
  path_evaluates fs startdir dirpn node.
Proof.
  intros.
  remember (add_link dirnum (FileNode finum) name fs).
  generalize dependent fs; intros.
  induction H4; subst.
  - constructor.
  - eapply PathEvalFileLink; subst; eauto.
    inversion H4; subst.
    eapply fs_proper_name in H5 as H5x.
    eapply FSet.add_in' in H5.
    intuition idtac.
    + inversion H6; subst; clear H6.
      exfalso; eauto using path_evaluates_does_not_exist.
    + constructor; eauto.
    + apply fs_invariant_add_link; eauto.
  - inversion H1; subst; clear H1.
    {
      eapply PathEvalDirLink; eauto.
      eapply valid_link_add_file_link' in H4; auto.
      assert (DirNode inum0 = DirNode inum).
      {
        inversion H0; subst.
        eauto using unique_pathname_valid_link_eq.
      }
      inversion H1; subst; clear H1.
      eapply IHpath_evaluates; eauto.
      admit.
      eauto.
    }
    {
      inversion H10; subst.
      eapply fs_proper_name in H1 as Hx; eauto.
      (* stronger property on dirpn  *)
      (* xxx eapply valid_link_add_link'' in H4; eauto. *)
      exfalso. admit. (* H2 + H8 + H *)
    }
  - eapply PathEvalSymlink; eauto; subst.
    inversion H0; subst.
    (*
    - constructor.
      apply FSet.add_spec.
      eauto.
    - apply IHpath_evaluates1; eauto.
    - apply IHpath_evaluates2; eauto.
*)
Admitted.

Lemma path_eval_root_add_link : forall fs dirnum name dirpn n,
  path_eval_root fs dirpn (DirNode dirnum) ->
  path_eval_root (add_link dirnum n name fs) dirpn (DirNode dirnum).
Proof.
  intros.
  unfold path_eval_root.
  eapply path_evaluates_add_link in H; eauto.
Qed.

Hint Constructors path_evaluates.

Lemma path_evaluates_upd_file : forall fs startdir dirnum h data dirpn,
  path_evaluates fs startdir dirpn (DirNode dirnum) ->
  path_evaluates (upd_file h data fs) startdir dirpn (DirNode dirnum).
Proof.
  intros.
  unfold upd_file; simpl.
  induction H; eauto with model.
  + eapply PathEvalFileLink.
    edestruct H; eauto with model.
  + eapply PathEvalDirLink; eauto.
    destruct H; eauto with model.
  + eapply PathEvalSymlink; simpl; eauto.
    destruct H; eauto with model.
Qed.

Lemma path_eval_root_upd_file : forall fs dirnum h data dirpn,
  path_eval_root fs dirpn (DirNode dirnum) ->
  path_eval_root (upd_file h data fs) dirpn (DirNode dirnum).
Proof.
  intros.
  unfold path_eval_root in *.
  eapply path_evaluates_upd_file in H; eauto.
Qed.

Lemma path_evaluates_upd_file' : forall fs node h data dirpn startdir,
  path_evaluates (upd_file h data fs) startdir dirpn node ->
  path_evaluates fs startdir dirpn node.
Proof.
  intros.
  match goal with
  | H : path_evaluates ?fs0 ?dir0 ?pn0 ?node0 |- _ =>
    remember fs0;
    induction H; intros; subst; simpl
  end.
  + constructor.
  + eapply PathEvalFileLink; eauto.
    inversion H; clear H; subst.
    constructor. eauto.
  + eapply PathEvalDirLink; eauto.
    inversion H; clear H; subst.
    - constructor. eauto.
    - apply ValidDot.
    - eapply ValidDotDot; simpl; eauto.
    - apply ValidDotDotRoot; auto.
  + eapply PathEvalSymlink; simpl.
    inversion H; clear H; subst.
    constructor; eauto.
    eapply IHpath_evaluates1; eauto.
    apply IHpath_evaluates2; eauto.
Qed.

Lemma path_eval_root_upd_file' : forall fs node h data dirpn,
  path_eval_root (upd_file h data fs) dirpn node ->
  path_eval_root fs dirpn node.
Proof.
  intros.
  eapply path_evaluates_upd_file'; eauto.
Qed.

Lemma does_not_exist_add_link : forall fs dirnum name dirnum0 n0 name0,
  does_not_exist (add_link dirnum0 n0 name0 fs) dirnum name ->
  does_not_exist fs dirnum name.
Proof.
  intros.
  unfold does_not_exist, add_link in *.
  simpl in *.
  intro.
  destruct H.
  deex.
  eexists.
  apply FSet.add_incr; eauto.
Qed.

Lemma does_not_exist_add_link_same_dirnum : forall fs dirnum name n0 name0,
  does_not_exist fs dirnum name ->
  name <> name0 ->
  does_not_exist (add_link dirnum n0 name0 fs) dirnum name.
Proof.
  intros.
  unfold does_not_exist, add_link in *.
  simpl in *.
  intro.
  deex.
  apply FSet.add_in' in H1.
  intuition idtac.
  inversion H2; congruence.
  destruct H.
  eexists.
  apply H2.
Qed.

Lemma does_not_exist_upd_file : forall fs h data dirnum name,
  does_not_exist (upd_file h data fs) dirnum name ->
  does_not_exist fs dirnum name.
Proof.
  intros.
  unfold does_not_exist, upd_file in *.
  simpl in *; auto.
Qed.

Lemma does_not_exist_upd_file' : forall fs h data dirnum name,
  does_not_exist fs dirnum name ->
  does_not_exist (upd_file h data fs) dirnum name.
Proof.
  intros.
  unfold does_not_exist, upd_file in *.
  simpl in *; auto.
Qed.

Hint Resolve does_not_exist_add_link.
Hint Resolve does_not_exist_add_link_same_dirnum.
Hint Resolve does_not_exist_upd_file.
Hint Resolve does_not_exist_upd_file'.

Lemma file_handle_unused_upd_file : forall fs h0 data0 h,
  file_handle_unused (upd_file h0 data0 fs) h ->
  file_handle_unused fs h.
Proof.
  intros.
  unfold file_handle_unused, upd_file in *.
  simpl in *; auto.
Qed.

Lemma file_handle_unused_add_link : forall fs dirnum n name h,
  file_handle_unused (add_link dirnum n name fs) h ->
  file_handle_unused fs h.
Proof.
  intros.
  unfold file_handle_unused, add_link in *.
  simpl in *.
  intro.
  repeat deex.
  destruct H.
  repeat eexists.
  apply FSet.add_incr; eauto.
Qed.

Lemma file_handle_unused_upd_file' : forall fs h0 data0 h,
  file_handle_unused fs h ->
  file_handle_unused (upd_file h0 data0 fs) h.
Proof.
  intros.
  unfold file_handle_unused, upd_file in *.
  simpl in *; auto.
Qed.

Lemma file_handle_unused_add_link' : forall fs dirnum n name h,
  file_handle_unused fs h ->
  n <> FileNode h ->
  file_handle_unused (add_link dirnum n name fs) h.
Proof.
  intros.
  unfold file_handle_unused, add_link in *.
  simpl in *.
  intro.
  repeat deex.
  apply FSet.add_in' in H1.
  intuition idtac.
  inversion H2; congruence.
  destruct H.
  repeat eexists.
  apply H2.
Qed.

Lemma file_handle_unused_ne : forall fs dirnum v0 v1 name,
  file_handle_unused (add_link dirnum (FileNode v0) name fs) v1 ->
  FileNode v1 <> FileNode v0.
Proof.
  intros.
  unfold file_handle_unused, add_link in *.
  simpl in *.
  intro.
  destruct H.
  repeat eexists.
  rewrite H0 in *.
  apply FSet.add_in.
Qed.

Hint Resolve file_handle_unused_upd_file.
Hint Resolve file_handle_unused_add_link.
Hint Resolve file_handle_unused_add_link'.
Hint Resolve file_handle_unused_ne.

Lemma file_handle_valid_upd_file : forall fs h0 data0 h,
  file_handle_valid (upd_file h0 data0 fs) h ->
  file_handle_valid fs h.
Proof.
  intros.
  unfold file_handle_valid, file_handle_valid, upd_file in *.
  simpl in *.
  rewrite length_list_upd in H; auto.
Qed.

Lemma file_handle_valid_add_link : forall fs dirnum n name h,
  file_handle_valid (add_link dirnum n name fs) h ->
  file_handle_valid fs h.
Proof.
  intros.
  unfold file_handle_valid, file_handle_valid, add_link in *.
  simpl in *; auto.
Qed.

Lemma file_handle_valid_upd_file' : forall fs h0 data0 h,
  file_handle_valid fs h ->
  file_handle_valid (upd_file h0 data0 fs) h.
Proof.
  intros.
  unfold file_handle_valid, file_handle_valid, upd_file in *.
  simpl in *.
  rewrite length_list_upd; auto.
Qed.

Lemma file_handle_valid_add_link' : forall fs dirnum n name h,
  file_handle_valid fs h ->
  file_handle_valid (add_link dirnum n name fs) h.
Proof.
  intros.
  unfold file_handle_valid, file_handle_valid, add_link in *.
  simpl in *; auto.
Qed.

Hint Resolve file_handle_valid_upd_file.
Hint Resolve file_handle_valid_add_link.
Hint Resolve file_handle_valid_upd_file'.
Hint Resolve file_handle_valid_add_link'.

Lemma valid_link_upd_file' : forall fs h data dir name target,
  valid_link (upd_file h data fs) dir name target ->
  valid_link fs dir name target.
Proof.
  intros.
  remember (upd_file h data fs); generalize dependent fs.
  induction H; intros; subst.
  - constructor. eauto.
  - eapply ValidDot.
  - eapply ValidDotDot. eauto.
  - eapply ValidDotDotRoot. eauto.
Qed.