From Coq Require Import Bool String List Program.Equality.
From CDF Require Import Sequences.

Local Open Scope string_scope.
Local Open Scope list_scope.

(** * 7.  The functional language FUN *)

(** ** 7.1.  Syntax and semantics *)

(** The FUN language is lambda-calculus (variables, function abstractions,
    function applications) extended with Booleans:
    constants [Const true] and [Const false], and a conditional
    [Cond a ifso ifnot] (that is, [if a then ifso else ifnot]).  *)

Inductive term: Type :=
  | Var (x: string)
  | Abs (x: string) (a: term)
  | App (a1: term) (a2: term)
  | Const (b: bool)
  | Cond (a: term) (ifso: term) (ifnot: term).

(** Values are function abstractions and Boolean constants. *)

Inductive isvalue: term -> Prop :=
  | V_Abs: forall x a,
      isvalue (Abs x a)
  | V_Const: forall b,
      isvalue (Const b).

(** [subst a x c] is the term [a] where the term [c] is substituted
    for variable [x], also written [a [x ← c]] in the lecture. *)

(** The substitution below is wrong in general, because it can capture
    variables that are free in [c].  We shall use it only when
    [c] is a closed term, without free variables.  This corresponds
    to the reduction of whole programs, without free variables.
    The type system in section 7.2 guarantees that this is the case. *)

Fixpoint subst (a: term) (x: string) (c: term) : term :=
  match a with
  | Var y => if string_dec x y then c else Var y
  | Abs y a => if string_dec x y then Abs y a else Abs y (subst a x c)
  | App a1 a2 => App (subst a1 x c) (subst a2 x c)
  | Const b => Const b
  | Cond a ifso ifnot => Cond (subst a x c) (subst ifso x c) (subst ifnot x c)
  end.

(** The reduction semantics: [red a a'] means that [a] reduces in one
    step to [a'].  We choose a call-by-value semantics, with applications
    being evaluated from left to right. *)

Inductive red: term -> term -> Prop :=
  | red_beta: forall x a v,                 (**r call-by-value beta reduction *)
      isvalue v ->
      red (App (Abs x a) v) (subst a x v)
  | red_cond: forall b ifso ifnot,            (**r reduction for conditionals *)
      red (Cond (Const b) ifso ifnot) (if b then ifso else ifnot)
  | red_app_1: forall a1 a2 a1', (**r reduction to the left of an application *)
      red a1 a1' ->
      red (App a1 a2) (App a1' a2)
  | red_app_2: forall v a2 a2', (**r reduction to the right of an application *)
      isvalue v -> red a2 a2' ->
      red (App v a2) (App v a2')
  | red_cond_1: forall a a' ifso ifnot,         (**r reduction under a [Cond] *)
      red a a' ->
      red (Cond a ifso ifnot) (Cond a' ifso ifnot).

(** *** Exercise (1 star) *)
(** Modify [red] to obtain a call-by-name semantics.
    What is the impact of this change on the results in the remainder
    of this module? *)

(** *** Exercise (2 stars) *)
(** Extend the syntax and the semantics of FUN with one or several
    of the features mentioned in the lecture: Peano integers,
    products, sums, fixed points. *)

(** Another presentation of the reduction semantics, in the style
    popularized by Wright and Felleisen.  First we define head reductions. *)

Inductive head_red: term -> term -> Prop :=
  | head_red_beta: forall x a v,
      isvalue v ->
      head_red (App (Abs x a) v) (subst a x v)
  | head_red_cond: forall b ifso ifnot,
      head_red (Cond (Const b) ifso ifnot) (if b then ifso else ifnot).

(** Then we define the reduction contexts.  Contexts are represented by
    functions [C: term -> term].  The inductive predicate
    [iscontext C] defines which functions are valid reduction contexts. *)

Inductive iscontext: (term -> term) -> Prop :=
  | iscontext_hole:                      (**r at the top *)
      iscontext (fun a => a)
  | iscontext_app_1: forall a C,         (**r to the left of an application *)
      iscontext C -> iscontext (fun x => App (C x) a)
  | iscontext_app_2: forall v C,         (**r to the right of an application *)
      isvalue v -> iscontext C -> iscontext (fun x => App v (C x))
  | iscontext_cond: forall C ifso ifnot, (**r under a conditional *)
      iscontext C -> iscontext (fun x => Cond (C x) ifso ifnot).

(** Finally, we define reductions under a context. *)

Inductive ctx_red: term -> term -> Prop :=
  | ctx_red_intro: forall a a' C,
      head_red a a' -> iscontext C ->
      ctx_red (C a) (C a').

(** Equivalence with the previous definition [red]. *)

Lemma ctx_red_to_red:
  forall a a', ctx_red a a' -> red a a'.
Proof.
  assert (REC: forall a a', head_red a a' ->
               forall C, iscontext C ->
               red (C a) (C a')).
  { intros a a' HR; induction 1.
  - inversion HR; subst; constructor; auto.
  - apply red_app_1; auto.
  - apply red_app_2; auto.
  - apply red_cond_1; auto. }
  destruct 1. apply REC; auto.
Qed.

Lemma red_to_ctx_red:
  forall a a', red a a' -> ctx_red a a'.
Proof.
  induction 1.
- apply ctx_red_intro with (C := fun x => x).
  apply head_red_beta; auto.
  constructor.
- apply ctx_red_intro with (C := fun x => x).
  apply head_red_cond; auto.
  constructor.
- destruct IHred. apply ctx_red_intro with (C := fun x => App (C x) a2); auto using iscontext.
- destruct IHred. apply ctx_red_intro with (C := fun x => App v (C x)); auto using iscontext.
- destruct IHred. apply ctx_red_intro with (C := fun x => Cond (C x) ifso ifnot); auto using iscontext.
Qed.

(** The natural semantics. *)

Inductive eval: term -> term -> Prop :=
  | eval_abs: forall x a,
      eval (Abs x a) (Abs x a)
  | eval_app: forall a1 a2 x a v2 v,
      eval a1 (Abs x a) -> eval a2 v2 -> eval (subst a x v2) v ->
      eval (App a1 a2) v
  | eval_const: forall b,
      eval (Const b) (Const b)
  | eval_cond: forall a ifso ifnot b v,
      eval a (Const b) -> eval (if b then ifso else ifnot) v ->
      eval (Cond a ifso ifnot) v.

Lemma eval_isvalue:
  forall a v, eval a v -> isvalue v.
Proof.
  induction 1; auto using isvalue.
Qed.

Lemma isvalue_eval:
  forall v, isvalue v -> eval v v.
Proof.
  destruct 1; eauto using eval.
Qed.

(** Equivalence between natural semantics [eval a v] and reduction semantics
    (there exists a sequence of reductions from term [a] to value [v]). *)

Lemma eval_reds:
  forall a v, eval a v -> star red a v.
Proof.
  induction 1.
- apply star_refl.
- apply star_trans with (App (Abs x a) a2).
  revert IHeval1. generalize a1, (Abs x a). induction 1; eauto using star, red_app_1.
  apply star_trans with (App (Abs x a) v2).
  revert IHeval2. generalize a2, v2. induction 1; eauto using star, red_app_2, isvalue.
  eapply star_step. apply red_beta. eapply eval_isvalue; eauto.
  apply IHeval3.
- apply star_refl.
- apply star_trans with (Cond (Const b) ifso ifnot).
  revert IHeval1. generalize a, (Const b). induction 1; eauto using star, red_cond_1.
  eapply star_step. apply red_cond.
  apply IHeval2.
Qed.

Lemma red_eval_eval:
  forall a1 a2, red a1 a2 -> forall v, eval a2 v -> eval a1 v.
Proof.
  induction 1; intros v' E.
- eauto using eval, isvalue_eval.
- eauto using eval.
- inversion E; subst; eauto using eval.
- inversion E; subst; eauto using eval, isvalue_eval.
- inversion E; subst; eauto using eval.
Qed.

Lemma reds_eval:
  forall a v, star red a v -> isvalue v -> eval a v.
Proof.
  induction 1; intros.
- apply isvalue_eval; auto.
- apply red_eval_eval with b; auto.
Qed.

(** ** 7.2.  Simple types *)

(** The type algebra. *)

Inductive type: Type :=
  | Bool                          (**r the type of Booleans *)
  | Fun (t1: type) (t2: type).    (**r the type of functions from [t1] to [t2] *)

Notation " t1 --> t2 " := (Fun t1 t2) (right associativity, at level 55).

(** Typing contexts associate a type to each free variable. *)

Definition context := list (string * type).

Fixpoint lookup {A: Type} (x: string) (l: list (string * A)) : option A :=
  match l with
  | nil => None
  | (y, a) :: l => if string_dec x y then Some a else lookup x l
  end.

(** The typing rules. *)

Reserved Notation "E '⊢' a '∈' t" (at level 40).

Inductive has_type : context -> term -> type -> Prop :=
  | T_Var: forall E x t,
      lookup x E = Some t ->
      E ⊢ Var x ∈ t
  | T_Abs : forall E x a t t',
      ((x, t) :: E) ⊢ a ∈ t' ->
      E ⊢ Abs x a ∈ Fun t t'
  | T_App : forall E a1 a2 t t',
      E ⊢ a1 ∈ Fun t t' -> E ⊢ a2 ∈ t ->
      E ⊢ App a1 a2 ∈ t'
  | T_Const : forall E b,
      E ⊢ Const b ∈ Bool
  | T_Cond : forall E a ifso ifnot t,
      E ⊢ a ∈ Bool -> E ⊢ ifso ∈ t -> E ⊢ ifnot ∈ t ->
      E ⊢ Cond a ifso ifnot ∈ t

where "E '⊢' a '∈' t" := (has_type E a t).

(** The main properties of the typing judgment.
    First, the weakening property. *)

Lemma weakening:
  forall E a t,
  E ⊢ a ∈ t ->
  forall E',
  (forall x tx, lookup x E = Some tx -> lookup x E' = Some tx) ->
  E' ⊢ a ∈ t.
Proof.
  induction 1; intros E' W; eauto using has_type.
- (* Abs *)
  apply T_Abs. apply IHhas_type.
  cbn; intros. destruct (string_dec x0 x); auto.
Qed.

(** Weakening is stated in an unusual manner.
    Usually, it is stated with a syntactic concatenation of contexts:
    if [E ⊢ a ∈ t], then [E' ++ E ⊢ a ∈ t].  However, this statement
    is false if [E'] can bound variables that are already bound in [E].
    On paper, we implicitly assume that a context never binds the same
    variable twice, a constraint that can always be satisfied by
    renaming some variables.
    In our Coq development, we have no renaming nor constraints over
    contexts.  Instead, we use two arbitrary contexts [E] and [E'],
    connected by the hypothesis
    "any variable that is given a type by [E] is given the same type in [E']".
*)

(** The next property is stability of typing under substitution.
    It uses the same trick to connect
-   the context [E] in which term [a] is typed before substitution;
-   the context [E'] in which the term [subst a x c] is typed after
    substitution.

    Moreover, the lemma requires that [c] is typed in the empty
    environment, guaranteeing that [c] is closed and that the substitution
    [subst a x c] avoids variable capture. *)

Lemma substitution_preserves_typing:
  forall E a t,
  E ⊢ a ∈ t ->
  forall x c t' E',
  nil ⊢ c ∈ t' ->
  lookup x E = Some t' ->
  (forall y ty, y <> x -> lookup y E = Some ty -> lookup y E' = Some ty) ->
  E' ⊢ subst a x c ∈ t.
Proof.
  induction 1; intros until E'; intros TYC TYX TYE; cbn.
- (* Var *)
  destruct (string_dec x0 x).
  + (* Var x *)
    replace t with t' by congruence.
    apply weakening with (E := nil); auto.
    cbn; intros; discriminate.
  + (* Var y, y <> x *)
    apply T_Var. apply TYE; auto.
- (* Abs *)
  destruct (string_dec x0 x).
  + (* Abs x a *)
    subst x0.
    apply T_Abs. apply weakening with (E := (x, t) :: E); auto.
    cbn; intros. destruct (string_dec x0 x); auto.
  + (* Abs y a, y <> x *)
    apply T_Abs. eapply IHhas_type; eauto.
    cbn. destruct (string_dec x0 x); congruence.
    cbn; intros. destruct (string_dec y x); auto.
- (* App *)
  apply T_App with t; eauto.
- (* Const *)
  apply T_Const.
- (* Cond *)
  apply T_Cond; eauto.
Qed.

(** Finally, here is the "canonical forms" lemma, showing that the type
    of a closed value determines its shape. *)

Lemma canonical_forms:
  forall v t,
  nil ⊢ v ∈ t -> isvalue v ->
  match t with
  | Bool => exists b, v = Const b
  | Fun t1 t2 => exists x a, v = Abs x a
  end.
Proof.
  intros v t TY VAL. inversion VAL; subst; inversion TY; subst.
- (* Fun type *)
  exists x, a; auto.
- (* Bool type *)
  exists b; auto.
Qed.

(** We can, then, prove the two crucial properties that connect typing
    with reductions: preservation and progress. *)

Theorem reduction_preserves_typing:
  forall a a',
  red a a' ->
  forall t,
  nil ⊢ a ∈ t -> nil ⊢ a' ∈ t.
Proof.
  induction 1; intros t TY.
- (* red_beta *)
  inversion TY; subst. inversion H3; subst.
  eapply substitution_preserves_typing; eauto.
  cbn. destruct (string_dec x x); congruence.
  cbn; intros. destruct (string_dec y x); congruence.
- (* red_cond *)
  inversion TY; subst.
  destruct b; auto.
- (* red_app_1 *)
  inversion TY; subst. apply T_App with t0; eauto.
- (* red_app_2 *)
  inversion TY; subst. apply T_App with t0; eauto.
- (* red_cond_1 *)
  inversion TY; subst. apply T_Cond; eauto.
Qed.

Theorem progress:
  forall a t,
  nil ⊢ a ∈ t -> isvalue a \/ exists a', red a a'.
Proof.
  intros a t TY; dependent induction TY.
- (* Abs x a *)
  left; apply V_Abs.
- (* App a1 a2 *)
  destruct IHTY1 as [ISVAL1 | (a1' & RED1)]; auto.
  + destruct IHTY2 as [ISVAL2 | (a2' & RED2)]; auto.
    * (* a1 et a2 sont des valeurs *)
      destruct (canonical_forms a1 (Fun t t')) as (x & a & E); auto.
      subst a1. right; exists (subst a x a2). apply red_beta; auto.
    * (* a1 est une valeur, a2 se réduit *)
      right; exists (App a1 a2'). apply red_app_2; auto.
  + (* a1 se réduit *)
    right; exists (App a1' a2). apply red_app_1; auto.
- (* Const b *)
  left; apply V_Const.
- (* Cond a ifso ifnot *)
  destruct IHTY1 as [ISVAL1 | (a' & RED1)]; auto.
  + (* a est une valeur *)
    destruct (canonical_forms a Bool) as (b & E); auto.
    subst a. right; exists (if b then ifso else ifnot). apply red_cond.
  + (* a se réduit *)
    right; exists (Cond a' ifso ifnot). apply red_cond_1; auto.
Qed.

(** Type soundness follows: a well-typed closed term does not go wrong. *)

Definition goes_wrong (a: term) : Prop :=
  exists a', star red a a' /\ irred red a' /\ ~isvalue a'.

Theorem well_typed_programs_do_not_go_wrong:
  forall a t,
  nil ⊢ a ∈ t -> ~ goes_wrong a.
Proof.
  intros a t TY (a' & REDS & IRRED & NOTVAL).
  assert (TY': nil ⊢ a' ∈ t).
  { clear IRRED NOTVAL. revert a a' REDS TY.
    induction 1; eauto using reduction_preserves_typing. }
  destruct (progress a' t TY') as [ISVAL | (a'' & RED)].
  - apply NOTVAL. auto.
  - apply IRRED with a''. auto.
Qed.

(** A more positive presentation of the type soundness  result.
    We define coinductively the predicate [safe a], meaning
    "a executes without going wrong".  It covers both the case
    where the reduction of [a] terminates on a value, and the
    case where the reduction of [a] diverges. *)

CoInductive safe: term -> Prop :=
  | safe_value: forall v,
      isvalue v ->
      safe v
  | safe_red: forall a a',
      red a a' -> safe a' ->
      safe a.

Theorem well_typed_programs_are_safe:
  forall a t,
  nil ⊢ a ∈ t -> safe a.
Proof.
  cofix CIH; intros.
  destruct (progress a t H) as [ISVAL | (a' & RED)].
- apply safe_value; auto.
- apply safe_red with a'; auto.
  apply CIH with t. apply reduction_preserves_typing with a; auto.
Qed.

(** *** Exercise (2 or 3 stars) *)
(** Extend the type system with one or several of the features
    mentioned in the lecture: Peano integers, products, sums, fixed points.
    Update the proof of type soundness accordingly. *)

(** *** Exercise (3 stars) *)
(** In the definition of the type algebra, replace [Inductive type ...]
    by [CoInductive type ...].
    This makes it possible to work with infinite type expressions
    such as [Bool --> Bool --> ... --> Bool --> ...].

-   Check that the proof of type soundness still works.
-   Show that we can type the fixed-point combinator [Y] shown
    in the lecture, giving it the type [(t --> t) --> t] for any type [t]. *)

Remark type_Y: forall t,
  let D := Abs "x" (App (Var "f") (App (Var "x") (Var "x"))) in
  let Y := Abs "f" (App D D) in
  nil ⊢ Y ∈ ((t --> t) --> t).
Proof.
  intros t D Y.
  (* FILL IN HERE *)
Abort.

(** *** Exercise (3 stars) *)
(** Write a type-checker for our type system with simple types.
    It's a function [context -> term -> option type]
    that checks whether a term is well-typed in a given context.
    If yes, the type of the term is returned; if not, [None] is returned.
    Prove that this type-checker is sound and complete with respect
    to the typing rules. *)

Fixpoint typecheck (E: context) (a: term) : option type :=
  (* FILL IN HERE *) None.

Lemma typecheck_sound:
  forall E a t, typecheck E a = Some t -> has_type E a t.
Proof.
  intros E a; revert a E; induction a; cbn; intros E t T.
  (* FILL IN HERE *)
Abort.

Lemma typecheck_complete:
  forall E a t, has_type E a t -> typecheck E a = Some t.
Proof.
  induction 1; cbn.
  (* FILL IN HERE *)
Abort.

(** ** 7.3.  Subtyping *)

Module Subtyping.

(** We extend the type algebra with [Top], the universal type of all values. *)

Inductive type: Type :=
  | Top                           (**r universal type *)
  | Bool                          (**r type of Booleans *)
  | Fun (t1: type) (t2: type).    (**r type of functions from [t1] to [t2] *)

Reserved Notation "t '<:' s" (at level 40).

(** The subtyping relation.  Intuitively, [t] is subtype of [s]
    if every value of type [t] can be used with type [s]. *)

Inductive subtype: type -> type -> Prop :=
  | subtype_top: forall t,
      t <: Top
  | subtype_bool:
      Bool <: Bool
  | subtype_fun: forall s1 t1 s2 t2,
      s2 <: s1 -> t1 <: t2 ->
      Fun s1 t1 <: Fun s2 t2

where "t '<:' s" := (subtype t s).

(** Every type is subtype of itself. *)

Lemma subtype_refl:
  forall t, t <: t.
Proof.
  induction t; auto using subtype.
Qed.

(** The subtyping relation is transitive. *)

Lemma subtype_trans:
  forall t1 t2 t3, t1 <: t2 -> t2 <: t3 -> t1 <: t3.
Proof.
  intros t1 t2; revert t2 t1.
  induction t2; intros t1 t3 S1 S2;
  inversion S1; inversion S2; subst; eauto using subtype.
Qed.

(** We extend the type system with a subsumption rule [T_Sub]
    that allows us to use a term with a super-type of its type. *)

Definition context := list (string * type).

Inductive has_type : context -> term -> type -> Prop :=
  | T_Var: forall E x t,
      lookup x E = Some t ->
      E ⊢ Var x ∈ t
  | T_Abs : forall E x a t t',
      ((x, t) :: E) ⊢ a ∈ t' ->
      E ⊢ Abs x a ∈ Fun t t'
  | T_App : forall E a1 a2 t t',
      E ⊢ a1 ∈ Fun t t' -> E ⊢ a2 ∈ t ->
      E ⊢ App a1 a2 ∈ t'
  | T_Const : forall E b,
      E ⊢ Const b ∈ Bool
  | T_Cond : forall E a ifso ifnot t,
      E ⊢ a ∈ Bool -> E ⊢ ifso ∈ t -> E ⊢ ifnot ∈ t ->
      E ⊢ Cond a ifso ifnot ∈ t
  | T_Sub: forall E a s t,       (**r <-- new! *)
      E ⊢ a ∈ s -> s <: t ->
      E ⊢ a ∈ t

where "E '⊢' a '∈' t" := (has_type E a t).

(** *** Exercise (3 stars) *)
(** Prove type soundness for this type system with subtyping.
    The proof in section 7.2 can be reused with very few changes.
    However, it is necessary to use the following inversion lemmas. *)

Lemma T_Abs_inv:
  forall E x a t,
  E ⊢ Abs x a ∈ t -> exists t1 t2, ((x, t1) :: E) ⊢ a ∈ t2 /\ Fun t1 t2 <: t.
Proof.
  intros until t; intros TY; dependent induction TY.
- exists t, t'; auto using subtype_refl.
- edestruct IHTY as (t1 & t2 & P & Q); eauto.
  exists t1, t2; split. auto. apply subtype_trans with s; auto.
Qed.

Lemma T_App_inv:
  forall E a1 a2 t,
  E ⊢ App a1 a2 ∈ t -> exists t1 t2, E ⊢ a1 ∈ Fun t1 t2 /\ E ⊢ a2 ∈ t1 /\ t2 <: t.
Proof.
  intros until t; intros TY; dependent induction TY.
- exists t, t'; auto using subtype_refl.
- edestruct IHTY as (t1 & t2 & P & Q & R); eauto.
  exists t1, t2; split. auto. split. auto. apply subtype_trans with s; auto.
Qed.

Lemma T_Cond_inv:
  forall E a ifso ifnot t,
  E ⊢ Cond a ifso ifnot ∈ t -> exists t', E ⊢ a ∈ Bool /\ E ⊢ ifso ∈ t' /\ E ⊢ ifnot ∈ t' /\ t' <: t.
Proof.
  intros until t; intros TY; dependent induction TY.
- exists t; auto using subtype_refl.
- edestruct IHTY as (t' & P & Q & R & S); eauto.
  exists t'; intuition auto. apply subtype_trans with s; auto.
Qed.

Theorem well_typed_programs_are_safe:
  forall a t,
  nil ⊢ a ∈ t -> safe a.
Proof.
  (* FILL IN HERE *)
Abort.

End Subtyping.

(** ** 7.4.  Intrinsically-typed terms *)

From Coq Require Import FunctionalExtensionality.

Module Intrinsic.

(** We now develop an abstract syntax for FUN where terms are indexed
    by their types and the contexts in which they are typed. *)

(** A context lists the free variables that can occur in the term,
    along with their types.  We use a positional notation (de Bruijn indices)
    for variables.  Consequently, the context is just a list of types:
    [t1 :: ... :: tN :: nil] is the context that assigns type [ti]
    to the variable having index [i], for [i] ranging from 1 to [N]. *)

Definition context := list type.

(** [var E t] is the type of variables that can be used in context [E]
    with type [t]. *)

Inductive var: context -> type -> Type :=
  | V1: forall {E: context} {t: type}, var (t :: E) t
  | VS: forall {E: context} {t t': type}, var E t' -> var (t :: E) t'.

(** Examples of variables. *)

Definition V2 {E: context} {t1 t2: type}: var (t1 :: t2 :: E) t2 := VS V1.
Definition V3 {E: context} {t1 t2 t3: type}: var (t1 :: t2 :: t3 :: E) t3 := VS V2.

(** [term E t] is the type of terms having type [t] in context [E]. *)

Inductive term: context -> type -> Type :=
  | Var: forall {E: context} {t: type},
         var E t ->
         term E t
  | Abs: forall {E: context} {t t': type},
         term (t :: E) t' ->
         term E (Fun t t')
  | App: forall {E: context} {t t': type},
         term E (Fun t t') -> term E t ->
         term E t'
  | Const: forall {E: context} (b: bool),
         term E Bool
  | Cond: forall {E: context} {t: type},
         term E Bool -> term E t -> term E t ->
         term E t.

(** Examples of terms. *)

(** The term [fun b => if b then false else true]. *)
Definition t_negation : term nil (Bool --> Bool) :=
  Abs (Cond (Var V1) (Const false) (Const true)).

(** The term [fun f => fun g => fun x => g (f x)]. *)
Definition t_compose (t1 t2 t3: type) :
               term nil ((t1 --> t2) --> (t2 --> t3) --> (t1 --> t3)) :=
  Abs (Abs (Abs (App (Var V2) (App (Var V3) (Var V1))))).

(** An ill-typed term that, consequently, cannot be expressed. *)
Fail Definition t_error : term nil Bool :=
  Cond (Abs (Var V1)) (Const false) (Const true).

(** We interpret a FUN type expression by a Coq type.  It's the type of
    Coq values that match this FUN type. *)

Fixpoint dtype (t: type) : Type :=
  match t with
  | Bool => bool
  | Fun t1 t2 => dtype t1 -> dtype t2
  end.

(** Likewise, we interpret a typing context by a Coq type.
    It is the type of evaluation environments corresponding to this
    context: an heterogeneous list of the values associated to the variables. *)

Fixpoint dcontext (E: context) : Type :=
  match E with
  | nil => unit
  | t :: E => dtype t * dcontext E
  end.

(** The denotational semantics of a variable.
    It is the value associated to the variable in the evaluation environment. *)

Fixpoint dvar {E: context} {t: type} (v: var E t): dcontext E -> dtype t :=
  match v with
  | V1 => (fun e => fst e)
  | VS v => (fun e => dvar v (snd e))
  end.

(** The denotational semantics of a term.
    It is a function from evaluation environments, [dcontext E],
    to Coq values matching the type of the expression, [dtype t]. *)

Fixpoint dterm {E: context} {t: type} (a: term E t) : dcontext E -> dtype t :=
  match a with
  | Var v => dvar v
  | Abs a => (fun e => (fun v => dterm a (v, e)))
  | App a1 a2 => (fun e => dterm a1 e (dterm a2 e))
  | Const b => (fun e => b)
  | Cond a ifso ifnot => (fun e => if dterm a e then dterm ifso e else dterm ifnot e)
  end.

(** The semantics of a beta-redex [App (Abs a) b] is just that of the
    binding [let 1 = b in a]: we evaluate [a] after binding the
    variable of index 1 to the value of [b]. *)

Lemma dbeta: forall (E: context) (t t': type) (a: term (t :: E) t') (b: term E t),
  forall e, dterm (App (Abs a) b) e = dterm a (dterm b e, e).
Proof.
  reflexivity.
Qed.

(** In preparation for a reduction semantics, we now build a substitution
    function over intrinsically-typed terms.
    The substitution of [b] for variable of index 1 in [a] has type
<<
   subst1 {t': type} {E: context} {t: type} (a: term (t' :: E) t) (b: term E t') : term E t
>>
    and satisfies the equation [dterm (subst1 a b) e = dterm a (dterm b e, e)]. *)

(** Definiting the substitution function is difficult:
-   Since we use a positional notation, we need to "lift" by one certain
    variable indices (function [lift] below).
-   Our functions have complex dependent types.  On the one hand, these
    types guarantee type preservation by construction.  On the other hand,
    the functions are hard to write directly.
-   We chose to prove semantic equations about our functions at the
    same time we define the functions, resulting in many subset types
    [ { x | P x } ].
*)

(** Lifting. *)

Fixpoint unlift_env (E': context) (t': type) (E: context) : dcontext (E' ++ t' :: E) -> dcontext (E' ++ E) :=
  match E' with
  | nil => fun e => snd e
  | t :: E' => fun e => (fst e, unlift_env E' t' E (snd e))
  end.

Definition lift_var  (E': context) (t': type) {E: context} {t: type} (v: var (E' ++ E) t) :
           { w : var (E' ++ t' :: E) t
           | forall e, dvar w e = dvar v (unlift_env E' t' E e)}.
Proof.
  revert E' t' E t v. induction E' as [ | t0 E' ]; cbn.
- intros. exists (VS v). auto.
- intros. dependent destruction v.
  + exists V1. auto.
  + destruct (IHE' t' _ _ v) as (w & W). exists (VS w). intros; cbn. rewrite W; auto.
Defined.

Definition lift (E': context) (t': type) {E: context} {t: type} (a: term (E' ++ E) t) :
           { b : term (E' ++ t' :: E) t
           | forall e, dterm b e = dterm a (unlift_env E' t' E e) }.
Proof.
  dependent induction a.
- destruct (lift_var E' t' v) as (w & W). exists (Var w). auto.
- destruct (IHa (t::E') _ a) as (b & B); auto.
  exists (Abs b). intros. apply functional_extensionality; intros. cbn. rewrite B. auto.
- destruct (IHa1 E' _ a1) as (b1 & B1); auto.
  destruct (IHa2 E' _ a2) as (b2 & B2); auto.
  exists (App b1 b2). cbn; intros. rewrite B1, B2. auto.
- exists (Const b); auto.
- destruct (IHa1 E' _ a1) as (b1 & B1); auto.
  destruct (IHa2 E' _ a2) as (b2 & B2); auto.
  destruct (IHa3 E' _ a3) as (b3 & B3); auto.
  exists (Cond b1 b2 b3). intros; cbn. rewrite B1, B2, B3; auto.
Defined.

Definition lift1 (t': type) {E: context} {t: type} (a: term E t) :
           { b : term (t' :: E) t
           | forall e, dterm b e = dterm a (snd e) }.
Proof.
  apply lift with (E' := nil).
Defined.

(** Substitution. *)

Fixpoint proj_env (E': context) (E: context) : dcontext (E' ++ E) -> dcontext E :=
  match E' with
  | nil => fun e => e
  | t :: E' => fun e => proj_env E' E (snd e)
  end.

Fixpoint unsubst_env (E': context) (t': type) (E: context) : dcontext (E' ++  E) -> dtype t' -> dcontext (E' ++ t' :: E) :=
  match E' with
  | nil => fun e v => (v, e)
  | t :: E' => fun e v => (fst e, unsubst_env E' t' E (snd e) v)
  end.

Definition subst_var (E': context) (t': type) {E: context} {t: type} (v: var (E' ++ t' :: E) t) (b: term E t') :
           { c : term (E' ++ E) t
           | forall e, dterm c e = dvar v (unsubst_env E' t' E e (dterm b (proj_env E' E e))) }.
Proof.
  induction E' as [ | t0 E' ]; simpl.
- dependent destruction v; simpl.
  + exists b; auto.
  + exists (Var v); auto.
- dependent destruction v; simpl.
  + exists (Var V1); auto.
  + destruct (IHE' v) as (c & C). destruct (lift1 t0 c) as (c' & C'). exists c'.
    simpl; intros. rewrite C', C. auto.
Defined.

Definition subst (E': context) (t': type) {E: context} {t: type} (a: term (E' ++ t' :: E) t) (b: term E t') :
           { c : term (E' ++ E) t
           | forall e, dterm c e = dterm a (unsubst_env E' t' E e (dterm b (proj_env E' E e))) }.
Proof.
  dependent induction a.
- apply subst_var.
- edestruct (IHa (t :: E') t' E a) as (c & C); eauto.
  exists (Abs c). intros. apply functional_extensionality. intros v; simpl.
  rewrite C. simpl. eauto.
- edestruct (IHa1 E' t' E a1) as (c1 & C1); eauto.
  edestruct (IHa2 E' t' E a2) as (c2 & C2); eauto.
  exists (App c1 c2). simpl; intros. rewrite C1, C2. eauto.
- exists (Const b). simpl; auto.
- edestruct (IHa1 E' t' E a1) as (c1 & C1); eauto.
  edestruct (IHa2 E' t' E a2) as (c2 & C2); eauto.
  edestruct (IHa3 E' t' E a3) as (c3 & C3); eauto.
  exists (Cond c1 c2 c3). simpl; intros. rewrite C1, C2, C3. eauto.
Defined.

Definition subst1 {t': type} {E: context} {t: type} (a: term (t' :: E) t) (b: term E t') : term E t :=
  proj1_sig (subst nil t' a b).

Lemma dterm_subst1:
  forall {t': type} {E: context} {t: type} (a: term (t' :: E) t) (b: term E t') e,
  dterm (subst1 a b) e = dterm a (dterm b e, e).
Proof.
  intros. unfold subst1. destruct (subst nil t' a b) as (c & C). apply C.
Qed.

(** The reduction semantics. *)

Inductive isvalue: forall (E: context) (t: type), term E t -> Prop :=
  | V_Abs: forall E t1 t2 (a: term (t1 :: E) t2),
      isvalue E (Fun t1 t2) (Abs a)
  | V_Const: forall E b,
      isvalue E Bool (Const b).

Inductive red: forall E t, term E t -> term E t -> Prop :=
  | red_beta: forall E t1 t2 (a: term (t1 :: E) t2) (v: term E t1),
      isvalue E t1 v ->
      red E t2 (App (Abs a) v) (subst1 a v)
  | red_cond: forall E t (b: bool) (ifso ifnot: term E t),
      red E t (Cond (Const b) ifso ifnot) (if b then ifso else ifnot)
  | red_app_1: forall E t t' (a1 a1': term E (Fun t t')) (a2: term E t),
      red E (Fun t t') a1 a1' ->
      red E t' (App a1 a2) (App a1' a2)
  | red_app_2: forall E t t' (v: term E (Fun t t')) (a2 a2': term E t),
      isvalue E (Fun t t') v -> red E t a2 a2' ->
      red E t' (App v a2) (App v a2')
  | red_cond_1: forall E t (a a': term E Bool) (ifso ifnot: term E t),
      red E Bool a a' ->
      red E t (Cond a ifso ifnot) (Cond a' ifso ifnot).

(** Reductions are compatible with the denotational semantics. *)

Theorem red_denot:
  forall E t a1 a2, red E t a1 a2 -> forall e, dterm a1 e = dterm a2 e.
Proof.
  induction 1; simpl; intros.
- rewrite dterm_subst1; auto.
- destruct b; auto.
- rewrite IHred; auto.
- rewrite IHred; auto.
- rewrite IHred; auto.
Qed.

End Intrinsic.


From Hammer Require Import Hammer.

Require Import Bool Morphisms Setoid Bvector BinPos BinNat PeanoNat Pnat Nnat.

Local Open Scope N_scope.

Notation Pxor := Pos.lxor (compat "8.3").
Notation Nxor := N.lxor (compat "8.3").
Notation Pbit := Pos.testbit_nat (compat "8.3").
Notation Nbit := N.testbit_nat (compat "8.3").

Notation Nxor_eq := N.lxor_eq (compat "8.3").
Notation Nxor_comm := N.lxor_comm (compat "8.3").
Notation Nxor_assoc := N.lxor_assoc (compat "8.3").
Notation Nxor_neutral_left := N.lxor_0_l (compat "8.3").
Notation Nxor_neutral_right := N.lxor_0_r (compat "8.3").
Notation Nxor_nilpotent := N.lxor_nilpotent (compat "8.3").

Lemma Ptestbit_Pbit :
forall p n, Pos.testbit p (N.of_nat n) = Pos.testbit_nat p n.
Proof. hammer_hook "Ndigits" "Ndigits.Ptestbit_Pbit".
induction p as [p IH|p IH| ]; intros [|n]; simpl; trivial;
rewrite <- IH; f_equal; rewrite (pred_Sn n) at 2; now rewrite Nat2N.inj_pred.
Qed.

Lemma Ntestbit_Nbit : forall a n, N.testbit a (N.of_nat n) = N.testbit_nat a n.
Proof. hammer_hook "Ndigits" "Ndigits.Ntestbit_Nbit".
destruct a. trivial. apply Ptestbit_Pbit.
Qed.

Lemma Pbit_Ptestbit :
forall p n, Pos.testbit_nat p (N.to_nat n) = Pos.testbit p n.
Proof. hammer_hook "Ndigits" "Ndigits.Pbit_Ptestbit".
intros; now rewrite <- Ptestbit_Pbit, N2Nat.id.
Qed.

Lemma Nbit_Ntestbit :
forall a n, N.testbit_nat a (N.to_nat n) = N.testbit a n.
Proof. hammer_hook "Ndigits" "Ndigits.Nbit_Ntestbit".
destruct a. trivial. apply Pbit_Ptestbit.
Qed.

Lemma Nshiftr_nat_S : forall a n,
N.shiftr_nat a (S n) = N.div2 (N.shiftr_nat a n).
Proof. hammer_hook "Ndigits" "Ndigits.Nshiftr_nat_S".
reflexivity.
Qed.

Lemma Nshiftl_nat_S : forall a n,
N.shiftl_nat a (S n) = N.double (N.shiftl_nat a n).
Proof. hammer_hook "Ndigits" "Ndigits.Nshiftl_nat_S".
reflexivity.
Qed.

Lemma Nshiftr_nat_equiv :
forall a n, N.shiftr_nat a (N.to_nat n) = N.shiftr a n.
Proof. hammer_hook "Ndigits" "Ndigits.Nshiftr_nat_equiv".
intros a [|n]; simpl. unfold N.shiftr_nat.
trivial.
symmetry. apply Pos2Nat.inj_iter.
Qed.

Lemma Nshiftr_equiv_nat :
forall a n, N.shiftr a (N.of_nat n) = N.shiftr_nat a n.
Proof. hammer_hook "Ndigits" "Ndigits.Nshiftr_equiv_nat".
intros. now rewrite <- Nshiftr_nat_equiv, Nat2N.id.
Qed.

Lemma Nshiftl_nat_equiv :
forall a n, N.shiftl_nat a (N.to_nat n) = N.shiftl a n.
Proof. hammer_hook "Ndigits" "Ndigits.Nshiftl_nat_equiv".
intros [|a] [|n]; simpl; unfold N.shiftl_nat; trivial.
induction (Pos.to_nat n) as [|? H]; simpl; now try rewrite H.
rewrite <- Pos2Nat.inj_iter. symmetry. now apply Pos.iter_swap_gen.
Qed.

Lemma Nshiftl_equiv_nat :
forall a n, N.shiftl a (N.of_nat n) = N.shiftl_nat a n.
Proof. hammer_hook "Ndigits" "Ndigits.Nshiftl_equiv_nat".
intros. now rewrite <- Nshiftl_nat_equiv, Nat2N.id.
Qed.

Lemma Nshiftr_nat_spec : forall a n m,
N.testbit_nat (N.shiftr_nat a n) m = N.testbit_nat a (m+n).
Proof. hammer_hook "Ndigits" "Ndigits.Nshiftr_nat_spec".
induction n; intros m.
now rewrite <- plus_n_O.
simpl. rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn.
destruct (N.shiftr_nat a n) as [|[p|p|]]; simpl; trivial.
Qed.

Lemma Nshiftl_nat_spec_high : forall a n m, (n<=m)%nat ->
N.testbit_nat (N.shiftl_nat a n) m = N.testbit_nat a (m-n).
Proof. hammer_hook "Ndigits" "Ndigits.Nshiftl_nat_spec_high".
induction n; intros m H.
- now rewrite Nat.sub_0_r.
- destruct m.
+ inversion H.
+ apply le_S_n in H.
simpl. rewrite <- IHn; trivial.
destruct (N.shiftl_nat a n) as [|[p|p|]]; simpl; trivial.
Qed.

Lemma Nshiftl_nat_spec_low : forall a n m, (m<n)%nat ->
N.testbit_nat (N.shiftl_nat a n) m = false.
Proof. hammer_hook "Ndigits" "Ndigits.Nshiftl_nat_spec_low".
induction n; intros m H. inversion H.
rewrite Nshiftl_nat_S.
destruct m.
- destruct (N.shiftl_nat a n); trivial.
- apply Lt.lt_S_n in H.
specialize (IHn m H).
destruct (N.shiftl_nat a n); trivial.
Qed.

Lemma Pshiftl_nat_0 : forall p, Pos.shiftl_nat p 0 = p.
Proof. hammer_hook "Ndigits" "Ndigits.Pshiftl_nat_0".   reflexivity. Qed.

Lemma Pshiftl_nat_S :
forall p n, Pos.shiftl_nat p (S n) = xO (Pos.shiftl_nat p n).
Proof. hammer_hook "Ndigits" "Ndigits.Pshiftl_nat_S".   reflexivity. Qed.

Lemma Pshiftl_nat_N :
forall p n, Npos (Pos.shiftl_nat p n) = N.shiftl_nat (Npos p) n.
Proof. hammer_hook "Ndigits" "Ndigits.Pshiftl_nat_N".
unfold Pos.shiftl_nat, N.shiftl_nat.
induction n; simpl; auto. now rewrite <- IHn.
Qed.

Lemma Pshiftl_nat_plus : forall n m p,
Pos.shiftl_nat p (m + n) = Pos.shiftl_nat (Pos.shiftl_nat p n) m.
Proof. hammer_hook "Ndigits" "Ndigits.Pshiftl_nat_plus".
induction m; simpl; intros. reflexivity.
now f_equal.
Qed.

Lemma Pxor_semantics p p' n :
N.testbit_nat (Pos.lxor p p') n = xorb (Pos.testbit_nat p n) (Pos.testbit_nat p' n).
Proof. hammer_hook "Ndigits" "Ndigits.Pxor_semantics".
rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_lxor_spec.
Qed.

Lemma Nxor_semantics a a' n :
N.testbit_nat (N.lxor a a') n = xorb (N.testbit_nat a n) (N.testbit_nat a' n).
Proof. hammer_hook "Ndigits" "Ndigits.Nxor_semantics".
rewrite <- !Ntestbit_Nbit. apply N.lxor_spec.
Qed.

Lemma Por_semantics p p' n :
Pos.testbit_nat (Pos.lor p p') n = (Pos.testbit_nat p n) || (Pos.testbit_nat p' n).
Proof. hammer_hook "Ndigits" "Ndigits.Por_semantics".
rewrite <- !Ptestbit_Pbit. apply N.pos_lor_spec.
Qed.

Lemma Nor_semantics a a' n :
N.testbit_nat (N.lor a a') n = (N.testbit_nat a n) || (N.testbit_nat a' n).
Proof. hammer_hook "Ndigits" "Ndigits.Nor_semantics".
rewrite <- !Ntestbit_Nbit. apply N.lor_spec.
Qed.

Lemma Pand_semantics p p' n :
N.testbit_nat (Pos.land p p') n = (Pos.testbit_nat p n) && (Pos.testbit_nat p' n).
Proof. hammer_hook "Ndigits" "Ndigits.Pand_semantics".
rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_land_spec.
Qed.

Lemma Nand_semantics a a' n :
N.testbit_nat (N.land a a') n = (N.testbit_nat a n) && (N.testbit_nat a' n).
Proof. hammer_hook "Ndigits" "Ndigits.Nand_semantics".
rewrite <- !Ntestbit_Nbit. apply N.land_spec.
Qed.

Lemma Pdiff_semantics p p' n :
N.testbit_nat (Pos.ldiff p p') n = (Pos.testbit_nat p n) && negb (Pos.testbit_nat p' n).
Proof. hammer_hook "Ndigits" "Ndigits.Pdiff_semantics".
rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_ldiff_spec.
Qed.

Lemma Ndiff_semantics a a' n :
N.testbit_nat (N.ldiff a a') n = (N.testbit_nat a n) && negb (N.testbit_nat a' n).
Proof. hammer_hook "Ndigits" "Ndigits.Ndiff_semantics".
rewrite <- !Ntestbit_Nbit. apply N.ldiff_spec.
Qed.

Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n.

Program Instance eqf_equiv : Equivalence eqf.

Local Infix "==" := eqf (at level 70, no associativity).

Local Notation Step H := (fun n => H (S n)).

Lemma Pbit_faithful_0 : forall p, ~(Pos.testbit_nat p == (fun _ => false)).
Proof. hammer_hook "Ndigits" "Ndigits.Pbit_faithful_0".
induction p as [p IHp|p IHp| ]; intros H; try discriminate (H O).
apply (IHp (Step H)).
Qed.

Lemma Pbit_faithful : forall p p', Pos.testbit_nat p == Pos.testbit_nat p' -> p = p'.
Proof. hammer_hook "Ndigits" "Ndigits.Pbit_faithful".
induction p as [p IHp|p IHp| ]; intros [p'|p'|] H; trivial;
try discriminate (H O).
f_equal. apply (IHp _ (Step H)).
destruct (Pbit_faithful_0 _ (Step H)).
f_equal. apply (IHp _ (Step H)).
symmetry in H. destruct (Pbit_faithful_0 _ (Step H)).
Qed.

Lemma Nbit_faithful : forall n n', N.testbit_nat n == N.testbit_nat n' -> n = n'.
Proof. hammer_hook "Ndigits" "Ndigits.Nbit_faithful".
intros [|p] [|p'] H; trivial.
symmetry in H. destruct (Pbit_faithful_0 _ H).
destruct (Pbit_faithful_0 _ H).
f_equal. apply Pbit_faithful, H.
Qed.

Lemma Nbit_faithful_iff : forall n n', N.testbit_nat n == N.testbit_nat n' <-> n = n'.
Proof. hammer_hook "Ndigits" "Ndigits.Nbit_faithful_iff".
split. apply Nbit_faithful. intros; now subst.
Qed.

Local Close Scope N_scope.

Notation Nbit0 := N.odd (compat "8.3").

Definition Nodd (n:N) := N.odd n = true.
Definition Neven (n:N) := N.odd n = false.

Lemma Nbit0_correct : forall n:N, N.testbit_nat n 0 = N.odd n.
Proof. hammer_hook "Ndigits" "Ndigits.Nbit0_correct".
destruct n; trivial.
destruct p; trivial.
Qed.

Lemma Ndouble_bit0 : forall n:N, N.odd (N.double n) = false.
Proof. hammer_hook "Ndigits" "Ndigits.Ndouble_bit0".
destruct n; trivial.
Qed.

Lemma Ndouble_plus_one_bit0 :
forall n:N, N.odd (N.succ_double n) = true.
Proof. hammer_hook "Ndigits" "Ndigits.Ndouble_plus_one_bit0".
destruct n; trivial.
Qed.

Lemma Ndiv2_double :
forall n:N, Neven n -> N.double (N.div2 n) = n.
Proof. hammer_hook "Ndigits" "Ndigits.Ndiv2_double".
destruct n. trivial. destruct p. intro H. discriminate H.
intros. reflexivity.
intro H. discriminate H.
Qed.

Lemma Ndiv2_double_plus_one :
forall n:N, Nodd n -> N.succ_double (N.div2 n) = n.
Proof. hammer_hook "Ndigits" "Ndigits.Ndiv2_double_plus_one".
destruct n. intro. discriminate H.
destruct p. intros. reflexivity.
intro H. discriminate H.
intro. reflexivity.
Qed.

Lemma Ndiv2_correct :
forall (a:N) (n:nat), N.testbit_nat (N.div2 a) n = N.testbit_nat a (S n).
Proof. hammer_hook "Ndigits" "Ndigits.Ndiv2_correct".
destruct a; trivial.
destruct p; trivial.
Qed.

Lemma Nxor_bit0 :
forall a a':N, N.odd (N.lxor a a') = xorb (N.odd a) (N.odd a').
Proof. hammer_hook "Ndigits" "Ndigits.Nxor_bit0".
intros. rewrite <- Nbit0_correct, (Nxor_semantics a a' O).
rewrite Nbit0_correct, Nbit0_correct. reflexivity.
Qed.

Lemma Nxor_div2 :
forall a a':N, N.div2 (N.lxor a a') = N.lxor (N.div2 a) (N.div2 a').
Proof. hammer_hook "Ndigits" "Ndigits.Nxor_div2".
intros. apply Nbit_faithful. unfold eqf. intro.
rewrite (Nxor_semantics (N.div2 a) (N.div2 a') n), Ndiv2_correct, (Nxor_semantics a a' (S n)).
rewrite 2! Ndiv2_correct.
reflexivity.
Qed.

Lemma Nneg_bit0 :
forall a a':N,
N.odd (N.lxor a a') = true -> N.odd a = negb (N.odd a').
Proof. hammer_hook "Ndigits" "Ndigits.Nneg_bit0".
intros.
rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc,
xorb_nilpotent, xorb_false.
reflexivity.
Qed.

Lemma Nneg_bit0_1 :
forall a a':N, N.lxor a a' = Npos 1 -> N.odd a = negb (N.odd a').
Proof. hammer_hook "Ndigits" "Ndigits.Nneg_bit0_1".
intros. apply Nneg_bit0. rewrite H. reflexivity.
Qed.

Lemma Nneg_bit0_2 :
forall (a a':N) (p:positive),
N.lxor a a' = Npos (xI p) -> N.odd a = negb (N.odd a').
Proof. hammer_hook "Ndigits" "Ndigits.Nneg_bit0_2".
intros. apply Nneg_bit0. rewrite H. reflexivity.
Qed.

Lemma Nsame_bit0 :
forall (a a':N) (p:positive),
N.lxor a a' = Npos (xO p) -> N.odd a = N.odd a'.
Proof. hammer_hook "Ndigits" "Ndigits.Nsame_bit0".
intros. rewrite <- (xorb_false (N.odd a)).
assert (H0: N.odd (Npos (xO p)) = false) by reflexivity.
rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb.
reflexivity.
Qed.

Fixpoint Nless_aux (a a':N) (p:positive) : bool :=
match p with
| xO p' => Nless_aux (N.div2 a) (N.div2 a') p'
| _ => andb (negb (N.odd a)) (N.odd a')
end.

Definition Nless (a a':N) :=
match N.lxor a a' with
| N0 => false
| Npos p => Nless_aux a a' p
end.

Lemma Nbit0_less :
forall a a',
N.odd a = false -> N.odd a' = true -> Nless a a' = true.
Proof. hammer_hook "Ndigits" "Ndigits.Nbit0_less".
intros. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless.
rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity.
assert (H1: N.odd (N.lxor a a') = false) by (rewrite H2; reflexivity).
rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1.
simpl. rewrite H, H0. reflexivity.
assert (H2: N.odd (N.lxor a a') = false) by (rewrite H1; reflexivity).
rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2.
Qed.

Lemma Nbit0_gt :
forall a a',
N.odd a = true -> N.odd a' = false -> Nless a a' = false.
Proof. hammer_hook "Ndigits" "Ndigits.Nbit0_gt".
intros. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless.
rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity.
assert (H1: N.odd (N.lxor a a') = false) by (rewrite H2; reflexivity).
rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1.
simpl. rewrite H, H0. reflexivity.
assert (H2: N.odd (N.lxor a a') = false) by (rewrite H1; reflexivity).
rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2.
Qed.

Lemma Nless_not_refl : forall a, Nless a a = false.
Proof. hammer_hook "Ndigits" "Ndigits.Nless_not_refl".
intro. unfold Nless. rewrite (N.lxor_nilpotent a). reflexivity.
Qed.

Lemma Nless_def_1 :
forall a a', Nless (N.double a) (N.double a') = Nless a a'.
Proof. hammer_hook "Ndigits" "Ndigits.Nless_def_1".
destruct a; destruct a'. reflexivity.
trivial.
unfold Nless. simpl. destruct p; trivial.
unfold Nless. simpl. destruct (Pos.lxor p p0). reflexivity.
trivial.
Qed.

Lemma Nless_def_2 :
forall a a',
Nless (N.succ_double a) (N.succ_double a') = Nless a a'.
Proof. hammer_hook "Ndigits" "Ndigits.Nless_def_2".
destruct a; destruct a'. reflexivity.
trivial.
unfold Nless. simpl. destruct p; trivial.
unfold Nless. simpl. destruct (Pos.lxor p p0). reflexivity.
trivial.
Qed.

Lemma Nless_def_3 :
forall a a', Nless (N.double a) (N.succ_double a') = true.
Proof. hammer_hook "Ndigits" "Ndigits.Nless_def_3".
intros. apply Nbit0_less. apply Ndouble_bit0.
apply Ndouble_plus_one_bit0.
Qed.

Lemma Nless_def_4 :
forall a a', Nless (N.succ_double a) (N.double a') = false.
Proof. hammer_hook "Ndigits" "Ndigits.Nless_def_4".
intros. apply Nbit0_gt. apply Ndouble_plus_one_bit0.
apply Ndouble_bit0.
Qed.

Lemma Nless_z : forall a, Nless a N0 = false.
Proof. hammer_hook "Ndigits" "Ndigits.Nless_z".
induction a. reflexivity.
unfold Nless. rewrite (N.lxor_0_r (Npos p)). induction p; trivial.
Qed.

Lemma N0_less_1 :
forall a, Nless N0 a = true -> {p : positive | a = Npos p}.
Proof. hammer_hook "Ndigits" "Ndigits.N0_less_1".
destruct a. discriminate.
intros. exists p. reflexivity.
Qed.

Lemma N0_less_2 : forall a, Nless N0 a = false -> a = N0.
Proof. hammer_hook "Ndigits" "Ndigits.N0_less_2".
induction a as [|p]; intro H. trivial.
exfalso. induction p as [|p IHp|]; discriminate || simpl; auto using IHp.
Qed.

Lemma Nless_trans :
forall a a' a'',
Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true.
Proof. hammer_hook "Ndigits" "Ndigits.Nless_trans".
induction a as [|a IHa|a IHa] using N.binary_ind; intros a' a'' H H0.
- case_eq (Nless N0 a'') ; intros Heqn.
+ trivial.
+ rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0.
- induction a' as [|a' _|a' _] using N.binary_ind.
+ rewrite (Nless_z (N.double a)) in H. discriminate H.
+ rewrite (Nless_def_1 a a') in H.
induction a'' using N.binary_ind.
* rewrite (Nless_z (N.double a')) in H0. discriminate H0.
* rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a'').
exact (IHa _ _ H H0).
* apply Nless_def_3.
+ induction a'' as [|a'' _|a'' _] using N.binary_ind.
* rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
* rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
* apply Nless_def_3.
- induction a' as [|a' _|a' _] using N.binary_ind.
+ rewrite (Nless_z (N.succ_double a)) in H. discriminate H.
+ rewrite (Nless_def_4 a a') in H. discriminate H.
+ induction a'' using N.binary_ind.
* rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
* rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
* rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H.
rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0).
Qed.

Lemma Nless_total :
forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}.
Proof. hammer_hook "Ndigits" "Ndigits.Nless_total".
induction a using N.binary_rec; intro a'.
- case_eq (Nless N0 a') ; intros Heqb.
+ left. left. auto.
+ right. rewrite (N0_less_2 a' Heqb). reflexivity.
- induction a' as [|a' _|a' _] using N.binary_rec.
+ case_eq (Nless N0 (N.double a)) ; intros Heqb.
* left. right. auto.
* right. exact (N0_less_2 _  Heqb).
+ rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->].
* left. assumption.
* right. reflexivity.
+ left. left. apply Nless_def_3.
- induction a' as [|a' _|a' _] using N.binary_rec.
+ left. right. destruct a; reflexivity.
+ left. right. apply Nless_def_3.
+ rewrite 2!Nless_def_2. destruct (IHa a') as [ | ->].
* left. assumption.
* right. reflexivity.
Qed.

Notation Nsize := N.size_nat (compat "8.3").

Fixpoint P2Bv (p:positive) : Bvector (Pos.size_nat p) :=
match p return Bvector (Pos.size_nat p) with
| xH => Bvect_true 1%nat
| xO p => Bcons false (Pos.size_nat p) (P2Bv p)
| xI p => Bcons true (Pos.size_nat p) (P2Bv p)
end.

Definition N2Bv (n:N) : Bvector (N.size_nat n) :=
match n as n0 return Bvector (N.size_nat n0) with
| N0 => Bnil
| Npos p => P2Bv p
end.

Fixpoint Bv2N (n:nat)(bv:Bvector n) : N :=
match bv with
| Vector.nil _ => N0
| Vector.cons _ false n bv => N.double (Bv2N n bv)
| Vector.cons _ true n bv => N.succ_double (Bv2N n bv)
end.

Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n.
Proof. hammer_hook "Ndigits" "Ndigits.Bv2N_N2Bv".
destruct n.
simpl; auto.
induction p; simpl in *; auto; rewrite IHp; simpl; auto.
Qed.

Lemma Bv2N_Nsize : forall n (bv:Bvector n), N.size_nat (Bv2N n bv) <= n.
Proof. hammer_hook "Ndigits" "Ndigits.Bv2N_Nsize".
induction bv; intros.
auto.
simpl.
destruct h;
destruct (Bv2N n bv);
simpl ; auto with arith.
Qed.

Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)),
Bsign _ bv = true <->
N.size_nat (Bv2N _ bv) = (S n).
Proof. hammer_hook "Ndigits" "Ndigits.Bv2N_Nsize_1".
apply Vector.rectS ; intros ; simpl.
destruct a ; compute ; split ; intros x ; now inversion x.
destruct a, (Bv2N (S n) v) ;
simpl ;intuition ; try discriminate.
Qed.

Fixpoint N2Bv_gen (n:nat)(a:N) : Bvector n :=
match n return Bvector n with
| 0 => Bnil
| S n => match a with
| N0 => Bvect_false (S n)
| Npos xH => Bcons true _ (Bvect_false n)
| Npos (xO p) => Bcons false _ (N2Bv_gen n (Npos p))
| Npos (xI p) => Bcons true _ (N2Bv_gen n (Npos p))
end
end.

Lemma N2Bv_N2Bv_gen : forall (a:N), N2Bv a = N2Bv_gen (N.size_nat a) a.
Proof. hammer_hook "Ndigits" "Ndigits.N2Bv_N2Bv_gen".
destruct a; simpl.
auto.
induction p; simpl; intros; auto; congruence.
Qed.

Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat),
N2Bv_gen (N.size_nat a + k) a = Vector.append (N2Bv a) (Bvect_false k).
Proof. hammer_hook "Ndigits" "Ndigits.N2Bv_N2Bv_gen_above".
destruct a; simpl.
destruct k; simpl; auto.
induction p; simpl; intros;unfold Bcons; f_equal; auto.
Qed.

Lemma N2Bv_Bv2N : forall n (bv:Bvector n),
N2Bv_gen n (Bv2N n bv) = bv.
Proof. hammer_hook "Ndigits" "Ndigits.N2Bv_Bv2N".
induction bv; intros.
auto.
simpl.
generalize IHbv; clear IHbv.
unfold Bcons.
destruct (Bv2N _ bv);
destruct h; intro H; rewrite <- H; simpl; trivial;
induction n; simpl; auto.
Qed.

Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)),
N.odd (Bv2N _ bv) = Blow _ bv.
Proof. hammer_hook "Ndigits" "Ndigits.Nbit0_Blow".
apply Vector.caseS.
intros.
unfold Blow.
simpl.
destruct (Bv2N n t); simpl;
destruct h; auto.
Qed.

Notation Bnth := (@Vector.nth_order bool).

Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n),
Bnth bv H = N.testbit_nat (Bv2N _ bv) p.
Proof. hammer_hook "Ndigits" "Ndigits.Bnth_Nbit".
induction bv; intros.
inversion H.
destruct p ; simpl.
destruct (Bv2N n bv); destruct h; simpl in *; auto.
specialize IHbv with p (Lt.lt_S_n _ _ H).
simpl in * ; destruct (Bv2N n bv); destruct h; simpl in *; auto.
Qed.

Lemma Nbit_Nsize : forall n p, N.size_nat n <= p -> N.testbit_nat n p = false.
Proof. hammer_hook "Ndigits" "Ndigits.Nbit_Nsize".
destruct n as [|n].
simpl; auto.
induction n; simpl in *; intros; destruct p; auto with arith.
inversion H.
inversion H.
Qed.

Lemma Nbit_Bth: forall n p (H:p < N.size_nat n),
N.testbit_nat n p = Bnth (N2Bv n) H.
Proof. hammer_hook "Ndigits" "Ndigits.Nbit_Bth".
destruct n as [|n].
inversion H.
induction n ; destruct p ; unfold Vector.nth_order in *; simpl in * ; auto.
intros H ; destruct (Lt.lt_n_O _ (Lt.lt_S_n _ _ H)).
Qed.

Lemma Nxor_BVxor : forall n (bv bv' : Bvector n),
Bv2N _ (BVxor _ bv bv') = N.lxor (Bv2N _ bv) (Bv2N _ bv').
Proof. hammer_hook "Ndigits" "Ndigits.Nxor_BVxor".
apply Vector.rect2 ; intros.
now simpl.
simpl.
destruct a, b, (Bv2N n v1), (Bv2N n v2); simpl in *; rewrite H ; now simpl.
Qed.

Lemma Nand_BVand : forall n (bv bv' : Bvector n),
Bv2N _ (BVand _ bv bv') = N.land (Bv2N _ bv) (Bv2N _ bv').
Proof. hammer_hook "Ndigits" "Ndigits.Nand_BVand".
refine (@Vector.rect2 _ _ _ _ _); simpl; intros; auto.
rewrite H.
destruct a, b, (Bv2N n v1), (Bv2N n v2);
simpl; auto.
Qed.


(** * Trie:  Number representations and efficient lookup tables *)

(* ################################################################# *)
(** * logN penalties in functional programming *)

(** Purely functional algorithms sometimes suffer from an asymptotic
  slowdown of order logN compared to imperative algorithms.  The
  reason is that imperative programs can do _indexed array update_
  in constant time, while functional programs cannot.

  Let's take an example.  Give an algorithm for detecting duplicate
  values in a sequence of N integers, each in the range 0..2N.
  As an imperative program, there's a very simple linear-time algorithm:

  collisions=0;
  for (i=0; i<2N; i++)
     a[i]=0;
  for (j=0; j<N; j++) {
     i = input[j];
     if (a[i] != 0)
       collisions++;
     a[i]=1;
  }
  return collisions;

  In a functional program, we must replace [a[i]=1] with the update
  of a finite map.  If we use the inefficient maps in [Maps.v], each
  lookup and update will take (worst-case) linear time, and the whole
  algorithm is quadratic time.  If we use balanced binary search trees
  [Redblack.v], each lookup and update will take (worst-case) logN time,
  and the whole algorithm takes NlogN.  Comparing O(NlogN) to O(N),
  we see that there is a logN asymptotic penalty for using a functional
  implementation of finite maps.  This penalty arises not only in this
  "duplicates" algorithm, but in any algorithm that relies on random
  access in arrays.

  One way to avoid this problem is to use the imperative (array) features
  of a not-really-functional language such as ML.  But that's not really
  a functional program!  In particular, in _Verified Functional Algorithms_
  we prove program correct by relying on the _tractable proof theory_
  of purely functional programs; if we use nonfunctional features of ML,
  then this style of proof will not work.  We'd have to use something like
  Hoare logic instead (see [Hoare.v] in volume 2 of _Software Foundations_),
  and that is not _nearly_ as nice.

  Another choice is to use a purely functional programming language
  designed for imperative programming:  Haskell with the IO monad.
  The IO monad provides a pure-functional interface to efficient random-access
  arrays.  This might be a reasonable approach, but we will not cover it
  here.

  Here, we accept the logN penalty, and focus on making the "constant
  factors" small: that is, let us at least have efficient functional finite maps.

  [Extract] showed one approach: use Ocaml integers.
  The advantage: constant-time greater-than comparison.
  The disadvantages: (1) Need to make sure you axiomatize them correctly
   in Coq, otherwise your proofs are unsound.  (2) Can't easily axiomatize
   addition, multiplication, subtraction, because Ocaml integers don't
   behave like the "mathematical" integers upon 31-bit (or 63-bit) overflow.
   (3) Can _only_ run the programs in Ocaml, not inside Coq.

   So let's examine another approach, which is quite standard inside Coq:
   use a construction in Coq of arbitrary-precision binary numbers,
   with logN-time addition, subtraction, and comparison. *)

(* ################################################################# *)
(** * A simple program that's waaay too slow. *)

Require Import Perm.
Require Import Maps.
Import FunctionalExtensionality.

Module VerySlow.

Fixpoint loop (input: list nat) (c: nat) (table: total_map bool) : nat :=
  match input with
  | nil => c
  | a::al => if table (Id a)
                  then loop al (c+1) table
                  else loop al c (t_update table (Id a) true)
 end.

Definition collisions (input: list nat) : nat :=
       loop input 0 (t_empty false).

Example collisions_pi: collisions [3;1;4;1;5;9;2;6] = 1.
Proof. reflexivity. Qed.

(** This program takes cubic time, O(N^3).   Let's assume that there are
      few duplicates, or none at all.  There are [N] iterations
      of [loop], each iteration does a [table] lookup, most iterations do
      a [t_update] as well, and those operations each do [N] comparisons.
      The average length of the [table] (the number of elements) averages
      only N/2, and (if there are few duplicates) the lookup will have to
      traverse the entire list, so really in each iteration there will be only
      [N/2] comparisons instead of [N], but in asymptotic analysis we ignore
      the constant factors.

      So far it seems like this is a quadratic-time algorithm, O(N^2).  But
      to compare Coq natural numbers for equality takes O(N) time as well: *)

Print beq_nat.
 (* fix beq_nat (n m : nat) {struct n} : bool :=
  match n with
  | 0 => match m with 0 => true | S _ => false end
  | S n1 => match m with 0 => false | S m1 => beq_nat n1 m1 end
  end *)

(** Remember, [nat] is a unary representation, with a number of [S] constructors
     proportional to the number being represented! *)

End VerySlow.

(* ################################################################# *)
(** * Efficient positive numbers *)
(** We can do better; we _must_ do better.  In fact, Coq's integer type,
     called [Z], is a binary representation (not unary), so that operations
     such as [plus] and [leq] take time linear in the number of bits, that is,
     logarithmic in the value of the numbers.  Here we will explore how [Z]
     is built. *)

Module Integers.

(** We start with positive numbers. *)

Inductive positive : Set :=
  | xI : positive -> positive
  | xO : positive -> positive
  | xH : positive.

(** A positive number is either
     -    1, that is, [xH]
     -    0+2n, that is,  [xO n]
     -    1+2n, that is,  [xI n].
    For example, ten is 0+2(1+2(0+2(1))).
*)

Definition ten := xO (xI (xO xH)).

(** To interpret a [positive] number as a [nat], *)

Fixpoint positive2nat (p: positive) : nat :=
  match p with
  | xI q => 1 + 2 * positive2nat q
  | xO q => 0 + 2 * positive2nat q
  | xH => 1
 end.

Eval compute in positive2nat ten.  (* = 10 : nat *)

(** We can read the binary representation of a positive number
    as the _backwards_ sequence of [xO] (meaning 0) and [xI/xH] (1).
    Thus, ten is 1010 in binary. *)

Fixpoint print_in_binary (p: positive) : list nat :=
  match p with
  | xI q => print_in_binary q ++ [1]
  | xO q =>print_in_binary q ++ [0]
  | xH => [1]
 end.

Eval compute in print_in_binary ten.  (*  = [1; 0; 1; 0] *)

(** Another way to see the "binary representation" is to make up
     postfix notation for [xI] and [xO], as follows *)

Notation "p ~ 1" := (xI p)
 (at level 7, left associativity, format "p '~' '1'").
Notation "p ~ 0" := (xO p)
 (at level 7, left associativity, format "p '~' '0'").

Print ten. (* = xH~0~1~0 : positive *)

(** Why are we using positive numbers anyway?  Since the zero was
    invented 2300 years ago by the Babylonians, it's sort of old-fashioned
    to use number systems that start at 1.

    The answer is that it's highly inconvenient to have number systems
    with several different representations of the same number.
    For one thing, we don't want to worry about  00110=110.
    Then, when we extend this to the integers, with a "minus sign",
    we don't have to worry about -0 = +0.    *)

(**  To find the successor of a binary number--that is to increment--
    we work from low-order to high-order, until we hit a zero bit. *)

Fixpoint succ x :=
  match x with
    | p~1 => (succ p)~0
    | p~0 => p~1
    | xH => xH~0
  end.

(** To add binary numbers, we work from low-order to high-order,
    keeping track of the carry. *)

Fixpoint addc (carry: bool) (x y: positive) {struct x} : positive :=
  match carry, x, y with
    | false, p~1, q~1 => (addc true p q)~0
    | false, p~1, q~0 => (addc false p q)~1
    | false, p~1, xH => (succ p)~0
    | false, p~0, q~1 => (addc false p q)~1
    | false, p~0, q~0 => (addc false p q)~0
    | false, p~0, xH => p~1
    | false, xH, q~1 => (succ q)~0
    | false, xH, q~0 => q~1
    | false, xH, xH => xH~0
    | true, p~1, q~1 => (addc true p q)~1
    | true, p~1, q~0 => (addc true p q)~0
    | true, p~1, xH => (succ p)~1
    | true, p~0, q~1 => (addc true p q)~0
    | true, p~0, q~0 => (addc false p q)~1
    | true, p~0, xH => (succ p)~0
    | true, xH, q~1 => (succ q)~1
    | true, xH, q~0 => (succ q)~0
    | true, xH, xH => xH~1
  end.

Definition add (x y: positive) : positive := addc false x y.

(** **** Exercise: 2 stars (succ_correct)  *)
Lemma succ_correct: forall p,
   positive2nat (succ p) = S (positive2nat p).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (add_correct)  *)
(** You may use [omega] in this proof if you want, along with induction
     of course.  But really, using [omega] is an anachronism in a sense:
     Coq's [omega] uses theorems about [Z] that are proved from theorems about
     Coq's standard-library [positive] that, in turn, rely on a theorem much
     like this one.  So the authors of the Coq standard library had to
     do the associative-commutative rearrangement proofs "by hand."
     But really, here you can use [omega] without penalty. *)

Lemma addc_correct: forall (c: bool) (p q: positive),
   positive2nat (addc c p q) =
        (if c then 1 else 0) + positive2nat p + positive2nat q.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

Theorem add_correct: forall (p q: positive),
   positive2nat (add p q) = positive2nat p + positive2nat q.
Proof.
intros.
unfold add.
apply addc_correct.
Qed.
(** [] *)

(** Claim:  the [add] function on positive numbers takes worst-case time
    proportional to the log base 2 of the result.

    We can't prove this in Coq, since Coq has no cost model for execution.
    But we can prove it informally. Notice that [addc] is structurally recursive
   on [p], that is, the number of recursive calls is at most the height of the
    [p] structure; that's equal to log base 2 of [p] (rounded up to the nearest
    integer). The last call may call [succ q], which is structurally recursive on [q],
    but this [q] argument is what remained of the original [q] after
    stripping off a number of constructors equal to the height of [p].
*)

(** To implement comparison algorithms on positives, the recursion
    (Fixpoint) is easier to implement if we compute not only
    "less-than / not-less-than", but actually, "less / equal / greater".
    To express these choices, we use an Inductive data type. *)

Inductive comparison : Set :=
    Eq : comparison | Lt : comparison | Gt : comparison.

(** **** Exercise: 5 stars (compare_correct)  *)
Fixpoint compare x y {struct x}:=
  match x, y with
    | p~1, q~1 => compare p q
    | p~1, q~0 => match compare p q with Lt => Lt | _ => Gt end
    | p~1, xH => Gt

  (* DELETE THIS CASE!  Replace it with cases that actually work. *)
    | _, _ => Lt
  end.

Lemma positive2nat_pos:
 forall p, positive2nat p > 0.
Proof.
intros.
induction p; simpl; omega.
Qed.

Theorem compare_correct:
 forall x y,
  match compare x y with
  | Lt => positive2nat x < positive2nat y
  | Eq => positive2nat x = positive2nat y
  | Gt => positive2nat x > positive2nat y
 end.
Proof.
induction x; destruct y; simpl.
(* FILL IN HERE *) Admitted.
(** [] *)

(** Claim: [compare x y] takes time proportional to the log base 2 of [x].
     Proof: it's structurally inductive on the height of [x]. *)

(* ================================================================= *)
(** ** Coq's integer type, [Z] *)
(** Coq's integer type is constructed from positive numbers: *)

Inductive Z : Set :=
  | Z0 : Z
  | Zpos : positive -> Z
  | Zneg : positive -> Z.

(** We can construct efficient (logN time) algorithms for operations
   on [Z]:  [add], [subtract], [compare], and so on.  These algorithms
   call upon the efficient algorithms for [positive]s.

   We won't show these here, because in this chapter we now turn
   to efficient maps over positive numbers. *)

End Integers.  (* Hide away our experiments with [positive] *)

(** These types, [positive] and [Z], are part of the Coq standard library.
   We can access them here, because (above) the [Import Perm]
   has also exported [ZArith] to us. *)

Print positive.  (* from the Coq standard library:
  Inductive positive : Set :=
  |  xI : positive -> positive
  | xO : positive -> positive
  | xH : positive *)

Check Pos.compare.  (*   : positive -> positive -> comparison *)
Check Pos.add. (* : positive -> positive -> positive *)

Check Z.add. (* : Z -> Z -> Z *)

(* ================================================================= *)
(** ** From [N*N*N] to [N*N*logN] *)

(** This program runs in [(N^2)*(log N)] time.  The [loop] does [N]
    iterations; the table lookup does [O(N)] comparisons, and each
    comparison takes [O(log N)] time. *)

Module RatherSlow.

Definition total_mapz (A: Type) := Z -> A.

Definition empty {A:Type} (default: A) : total_mapz A := fun _ => default.
Definition update {A:Type} (m : total_mapz A)
                    (x : Z) (v : A) :=
  fun x' => if Z.eqb x x' then v else m x'.

Fixpoint loop (input: list Z) (c: Z) (table: total_mapz bool) : Z :=
  match input with
  | nil => c
  | a::al => if table a
                  then loop al (c+1) table
                  else loop al c (update table a true)
 end.

Definition collisions (input: list Z) := loop input 0 (empty false).

Example collisions_pi: collisions [3;1;4;1;5;9;2;6]%Z = 1%Z.
Proof. reflexivity. Qed.

End RatherSlow.

(* ================================================================= *)
(** ** From [N*N*logN] to [N*logN*logN] *)

(** We can use balanced binary search trees (red-black trees), with
   keys of type [Z].  Then the [loop] does [N] iterations; the table lookup
   does [O(logN)] comparisons, and each comparison takes [O(log N)] time.
   Overall, the asymptotic run time is [N*(logN)^2]. *)

(* ################################################################# *)
(** * Tries: efficient lookup tables on positive binary numbers *)

(** Binary search trees are very nice, because they can implement lookup
    tables from _any_ totally ordered type to any other type.  But when the
    type of keys is known specifically to be (small-to-medium size) integers,
    then we can use a more specialized representation.

    By analogy, in imperative programming languages (C, Java, ML),
    when the index of a table is the integers in a certain range,
    you can use arrays.    When the keys are not integers, you have
    to use something like hash tables or binary search trees.

    A _trie_ is a tree in which the edges are labeled with letters from
    an alphabet, and you look up a word by following edges labeled
    by successive letters of the word.  In fact, a trie is a special case
    of a Deterministic Finite Automaton (DFA) that happens to be a
    tree rather than a more general graph.

   A _binary trie_ is a trie in which the alphabet is just {0,1}.  The "word"
   is a sequence of bits, that is, a binary number.  To look up the "word"
   10001, use 0 as a signal to "go left", and 1 as a signal to "go right."

   The binary numbers we use will be type [positive]:  *)

Print positive.
(* Inductive positive : Set :=
    xI : positive -> positive
 | xO : positive -> positive
 | xH : positive *)

Goal   10%positive = xO (xI (xO xH)).
Proof. reflexivity. Qed.

(** Given a [positive] number such as ten, we will go left to right in
   the [xO/xI/ constructors (which is from the low-order bit to the high-order bit),
   using [xO] as a signal to go left, [xI] as a signal to go right,
   and [xH] as a signal to stop. *)

Inductive trie (A : Type) :=
    | Leaf : trie A
    | Node : trie A -> A -> trie A -> trie A.
Implicit Arguments Leaf [A].
Implicit Arguments Node [A].

Definition trie_table (A: Type) : Type := (A * trie A)%type.

Definition empty {A: Type} (default: A) : trie_table A :=
      (default, Leaf).

Fixpoint look {A: Type} (default: A) (i: positive) (m: trie A): A :=
    match m with
    | Leaf => default
    | Node l x r =>
        match i with
        | xH => x
        | xO i' => look default i' l
        | xI i' => look default i' r
        end
    end.

Definition lookup {A: Type} (i: positive) (t: trie_table A) : A :=
   look (fst t) i (snd t).

Fixpoint ins {A: Type} default (i: positive) (a: A) (m: trie A): trie A :=
    match m with
    | Leaf =>
        match i with
        | xH => Node Leaf a Leaf
        | xO i' => Node (ins default i' a Leaf) default Leaf
        | xI i' => Node Leaf default (ins default i' a Leaf)
        end
    | Node l o r =>
        match i with
        | xH => Node l a r
        | xO i' => Node (ins default i' a l) o r
        | xI i' => Node l o (ins default i' a r)
        end
    end.

Definition insert {A: Type} (i: positive) (a: A) (t: trie_table A)
                 : trie_table A :=
  (fst t, ins (fst t) i a (snd t)).

Definition three_ten : trie_table bool :=
 insert 3 true (insert 10 true (empty false)).

Eval compute in three_ten.
(* = (false,
        Node (Node Leaf false (Node (Node Leaf true Leaf) false Leaf))
                 false
                 (Node Leaf true Leaf))
     : trie_table bool  *)

Eval compute in
   map (fun i => lookup i three_ten) [3;1;4;1;5]%positive.
(*      = [true; false; false; false; false]  : list bool *)

(* ================================================================= *)
(** ** From [N*logN*logN] to [N*logN] *)

Module FastEnough.

Fixpoint loop (input: list positive) (c: nat) (table: trie_table bool) : nat :=
  match input with
  | nil => c
  | a::al => if lookup a table
                  then loop al (1+c) table
                  else loop al c (insert a true table)
 end.

Definition collisions (input: list positive) := loop input 0 (empty false).

Example collisions_pi: collisions [3;1;4;1;5;9;2;6]%positive = 1.
Proof. reflexivity. Qed.

End FastEnough.

(** This program takes [O(N log N)] time:  the loop executes [N]
    iterations, the [lookup] takes [log N] time, the [insert] takes [log N] time.
    One might worry about [1+c] computed in the natural numbers (unary
    representation), but this evaluates in one step to [S c], which
    takes constant time, no matter how long [c] is.  In "real life", one
    might be advised to use [Z] instead of [nat] for the [c] variables,
    in which case, [1+c] takes worst-case [log N], and average-case
    constant time. *)

(** **** Exercise: 2 stars (successor_of_Z_constant_time)  *)
(** Explain why the average-case time for successor of a binary
     integer, with carry, is constant time.  Assume that the input integer
     is random (uniform distribution from 1 to N), or assume that
     we are iterating successor starting at 1, so that each number
     from 1 to N is touched exactly once -- whichever way you like. *)

(* [explain here]
*)
(** [] *)

(* ################################################################# *)
(** * Proving the correctness of trie tables *)

(** Trie tables are just another implementation of the [Maps]
     abstract data type.  What we have to prove is the same as usual for an ADT:
     define a representation invariant, define an abstraction relation, prove
     that the operations respect the invariant and the abstraction relation.

     We will indeed do that.  But this time we'll take a different approach.
     Instead of defining a "natural" abstraction relation based on what
     we see in the data structure, we'll define an abstraction relation
     that says, "what you get is what you get."    This will work, but it means
     we've moved the work into directly proving some things about the
     relation between the [lookup] and the [insert] operators. *)

(* ================================================================= *)
(** ** Lemmas about the relation between [lookup] and [insert] *)

(** **** Exercise: 1 star (look_leaf)  *)
Lemma look_leaf:
 forall A (a:A) j, look a j Leaf = a.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (look_ins_same)  *)
(** This is a rather simple induction. *)

Lemma look_ins_same: forall {A} a k (v:A) t, look a k (ins a k v t) = v.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (look_ins_same)  *)
(** Induction on j? Induction on t?   Do you feel lucky? *)

Lemma look_ins_other: forall {A} a j k (v:A) t,
   j <> k -> look a j (ins a k v t) = look a j t.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Bijection between [positive] and [nat]. *)

(** In order to relate [lookup] on positives to [total_map] on nats,
   it's helpful to have a bijection between [positive] and [nat].
   We'll relate [1%positive] to [0%nat],  [2%positive] to [1%nat], and so on. *)

Definition nat2pos (n: nat) : positive := Pos.of_succ_nat n.
Definition pos2nat (n: positive) : nat := pred (Pos.to_nat n).

Lemma pos2nat2pos: forall p, nat2pos (pos2nat p) = p.
Proof. (* You don't need to read this proof! *)
intro. unfold nat2pos, pos2nat.
rewrite <- (Pos2Nat.id p) at 2.
destruct (Pos.to_nat p) eqn:?.
pose proof (Pos2Nat.is_pos p). omega.
rewrite <- Pos.of_nat_succ.
reflexivity.
Qed.

Lemma nat2pos2nat: forall i, pos2nat (nat2pos i) = i.
Proof. (* You don't need to read this proof! *)
intro. unfold nat2pos, pos2nat.
rewrite SuccNat2Pos.id_succ.
reflexivity.
Qed.

(** Now, use those two lemmas to prove that it's really a bijection! *)

(** **** Exercise: 2 stars (pos2nat_bijective)  *)
Lemma pos2nat_injective: forall p q, pos2nat p = pos2nat q -> p=q.
(* FILL IN HERE *) Admitted.

Lemma nat2pos_injective: forall i j, nat2pos i = nat2pos j -> i=j.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Proving that tries are a "table" ADT. *)

(** Representation invariant.  Under what conditions is a trie well-formed?
    Fill in the simplest thing you can, to start; then correct it later as necessary. *)

Definition is_trie {A: Type} (t: trie_table A) : Prop
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** Abstraction relation.  This is what we mean by, "what you get is what you get."
   That is, the abstraction of a [trie_table] is the total function,
    from naturals to [A] values, that  you get by running the [lookup] function.
    Based on this abstraction relation, it'll be trivial to prove [lookup_relate].
    But [insert_relate] will NOT be trivial. *)

Definition abstract {A: Type} (t: trie_table A) (n: id) : A :=
  match n with Id n' => lookup (nat2pos n') t end.

Definition Abs {A: Type} (t: trie_table A) (m: total_map A) :=
  abstract t = m.

(** **** Exercise: 2 stars (is_trie)  *)
(** If you picked a _really simple_ representation invariant, these should be easy.
    Later, if you need to change the representation invariant in order to
    get the [_relate] proofs to work, then you'll need to fix these proofs. *)

Theorem empty_is_trie: forall {A} (default: A), is_trie (empty default).
(* FILL IN HERE *) Admitted.

Theorem insert_is_trie: forall {A} i x (t: trie_table A),
   is_trie t -> is_trie (insert i x t).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (empty_relate)  *)
(** Just unfold a bunch of definitions, use [extensionality], and
    use one of the lemmas you proved above, in the section
    "Lemmas about the relation between [lookup] and [insert]." *)

Theorem empty_relate: forall {A} (default: A),
    Abs (empty default) (t_empty default).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (lookup_relate)  *)
(** Given the abstraction relation we've chosen, this one should be really simple. *)

Theorem lookup_relate: forall {A} i (t: trie_table A) m,
    is_trie t -> Abs t m -> lookup i t = m (Id (pos2nat i)).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (insert_relate)  *)
(** Given the abstraction relation we've chosen, this one should NOT be simple.
   However, you've already done the heavy lifting, with the lemmas
  [look_ins_same] and [look_ins_other].   You will not need induction here.
  Instead, unfold a bunch of things, use extensionality, and get to a case analysis
  on whether [pos2nat k =? pos2nat j].   To handle that case analysis,
   use [bdestruct]. You may also need [pos2nat_injective]. *)

Theorem insert_relate: forall {A} k (v: A) t cts,
    is_trie t ->
    Abs t cts ->
    Abs (insert k v t) (t_update cts (Id (pos2nat k)) v).
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Sanity check *)

Example Abs_three_ten:
    Abs
       (insert 3 true (insert 10 true (empty false)))
       (t_update (t_update (t_empty false) (Id (pos2nat 10)) true) (Id (pos2nat 3)) true).
Proof.
try (apply insert_relate; [hnf; auto | ]).
try (apply insert_relate; [hnf; auto | ]).
try (apply empty_relate).
(* Change this to Qed once you have [is_trie] defined and working. *)
(* FILL IN HERE *) Admitted.

(* ################################################################# *)
(** * Conclusion *)
(** Efficient functional maps with (positive) integer keys are one of the most
   important data structures in functional programming.  They are used for
  symbol tables in compilers and static analyzers; to represent directed graphs
  (the mapping from node-ID to edge-list); and (in general) anywhere that
  an imperative algorithm uses an array or _requires_ a mutable pointer.

  Therefore, these _tries_ on positive numbers are very important in Coq programming.
  They were introduced by Xavier Leroy and Sandrine Blazy in the CompCert
  compiler (2006), and are now available in the Coq standard library as the
  [PositiveMap] module, which implements the [FMaps] interface.
  The core implementation of [PositiveMap] is just as shown in this chapter,
  but [FMaps] uses different names for the functions [insert] and [lookup],
  and also provides several other operations on maps.  *)


(* ******************************************************************************* *)
(** * Bicategory of graphs
    Benedikt Ahrens, Marco Maggesi
    May 2018
    Revised June 2019
 ********************************************************************************* *)

Require Import UniMath.MoreFoundations.Notations.
Require Import UniMath.MoreFoundations.Propositions.

(** ** Pregraphs. *)

Definition pregraph : UU
  := ∑ N : UU, N → N → UU.

Definition make_pregraph
  : ∏ N : UU, (N → N → UU) → pregraph
  := tpair _.

Definition vertex : pregraph → UU := pr1.

Definition edge
  : ∏ G : pregraph, vertex G → vertex G → UU
  := pr2.

Definition has_vertexset (G : pregraph) : UU
  := isaset (vertex G).

Definition isaprop_has_vertexset (G : pregraph)
  : isaprop (has_vertexset G)
  := isapropisaset (vertex G).

Definition has_edgesets (G : pregraph) : UU
  := ∏ x y : vertex G, isaset (edge G x y).

(** ** Graphs. *)

Definition graph : UU
  := ∑ G : pregraph, has_vertexset G × has_edgesets G.

Definition make_graph (G : pregraph)
           (h : has_vertexset G)
           (k : has_edgesets G)
  : graph
  := G,, make_dirprod h k.

Definition pregraph_of_graph : graph → pregraph := pr1.
Coercion pregraph_of_graph : graph >-> pregraph.

Definition isaset_vertex (G : graph)
  : isaset (vertex G)
  := pr12 G.

Definition isaset_edge (G : graph)
  : ∏ x y : vertex G, isaset (edge G x y)
  := pr22 G.

(** ** Graph morphisms. *)

Definition graph_mor (G H : pregraph) : UU :=
  ∑ (f₀ : vertex G → vertex H),
  (∏ x y : vertex G, edge G x y → edge H (f₀ x) (f₀ y)).

Definition make_graph_mor {G H : pregraph}
  : ∏ (f₀ : vertex G → vertex H)
      (f₁ : ∏ x y : vertex G, edge G x y → edge H (f₀ x) (f₀ y)),
    graph_mor G H
  := tpair _.

Definition onvertex {G H : pregraph}
  : ∏ (p : graph_mor G H), vertex G → vertex H
  := pr1.

Definition onedge {G H : pregraph} (p : graph_mor G H) {x y : vertex G}
  : edge G x y → edge H (onvertex p x) (onvertex p y)
  := pr2 p x y.

Definition graph_mor_id (G : pregraph)
  : graph_mor G G
    := make_graph_mor
         (idfun (vertex G))
         (λ x y : vertex G, idfun (edge G x y)).

Definition graph_mor_comp {G H K: pregraph}
           (p : graph_mor G H) (q : graph_mor H K)
  : graph_mor G K
  := make_graph_mor
       (onvertex q ∘ onvertex p)
         (λ (x y : vertex G) (f : edge G x y), onedge q (pr2 p x y f)).

Lemma make_graph_mor_eq {G H : pregraph}
      (p₀ : vertex G → vertex H)
      (p₁ p₁' : ∏ x y : vertex G, edge G x y → edge H (p₀ x) (p₀ y))
      (e : ∏ x y (f : edge G x y), p₁ x y f = p₁' x y f)
  : make_graph_mor p₀ p₁ = make_graph_mor p₀ p₁'.
Proof.
  apply pair_path_in2.
  apply funextsec. intro x.
  apply funextsec. intro y.
  apply funextfun. intro f.
  apply e.
Defined.

Lemma graph_mor_id_left {G H : pregraph} (p : graph_mor G H) :
  graph_mor_comp (graph_mor_id G) p = p.
Proof.
  induction p as (p₀,p₁).
  apply make_graph_mor_eq.
  intros. apply idpath.
Defined.

Lemma graph_mor_id_right {G H : pregraph} (p : graph_mor G H) :
  graph_mor_comp p (graph_mor_id H) = p.
Proof.
  induction p as (p₀,p₁).
  apply make_graph_mor_eq.
  intros. apply idpath.
Defined.

Lemma graph_mor_comp_assoc {G1 G2 G3 G4 : pregraph}
      (p : graph_mor G1 G2) (q : graph_mor G2 G3) (r : graph_mor G3 G4)
  : graph_mor_comp p (graph_mor_comp q r) =
    graph_mor_comp (graph_mor_comp p q) r.
Proof.
  induction p as (p₀,p₁).
  induction q as (q₀,q₁).
  induction r as (r₀,r₁).
  apply make_graph_mor_eq.
  intros. apply idpath.
Qed.

Lemma isaset_graph_mor {G H : pregraph}
      (h : has_vertexset H) (k : has_edgesets H)
  : isaset (graph_mor G H).
Proof.
  apply isaset_total2.
  - exact (funspace_isaset h).
  - intro p₀.
    apply impred_isaset. intro x.
    apply impred_isaset. intro y.
    apply funspace_isaset.
    apply k.
Qed.


Require Import Real.

Section Minmax.
  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  Definition real_is_max (x y z : Real)
    := (x > y -> z = x) /\ (x = y -> z = x) /\ (x < y -> z = y).

  Lemma real_is_max_or : forall x y z, real_is_max x y z -> (x = z) \/ (y = z).
  Proof.
    intros x y z m.
    destruct m as [a [b c]].
    destruct (real_total_order x y) as [p1 | [p2 | p3]].
    right; rewrite (c p1); exact eq_refl.
    left; rewrite (b p2); exact eq_refl.
    left; rewrite (a p3); exact eq_refl.
  Qed.

  Lemma real_is_max_Or : forall x y z, real_is_max x y z -> (x=z /\ x>=y) \/ (y=z /\ y>=x).
  Proof.
    intros x y z m.
    destruct m as [a [b c]].
    destruct (real_total_order x y) as [p1 | [p2 | p3]].
    right; rewrite (c p1); split; auto with real.
    left; rewrite (b p2); split; auto with real.
    left; rewrite (a p3); split; auto with real.
  Qed.

  Lemma real_W_max_prop : forall x y, (exists z, real_is_max x y z).
  Proof.
    intros x y.
    destruct (real_total_order x y) as [c1 | [c2 | c3]]; unfold real_is_max.

    exists y.
    split; auto.
    intro H; contradict H; apply real_lt_nlt; auto.

    exists x.
    split; auto.

    exists x.
    split; auto.
    split; auto.
    intro H; contradict c3; apply real_lt_nlt; auto.
  Qed.
  Local Hint Resolve real_is_max_or real_is_max_Or real_W_max_prop: real.

  (***************************************************************)
  (** ** min                                                     *)
  (***************************************************************)
  Definition real_is_min (x y z : Real)
    := (x > y -> z = y) /\ (x = y -> z = x) /\ (x < y -> z = x).

  Lemma real_is_min_or : forall x y z, real_is_min x y z -> (x = z) \/ (y = z).
  Proof.
    intros x y z m.
    destruct m as [a [b c]].
    destruct (real_total_order x y) as [p1 | [p2 | p3]].
    left; rewrite (c p1); exact eq_refl.
    left; rewrite (b p2); exact eq_refl.
    right; rewrite (a p3); exact eq_refl.
  Qed.

  Lemma real_is_min_Or : forall x y z, real_is_min x y z -> (x=z /\ y>=x) \/ (y=z /\ x>=y).
  Proof.
    intros x y z m.
    destruct m as [a [b c]].
    destruct (real_total_order x y) as [p1 | [p2 | p3]].
    left; rewrite (c p1); split; auto with real.
    left; rewrite (b p2); split; auto with real.
    right; rewrite (a p3); split; auto with real.
  Qed.

  Lemma real_is_min_whatever_r : forall x y z, real_is_min x y z -> (z <= y).
  Proof.
    intros.
    destruct (real_is_min_Or x y z H).
    destruct H0.
    rewrite H0 in H1; auto with real.
    destruct H0; right; rewrite H0;  exact eq_refl.
  Qed.

  Lemma real_is_min_whatever_l : forall x y z, real_is_min x y z -> (z <= x).
  Proof.
    intros.
    destruct (real_is_min_Or x y z H).
    destruct H0.
    destruct H0; right; exact eq_refl.
    destruct H0.

    rewrite H0 in H1; auto with real.
  Qed.

  Lemma real_W_min_prop : forall x y, (exists z, real_is_min x y z).
  Proof.
    intros x y.
    destruct (real_total_order x y) as [c1 | [c2 | c3]]; unfold real_is_min.

    exists x.
    split; auto.
    intro Hl; contradict c1; apply real_lt_nlt; auto.

    exists x.
    split; auto.

    exists y.
    split; auto.
    split; auto.
    intro H; contradict c3; apply real_lt_nlt; auto.
  Qed.
  Local Hint Resolve real_is_min_or  real_W_min_prop: real.

  Lemma real_max_prop : forall x y, {z | real_is_max x y z}.
  Proof.
    intros.
    apply real_mslimit_P_lt.
    + (* max is single valued predicate *)
      unfold unique.
      pose proof (real_W_max_prop x y).
      destruct H as [m H].
      exists m.
      split; auto.
      intros m' H'.
      destruct (real_is_max_Or x y m H) as [[H11 H12]|[H11 H12]];
        destruct (real_is_max_Or x y m' H') as [[H11' H12']|[H11' H12']];
        try rewrite <- H11; try rewrite <- H11'; auto with real.
      apply real_ge_ge_eq; auto.
      apply real_ge_ge_eq; auto.
    + (* construct limit *)
      intros.
      apply (mjoin (x>y - prec n) (y > x - prec n)).
      ++ intros [c1|c2].
         +++ (* when x>y-2ⁿ *)
           exists x.
           destruct (real_W_max_prop x y).
           exists x0.
           constructor; auto.
           destruct (real_is_max_Or x y x0 H) as [[H1 _]|[H1 H2]].
           ++++ rewrite H1.
                destruct (dist_zero x0 x0) as [o t]; rewrite (t eq_refl).
                apply prec_pos.

           ++++ rewrite <- H1.
                pose proof (prec_pos n) as P.
                apply (real_lt_plus_lt y real_0 (prec n)) in P; ring_simplify in P.
                apply (real_ge_le) in H2.
                apply (real_le_lt_lt x y (y+prec n) H2) in P.
                assert (y-prec n < x < y+prec n) by auto.
                pose proof (prec_pos n) as Q.
                rewrite (dist_symm).
                apply (real_metric_gtgt_sand y x (prec n) Q H0).

         +++ (* when x<y-2ⁿ *)
           exists y.
           destruct (real_W_max_prop x y).
           exists x0.
           constructor; auto.
           destruct (real_is_max_Or x y x0 H) as [[H1 H2]|[H1 _]].
           ++++ rewrite <- H1.
                pose proof (prec_pos n) as P.
                apply (real_lt_plus_lt x real_0 (prec n)) in P; ring_simplify in P.
                apply (real_ge_le) in H2.
                apply (real_le_lt_lt y x (x+prec n) H2) in P.
                assert (x-prec n < y < x+prec n) by auto.
                pose proof (prec_pos n) as Q.
                rewrite (dist_symm).
                apply (real_metric_gtgt_sand x y (prec n) Q H0).
           ++++ rewrite H1.
                destruct (dist_zero x0 x0) as [o t]; rewrite (t eq_refl).
                apply @prec_pos.

      ++ apply M_split.
         apply @prec_pos.
  Defined.

  Lemma real_min_prop : forall x y, {z | real_is_min x y z}.
  Proof.
    intros x y.
    pose proof (real_max_prop (-x) (-y)) as [m rel].
    exists (-m).
    destruct rel as [a [b c]].
    split.
    intro
    + apply (real T_lt_plus_lt (-x-y)) in H.
    apply (real_lt_plus_lt (- x - y)) in H;
    ring_simplify in H.
      apply c in H.
      rewrite H; ring.

    + split.
    ++
        intro.
        rewrite H in b at 1.
        rewrite (b eq_refl); ring.

      ++
        intro.
        apply (real_lt_plus_lt (-x-y)) in H.
        ring_simplify in H.
        apply a in H.
        rewrite H; ring.
  Defined.

  Definition real_max (x y : Real) := projP1 _ _ (real_max_prop x y).

  (* properties of max function *)

  Lemma real_max_eq_fst_le : forall x y z, (real_max x y) = z -> x <= z.
  Proof.
    intros.
    unfold real_max in H.
    destruct (real_max_prop x y).
    destruct r.
    destruct a.
    simpl in H.
    destruct (real_total_order x y).
    pose proof (e1 H0).
    induction (eq_sym H1).
    induction (eq_sym H).

    left; exact H0.
    destruct H0.
    induction H0.
    induction (e0 eq_refl).
    right; exact H.
    induction (e H0).
    induction (eq_sym H).
    right; exact (eq_refl).
  Qed.

  Lemma real_max_sym : forall x y, (real_max x y) = (real_max y x).
  Proof.
    intros.
    unfold real_max.
    destruct (real_max_prop x y).
    destruct (real_max_prop y x).
    simpl.
    destruct r.
    destruct H0.
    destruct r0.
    destruct H3.
    destruct (real_total_order x y).
    rewrite (H1 H5).
    rewrite (H2 H5).
    auto.
    destruct H5.
    rewrite (H0 H5).
    rewrite (H3 (eq_sym H5)).
    auto.
    rewrite (H H5).
    rewrite (H4 H5).
    auto.
  Qed.

  Lemma real_max_cand : forall x y, (real_max x y) =  x \/ (real_max x y) =  y.
  Proof.
    intros.
    unfold real_max.
    destruct (real_max_prop x y).
    simpl.
    destruct r as [p [q r]].
    destruct (real_total_order x y).
    right; apply r; exact H.
    destruct H.
    left; apply q; exact H.
    left; apply p; exact H.
  Qed.

  Lemma real_max_eq_snd_le : forall x y z, (real_max x y) = z -> y <= z.
  Proof.
    intros.
    rewrite real_max_sym in H.
    apply (real_max_eq_fst_le y x).
    exact H.
  Qed.

  Lemma real_max_fst_ge_ge : forall x y z, x >= z -> (real_max x y) >= z.
  Proof.
    intros.
    unfold real_max.
    destruct (real_max_prop x y).
    destruct r.
    destruct a.
    simpl.
    destruct (real_total_order x y).
    pose proof (e1 H0).
    induction (eq_sym H1).
    destruct H.
    left; apply (real_lt_lt_lt _ _ _ H H0).
    left; rewrite <- H; exact H0.
    destruct H0.
    induction H0.
    rewrite (e0 eq_refl).
    exact H.
    rewrite (e H0).
    exact H.
  Qed.

  Lemma real_max_snd_ge_ge : forall x y z, y >= z -> (real_max x y) >= z.
  Proof.
    intros.
    rewrite real_max_sym.
    apply (real_max_fst_ge_ge y x).
    exact H.
  Qed.

  Lemma real_max_fst_ge : forall x y, (real_max x y) >= x.
  Proof.
    intros.
    apply (real_max_fst_ge_ge _ _ x).
    right; auto.
  Qed.

  Lemma real_max_snd_ge : forall x y, (real_max x y) >= y.
  Proof.
    intros.
    apply (real_max_snd_ge_ge _ _ y).
    right; auto.
  Qed.

  Lemma real_max_le_fst_le : forall x y z, (real_max x y) <= z -> x <= z.
  Proof.
    unfold real_max.
    intros.
    destruct (real_max_prop x y).
    simpl in H.
    destruct r as [p [q r]].
    destruct (real_total_order x y).
    induction (eq_sym (r H0)).

    left; apply (real_lt_le_lt _ _ _ H0 H).
    destruct H0.
    induction H0.
    induction (eq_sym (q eq_refl)).
    exact H.
    induction (eq_sym (p H0)).
    exact H.
  Qed.

  Lemma real_max_le_snd_le : forall x y z, (real_max x y) <= z -> y <= z.
  Proof.
    intros.
    rewrite real_max_sym in H.
    apply (real_max_le_fst_le y x).
    exact H.
  Qed.

  Lemma real_max_le_le_le : forall x y z, x<= z -> y <= z -> (real_max x y) <= z.
  Proof.
    intros.
    destruct (real_max_cand x y).
    rewrite H1; auto.
    rewrite H1; auto.
  Qed.

  Lemma real_le_ge_eq : forall x y  : Real, x <= y -> x >= y -> x = y.
  Proof.
    intros.
    destruct H, H0.
    induction (real_lt_nlt _ _ H H0).
    rewrite H0 in H; induction (real_nlt_triv _ H).
    rewrite H in H0 ; induction (real_nlt_triv _ H0).
    exact H.
  Qed.

  Lemma real_abs_le0_eq0 : forall x : Real, abs x <= real_0 -> x = real_0.
  Proof.
    intros.
    pose proof (abs_pos x).
    destruct H, H0.
    induction (real_lt_nlt _ _ H H0).
    rewrite H0 in H; induction (real_nlt_triv _ H).
    rewrite H in H0 ; induction (real_nlt_triv _ H0).
    exact (proj1 (abs_zero x) H ).
  Qed.

  Lemma real_max_plus_eq : forall a b c : Real, c + real_max a b = real_max (a + c) (b + c).
  Proof.
    intros.
    unfold real_max.
    destruct (real_max_prop (a + c) (b + c)),  (real_max_prop a b).
    destruct r.
    destruct a0.
    destruct r0.
    destruct a0.
    simpl.
    destruct (real_total_order a b).
    rewrite (e4 H).
    rewrite real_plus_comm; apply eq_sym, e1.
    apply (real_lt_plus_r_lt c) in H; exact H.
    destruct H.
    induction H.
    rewrite (e3 eq_refl).
    rewrite (e0 eq_refl); ring.
    rewrite (e2 H).
    rewrite (real_plus_comm); apply eq_sym, e.
    apply (real_lt_plus_r_lt c) in H; exact H.
  Qed.

  Lemma real_max_fst_le_le : forall a b c , a <= b -> a <= real_max b c.
  Proof.
    intros.
    unfold real_max.
    destruct (real_max_prop b c).
    simpl.
    destruct r.
    destruct H1.
    destruct (real_total_order b c).
    rewrite (H2 H3).
    left; apply (real_le_lt_lt _ _ _ H H3).
    destruct H3.
    induction H3.
    rewrite (H1 eq_refl); auto.
    rewrite (H0 H3); auto.
  Defined.

  Lemma real_max_snd_le_le : forall a b c , a <= b -> a <= real_max c b.
  Proof.
    intros.
    rewrite (real_max_sym).
    apply real_max_fst_le_le.
    exact H.
  Qed.

  Lemma real_max_compwise_le : forall a b c d, a <= b -> c <= d -> (real_max a c) <= (real_max b d).
  Proof.
    intros.
    pose proof (real_max_fst_le_le _ _ d H).
    pose proof (real_max_snd_le_le _ _ b H0).
    apply (real_max_le_le_le _ _ _ H1 H2).
  Qed.

End Minmax.
(*  Hint Resolve real_is_max_or real_is_max_Or real_W_max_prop_prop: real. *)
(* Global Hint Resolve real_is_min_or  real_W_real_min_prop: real. *)


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch06_out_lines.

Section tarski_s_euclid_remove_degenerated_cases.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma tarski_s_euclid_remove_degenerated_cases :
  (forall A B C D T,
   A <> B ->
   A <> C ->
   A <> D ->
   A <> T ->
   B <> C ->
   B <> D ->
   B <> T ->
   C <> D ->
   C <> T ->
   D <> T ->
   ~ Col A B C ->
   Bet A D T ->
   Bet B D C ->
   ~ Col B C T ->
   exists x y : Tpoint, Bet A B x /\ Bet A C y /\ Bet x T y) ->
  forall A B C D T,
  Bet A D T ->
  Bet B D C ->
  A <> D -> exists x y : Tpoint, Bet A B x /\ Bet A C y /\ Bet x T y.
Proof.
intro HGC; intros A B C D T HADT HBDC HAD.
elim (eq_dec_points A B); intro HAB.
subst; exists T; exists C; Between.
elim (eq_dec_points A C); intro HAC.
subst; exists B; exists T; Between.
elim (eq_dec_points A T); intro HAT.
exfalso; apply HAD; treat_equalities; reflexivity.
elim (eq_dec_points B C); intro HBC.
treat_equalities; exists T; exists T; Between.
elim (eq_dec_points B D); intro HBD.
subst; exists T; exists C; Between.
elim (eq_dec_points B T); intro HBT.
subst; exists T; exists C; Between.
elim (eq_dec_points C D); intro HCD.
subst; exists B; exists T; Between.
elim (eq_dec_points C T); intro HCT.
subst; exists B; exists T; Between.
elim (eq_dec_points D T); intro HDT.
subst; exists B; exists C; Between.
elim (col_dec A B C); intro HABC.

  {
  elim HABC; clear HABC; intro HABC.

    {
    assert (H : Bet A B D) by eBetween; assert (Bet A B T) by eBetween.
    exists T; exists C; Between.
    }

    {
    elim HABC; clear HABC; intro HABC.

      {
      assert (H : Bet A C D) by eBetween; assert (Bet A C T) by eBetween.
      exists B; exists T; Between.
      }

      {
      assert (H : Bet B A D \/ Bet B D A) by (apply l5_3 with C; Between).
      elim H; clear H; intro H.

        {
        assert (H' : Bet A C T \/ Bet A T C) by (apply l5_2 with B; eBetween).
        elim H'; clear H'; intro H'.

          {
          exists B; exists T; Between.
          }

          {
          exists B; exists C; repeat split; Between; eBetween.
          }
        }
        {
        assert (H' : Bet A B T \/ Bet A T B) by (apply l5_1 with D; Between).
        elim H'; clear H'; intro H'.

          {
          exists T; exists C; Between.
          }

          {
          exists B; exists C; repeat split; Between; eBetween.
          }
        }
      }
    }
  }
  {
  assert (~ Col B C T) by (intro; apply HABC, col_permutation_2, (colx D T); Col).
  apply HGC with D; assumption.
  }
Qed.

End tarski_s_euclid_remove_degenerated_cases.