Require Import String.
Require Import List.

(* utils *)

Check exist.

Definition ret {A : Type} (x : A) := Some x.

Definition bind {A B : Type} (a : option A) (f : A -> option B) : option B :=
  match a with
    | Some x => f x
    | None => None
  end.

Definition guard (b : bool) : option unit := if b then Some tt else None.

Hint Unfold ret bind guard.

Notation "A >>= F" := (bind A F) (at level 42, left associativity).

Notation "X <-- A ; B" :=
  (bind A (fun X => B))
  (right associativity, at level 60).

Notation "'[' x ',' H ']' <-- A ; B" :=
  (match A with
  | Some (exist _ x H) => B
  | None => None
  end)
  (right associativity, at level 60).

Notation "A ;; B" :=
  (bind A (fun _ => B))
  (right associativity, at level 60).

(* tactics *)

Ltac try_inv :=
  match goal with
  | [ H : _ |- _ ] => solve [inversion H; auto]
  | _ => idtac
  end.

Ltac ind_rem h b Hb :=
  remember h as b eqn:Hb;
  (* apply eq_sym in Hb; *)
  induction b;
  cbn in *;
  try_inv.

Ltac di h := destruct h; try_inv; cbn in *.

(* main *)

Definition var := string.
(*
Eval compute in (if string_dec "a" "b" then 1 else 2). (* porównanie napisów *)
Eval compute in (if string_dec "a" "a" then 1 else 2). (* porównanie napisów *)
*)

Inductive type :=
(* | typebool : type *)
| typevar : var -> type
| typelam : type -> type -> type
.
Notation "a ~> b" :=
  (typelam a b)
  (at level 62, right associativity)
.
Fixpoint type_eq (a b : type) : bool :=
  match a, b with
  (* | typebool, typebool => true *)
  | typevar x, typevar y => if string_dec x y then true else false
  | a1 ~> a2, b1 ~> b2 => andb (type_eq a1 b1) (type_eq a2 b2)
  | _, _ => false
  end
.
Inductive term :=
(* | termbool : bool -> term
| termif : term -> term -> term -> term *)
| termvar : var -> term
| lam : var -> type -> term -> term
| termapp : term -> term -> term
.
Notation "M · N" :=
  (termapp M N)
  (at level 61, left associativity)
.
Definition ctx := list (var * type)
.
Fixpoint lookup (G : ctx) (x : var) : option type :=
  match G with
  | nil => None
  | (v, t) :: G' => if string_dec v x then Some t else lookup G' x
  end
.
Inductive has_type : ctx -> term -> type -> Prop :=
(* | bool_has_type : forall G b, has_type G (termbool b) typebool
| if_has_type : forall G b c1 c2 a,
  has_type G b typebool ->
  has_type G c1 a ->
  has_type G c2 a ->
  has_type G (termif b c1 c2) a *)
| var_has_type : forall G x a, lookup G x = Some a -> has_type G (termvar x) a
| lam_has_type : forall G x M (a b : type),
  has_type ((x, b) :: G) M a ->
  has_type G (lam x b M) (b ~> a)
| app_has_type : forall G (M N : term) (a b : type),
  has_type G M (a ~> b) -> has_type G N a -> has_type G (M · N) b
.
Hint Constructors has_type term type.

Inductive iterm :=
(* | itermbool : bool -> iterm *)
(* | itermif : cterm -> cterm -> cterm -> iterm *)
| itermvar : var -> iterm
| ilam : var -> type -> cterm -> iterm
| itermapp : cterm -> cterm -> iterm
with cterm :=
| C : iterm -> cterm
.

Fixpoint term_to_iterm M :=
  let I x := C (term_to_iterm x) in
  match M with
  (* | termbool b => itermbool b *)
  (* | termif b c1 c2 => itermif (I b) (I c1) (I c2) *)
  | termvar x => itermvar x
  | lam x a N => ilam x a (I N)
  | termapp M1 M2 => itermapp (I M1) (I M2)
  end
.

Definition unC cM :=
  match cM with
  | C M => M
  end.
Hint Unfold unC.

Fixpoint iterm_to_term iM :=
  let T x := iterm_to_term (unC x) in
  match iM with
  (* | itermbool b => termbool b *)
  (* | itermif (C b) (C c1) (C c2) => termif (T b) (T c1) (T c2) *)
  | itermvar x => termvar x
  | ilam x a cN => lam x a (T cN)
  | itermapp cM1 cM2 => (T cM1) · (T cM2)
  end
.

Program Fixpoint infer (G : ctx) (M : iterm) :
    option { A : type | has_type G (iterm_to_term M) A } :=
  match M with
  (* | itermbool _ => ret (exist typebool _) *)
  (* | itermif cb (C c1) cc2 =>
    check G cb typebool ;;
    a <-- infer G c1 ;
    check G cc2 a ;;
    ret a *)
  | itermvar x =>
    a <-- lookup G x ;
    ret (exist _ a (var_has_type G x a _))
  | ilam x a (C N) =>
    [b, H] <-- infer ((x, a) :: G) N ;
    ret (exist _ (a ~> b) _)
  | itermapp (C M1) cM2 =>
    match infer G M1 with
    | Some (exist _ (a ~> b) Hm1) =>
      [a', Hm2] <-- check G cM2 a ;
      ret (exist _ b _)
    | _ => None
    end
  end
with check (G : ctx) (M : cterm) (A : type) :
    option { A : type | has_type G (iterm_to_term (unC M)) A } :=
  match M with
  | C M =>
    [a, H] <-- infer G M ;
    guard (type_eq A a) ;;
    ret (exist _ A _)
  end
.
Obligation 1 of infer.

Definition vx := termvar "x"%string.
Definition vy := termvar "y"%string.
Definition vz := termvar "z"%string.
Definition va := typevar "a"%string.
Definition vb := typevar "b"%string.
Definition vc := typevar "c"%string.
Compute infer nil (lam "x"%string va vx).
Compute infer nil
  (lam "x"%string (vb ~> vc)
    (lam "y"%string (va ~> vb)
      (lam "z"%string va (vx · (vy · vz))))).

Lemma from_guard_type_eq : forall a b, Some tt = guard (type_eq a b) -> a = b.
Proof.
  intros.
  generalize dependent b. induction a; intros.
  { ind_rem (type_eq typebool b) t Ht. di b. }
  { ind_rem (type_eq (typevar v) b) t Ht. di b. di (string_dec v v0). }
  { ind_rem (type_eq (a1 ~> a2) b) t Ht. di b.
    ind_rem (type_eq a1 b1) t1 Ht1.
    assert (guard (type_eq a1 b1) = Some tt). rewrite <- Ht1; auto.
    assert (guard (type_eq a2 b2) = Some tt). rewrite <- Ht; auto.
    rewrite IHa1 with b1; auto.
    rewrite IHa2 with b2; auto.
  }
  Qed.

Lemma check_lam : forall G v t M a, check G (lam v t M) a = Some tt ->
  exists b, a = t ~> b /\ check ((v, t) :: G) M b = Some tt.
Proof.
  intros.
  cbn in H.
  di a.
  ind_rem (guard (type_eq a1 t)) g Hg.
  exists a2. split; auto.
  di a; apply from_guard_type_eq in Hg. rewrite Hg. reflexivity.
  Qed.

Lemma check_app : forall G M1 M2 a, check G (M1 · M2) a = Some tt ->
  exists b, infer G M1 = Some (b ~> a) /\ check G M2 b = Some tt.
Proof.
  intros.
  ind_rem (check G (M1 · M2) a) ch Hch.
  ind_rem (infer G M1) im1 Him1.
  di a1.
  ind_rem (guard (type_eq a1_2 a)) g Hg.
  di a1; apply from_guard_type_eq in Hg. subst.
  exists a1_1. di a0.
  Qed.

Lemma check_to_infer : forall G M a, check G M a = Some tt -> infer G M = Some a.
Proof.
  intros. generalize dependent a. generalize dependent G.
  induction M; intros.
  - cbn in *.
    ind_rem (guard (type_eq a typebool)) t Ht. di a0.
    apply from_guard_type_eq in Ht. subst. auto.
  - cbn in *.
    di (check G M1 typebool).
    ind_rem (check G M2 a) m2 Hm2. di a0.
    apply eq_sym in Hm2.
    apply IHM2 in Hm2 as Hcm2.
    (* apply IHM3 in H. *)
    rewrite Hcm2. cbn. rewrite H. cbn. auto.
  - cbn in *. di (lookup G v).
    ind_rem (guard (type_eq a t)) eqat Heq.
    di a0. apply from_guard_type_eq in Heq. subst. auto.
  - apply check_lam in H; destruct H as [b H]; destruct H as [Ha H].
    cbn.
    apply IHM in H. rewrite H. cbn. rewrite Ha. reflexivity.
  - apply check_app in H; destruct H as [b H]; destruct H as [Hi Hc].
    cbn. rewrite Hi. rewrite Hc. cbn. auto.
  Qed.

Lemma infer_lam : forall G v t M a, infer G (lam v t M) = Some a ->
  exists b, a = t ~> b /\ infer ((v, t) :: G) M = Some b.
Proof.
  intros.
  cbn in H.
  ind_rem (infer ((v, t) :: G) M) im Him.
  inversion H; subst; clear H.
  exists a0; auto.
  Qed.

Lemma infer_app : forall G M1 M2 a, infer G (M1 · M2) = Some a ->
  exists b, infer G M1 = Some (b ~> a) /\ check G M2 b = Some tt.
Proof.
  intros.
  ind_rem (infer G (M1 · M2)) im Him.
  ind_rem (infer G M1) im1 Him1.
  di a1.
  ind_rem (check G M2 a1_1) cm2 Hcm2.
  inversion H. inversion Him. subst. clear H Him.
  destruct a1.
  exists a1_1.
  auto.
  Qed.

Lemma infer_ok : forall G M a, infer G M = Some a -> has_type G M a.
Proof.
  intros. generalize dependent a. generalize dependent G.
  induction M; intros.
  - cbn in H. inversion H. constructor.
  - cbn in H.
    ind_rem (check G M1 typebool) cm1 Hcm1. di a0.
    ind_rem (infer G M2) im2 Him2.
    ind_rem (check G M3 a0) cm3 Hcm3. di a1.
    inversion H. subst. clear H.
    apply eq_sym in Hcm1. apply check_to_infer in Hcm1. apply IHM1 in Hcm1.
    apply eq_sym in Hcm3. apply check_to_infer in Hcm3. apply IHM3 in Hcm3.
    apply eq_sym in Him2. apply IHM2 in Him2.
    constructor; assumption.
  - constructor. cbn in H. auto.
  - apply infer_lam in H as H1; destruct H1 as [ b H1 ];
      destruct H1 as [H0 H1]; rewrite H0 in *; clear H0.
    constructor.
    apply IHM.
    assumption.
  - apply infer_app in H as H1;
      destruct H1 as [b H1]; destruct H1 as [H1 H2].
    apply app_has_type with b.
    + apply IHM1. assumption.
    + apply check_to_infer in H2. apply IHM2. auto.
  Qed.

Definition typecheck (G : ctx) (M : term) : option { A : type | has_type G M A }.
  ind_rem (infer G M) o H.
  - refine (Some (exist _ a _)).
    apply infer_ok. auto.
  - refine None.
Defined.


Lemma exists_aux: forall P: Prop, (exists H: P, let H' := H in True) -> P.
Proof.
  intros.
  destruct H; auto.
Qed.

Ltac gather_current_goal_with_evar := apply exists_aux; eexists; exact I.


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

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

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

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

(** * Floating-point format without underflow *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_rnd.
Require Import Fcore_generic_fmt.
Require Import Fcore_float_prop.
Require Import Fcore_FIX.
Require Import Fcore_rnd_ne.

Section RND_FLX.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable prec : Z.

Class Prec_gt_0 :=
  prec_gt_0 : (0 < prec)%Z.

Context { prec_gt_0_ : Prec_gt_0 }.

(* unbounded floating-point format *)
Definition FLX_format (x : R) :=
  exists f : float beta,
  x = F2R f /\ (Zabs (Fnum f) < Zpower beta prec)%Z.

Definition FLX_exp (e : Z) := (e - prec)%Z.

(** Properties of the FLX format *)

Global Instance FLX_exp_valid : Valid_exp FLX_exp.
Proof.
intros k.
unfold FLX_exp.
generalize prec_gt_0.
repeat split ; intros ; omega.
Qed.

Theorem FIX_format_FLX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FLX_format x ->
  FIX_format beta (e - prec) x.
Proof.
clear prec_gt_0_.
intros x e Hx ((xm, xe), (H1, H2)).
rewrite H1, (F2R_prec_normalize beta xm xe e prec).
now eexists.
exact H2.
now rewrite <- H1.
Qed.

Theorem FLX_format_generic :
  forall x, generic_format beta FLX_exp x -> FLX_format x.
Proof.
intros x H.
rewrite H.
unfold FLX_format.
eexists ; repeat split.
simpl.
apply lt_Z2R.
rewrite Z2R_abs.
rewrite <- scaled_mantissa_generic with (1 := H).
rewrite <- scaled_mantissa_abs.
apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp (Rabs x))).
apply bpow_gt_0.
rewrite scaled_mantissa_mult_bpow.
rewrite Z2R_Zpower, <- bpow_plus.
2: now apply Zlt_le_weak.
unfold canonic_exp, FLX_exp.
ring_simplify (prec + (ln_beta beta (Rabs x) - prec))%Z.
rewrite ln_beta_abs.
destruct (Req_dec x 0) as [Hx|Hx].
rewrite Hx, Rabs_R0.
apply bpow_gt_0.
destruct (ln_beta beta x) as (ex, Ex).
now apply Ex.
Qed.

Theorem generic_format_FLX :
  forall x, FLX_format x -> generic_format beta FLX_exp x.
Proof.
clear prec_gt_0_.
intros x ((mx,ex),(H1,H2)).
simpl in H2.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold canonic_exp, FLX_exp.
rewrite ln_beta_F2R with (1 := Zmx).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply ln_beta_le_Zpower.
Qed.

Theorem FLX_format_satisfies_any :
  satisfies_any FLX_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
intros x.
split.
apply FLX_format_generic.
apply generic_format_FLX.
Qed.

Theorem FLX_format_FIX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FIX_format beta (e - prec) x ->
  FLX_format x.
Proof with auto with typeclass_instances.
intros x e Hx Fx.
apply FLX_format_generic.
apply generic_format_FIX in Fx.
revert Fx.
apply generic_inclusion with (e := e)...
apply Zle_refl.
Qed.

(** unbounded floating-point format with normal mantissas *)
Definition FLXN_format (x : R) :=
  exists f : float beta,
  x = F2R f /\ (x <> R0 ->
  Zpower beta (prec - 1) <= Zabs (Fnum f) < Zpower beta prec)%Z.

Theorem generic_format_FLXN :
  forall x, FLXN_format x -> generic_format beta FLX_exp x.
Proof.
intros x ((xm,ex),(H1,H2)).
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx.
apply generic_format_0.
specialize (H2 Zx).
apply generic_format_FLX.
rewrite H1.
eexists ; repeat split.
apply H2.
Qed.

Theorem FLXN_format_generic :
  forall x, generic_format beta FLX_exp x -> FLXN_format x.
Proof.
intros x Hx.
rewrite Hx.
simpl.
eexists ; split. split.
simpl.
rewrite <- Hx.
intros Zx.
split.
(* *)
apply le_Z2R.
rewrite Z2R_Zpower.
2: now apply Zlt_0_le_0_pred.
rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_le_reg_r with (bpow (canonic_exp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- canonic_exp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold canonic_exp, FLX_exp.
rewrite ln_beta_abs.
ring_simplify (prec - 1 + (ln_beta beta x - prec))%Z.
destruct (ln_beta beta x) as (ex,Ex).
now apply Ex.
(* *)
apply lt_Z2R.
rewrite Z2R_Zpower.
2: now apply Zlt_le_weak.
rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- canonic_exp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold canonic_exp, FLX_exp.
rewrite ln_beta_abs.
ring_simplify (prec + (ln_beta beta x - prec))%Z.
destruct (ln_beta beta x) as (ex,Ex).
now apply Ex.
Qed.

Theorem FLXN_format_satisfies_any :
  satisfies_any FLXN_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
split ; intros H.
now apply FLXN_format_generic.
now apply generic_format_FLXN.
Qed.

(** FLX is a nice format: it has a monotone exponent... *)
Global Instance FLX_exp_monotone : Monotone_exp FLX_exp.
Proof.
intros ex ey Hxy.
now apply Zplus_le_compat_r.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z.

Global Instance exists_NE_FLX : Exists_NE beta FLX_exp.
Proof.
destruct NE_prop as [H|H].
now left.
right.
unfold FLX_exp.
split ; omega.
Qed.

End RND_FLX.


Require Import Coq.Program.Equality.
Require Import FSets.
From SF Require Import Imp.
From SF Require Import Semantics.
From SF Require Import Deadcode.
Import VSdecide.

(** In this chapter: a study of register allocation viewed as
  renaming the variables of an IMP program in a semantic-preserving
  manner.*)

(** * 1. Renaming variables in a program *)

(** Recognition of expressions that are just variables. *)

Definition expr_is_var (a: aexp): option id :=
  match a with AId x => Some x | _ => None end.

Lemma expr_is_var_correct:
  forall a x, expr_is_var a = Some x -> a = AId x.
Proof.
  unfold expr_is_var; intros. destruct a; congruence.
Qed.

Section RENAMING.

Variable f: id -> id.

(** Renaming variables in an expression. *)

Fixpoint rename_aexp (a: aexp) : aexp :=
  match a with
  | ANum n => ANum n
  | AId x => AId (f x)
  | APlus a1 a2 => APlus (rename_aexp a1) (rename_aexp a2)
  | AMinus a1 a2 => AMinus (rename_aexp a1) (rename_aexp a2)
  | AMult a1 a2 => AMult (rename_aexp a1) (rename_aexp a2)
  end.

Fixpoint rename_bexp (b: bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (rename_aexp a1) (rename_aexp a2)
  | BLe a1 a2 => BLe (rename_aexp a1) (rename_aexp a2)
  | BNot b1 => BNot (rename_bexp b1)
  | BAnd b1 b2 => BAnd (rename_bexp b1) (rename_bexp b2)
  end.

(** Transformation of a command:
- renaming the variables
- dead code elimination as in the previous chapter
- coalescing: useless variable-to-variable copies [x ::= y] where
  [f x = f y]are turned into [SKIP].
*)

Fixpoint transf_com (c: com) (L: VS.t): com :=
  match c with
  | SKIP => SKIP
  | x ::= a =>
      if VS.mem x L then
        match expr_is_var a with
        | None => (f x) ::= (rename_aexp a)
        | Some y => if beq_id (f x) (f y) then SKIP else (f x) ::= (rename_aexp a)
        end
      else SKIP
  | (c1; c2) =>
      (transf_com c1 (live c2 L); transf_com c2 L)
  | IFB b THEN c1 ELSE c2 FI =>
      IFB rename_bexp b THEN transf_com c1 L ELSE transf_com c2 L FI
  | WHILE b DO c END =>
      WHILE rename_bexp b DO transf_com c (live (WHILE b DO c END) L) END
  end.

(** * 2. Semantic preservation *)

(** We adapt the notion of agreement between two states over a given
  set of live variables that was introduced in chapter [Deadcode]. *)

Definition agree (L: VS.t) (s1 s2: state) : Prop :=
  forall x, VS.In x L -> s1 x = s2 (f x).

(** Monotonicity property. *)

Lemma agree_mon:
  forall L L' s1 s2,
  agree L' s1 s2 -> VS.Subset L L' -> agree L s1 s2.
Proof.
  unfold VS.Subset, agree; intros. auto.
Qed.

Lemma agree_extensional:
  forall L s1 s2 s3,
  agree L s1 s2 -> (forall x, s2 x = s3 x) -> agree L s1 s3.
Proof.
  unfold agree; intros. transitivity (s2 (f x)); auto.
Qed.

(** Agreement on the free variables of an expression implies that this
    expression and its renaming evaluates identically in both states. *)

Lemma aeval_agree:
  forall L s1 s2, agree L s1 s2 ->
  forall a, VS.Subset (fv_aexp a) L ->
  aeval s1 a = aeval s2 (rename_aexp a).
Proof.
  induction a; simpl; intros.
  auto.
  apply H. generalize H0; fsetdec.
  f_equal. apply IHa1. generalize H0; fsetdec. apply IHa2. generalize H0; fsetdec.
  f_equal. apply IHa1. generalize H0; fsetdec. apply IHa2. generalize H0; fsetdec.
  f_equal. apply IHa1. generalize H0; fsetdec. apply IHa2. generalize H0; fsetdec.
Qed.

Lemma beval_agree:
  forall L s1 s2, agree L s1 s2 ->
  forall b, VS.Subset (fv_bexp b) L ->
  beval s1 b = beval s2 (rename_bexp b).
Proof.
  induction b; simpl; intros.
  auto.
  auto.
  repeat rewrite (aeval_agree L s1 s2); auto; generalize H0; fsetdec.
  repeat rewrite (aeval_agree L s1 s2); auto; generalize H0; fsetdec.
  f_equal; auto.
  f_equal. apply IHb1. generalize H0; fsetdec. apply IHb2. generalize H0; fsetdec.
Qed.

(** Agreement is preserved by unilateral assignment to a dead variable. *)

Lemma agree_update_dead:
  forall s1 s2 L x v,
  agree L s1 s2 -> ~VS.In x L ->
  agree L (update s1 x v) s2.
Proof.
  intros; red; intros. unfold update. remember (beq_id x x0). destruct b.
  assert (x = x0). apply beq_id_eq. auto. subst x0. contradiction.
  apply H; auto.
Qed.

(** Agreement is preserved by simultaneous assignment to a live variable
   [x] and its renaming [f x], provided none of the other live variables
   [z] is renamed to [f x] (non-interference property). *)

Lemma agree_update_live:
  forall s1 s2 L x v,
  agree (VS.remove x L) s1 s2 ->
  (forall z, VS.In z L -> z <> x -> f z <> f x) ->
  agree L (update s1 x v) (update s2 (f x) v).
Proof.
  intros; red; intros. unfold update. remember (beq_id x x0). destruct b.
(* Case x = x0 *)
  assert (x = x0). apply beq_id_eq. auto. subst x0.
  rewrite <- beq_id_refl. auto.
(* Case x <> x0 *)
  assert (x <> x0). apply beq_id_false_not_eq; auto.
  assert (f x0 <> f x). apply H0; auto.
  rewrite not_eq_beq_id_false.
  apply H. apply VS.remove_2; auto.
  auto.
Qed.

(** A special case of [agree_update_live] where the value being assigned
  is not arbitrary, but is the value of another variable [y].
  In this case, we can relax the non-interference hypothesis
  (Chaitin's observation). *)

Lemma agree_update_move:
  forall s1 s2 L x y,
  agree (VS.union (VS.remove x L) (VS.singleton y)) s1 s2 ->
  (forall z, VS.In z L -> z <> x -> z <> y -> f z <> f x) ->
  agree L (update s1 x (s1 y)) (update s2 (f x) (s2 (f y))).
Proof.
  intros; red; intros. unfold update. remember (beq_id x x0). destruct b.
(* Case x = x0 *)
  assert (x = x0). apply beq_id_eq. auto. subst x0.
  rewrite <- beq_id_refl. apply H. fsetdec.
(* Case x <> x0 *)
  assert (x <> x0). apply beq_id_false_not_eq; auto.
  remember (beq_id x0 y). destruct b.
(*  SCase x0 = y *)
    assert (x0 = y). apply beq_id_eq. auto. subst x0.
    transitivity (s2 (f y)).
    apply H. fsetdec.
    destruct (beq_id (f x) (f y)); auto.
(*  SCase x0 <> y *)
    assert (x0 <> y). apply beq_id_false_not_eq; auto.
    assert (f x0 <> f x). apply H0; auto.
    rewrite not_eq_beq_id_false.
    apply H. apply VS.union_2. apply VS.remove_2; auto.
    auto.
Qed.

(** A special case of [agree_update_move] where [f x = f y].
  In this case, the assignment in the transformed program
  can be optimized away. *)

Lemma agree_update_coalesced_move:
  forall s1 s2 L x y,
  agree (VS.union (VS.remove x L) (VS.singleton y)) s1 s2 ->
  (forall z, VS.In z L -> z <> x -> z <> y -> f z <> f x) ->
  f x = f y ->
  agree L (update s1 x (s1 y)) s2.
Proof.
  intros. apply agree_extensional with (update s2 (f x) (s2 (f y))).
  apply agree_update_move; auto.
  intros. rewrite H1. unfold update. remember (beq_id (f y) x0). destruct b.
  assert (f y = x0). apply beq_id_eq; auto.
  congruence.
  auto.
Qed.

(** Gathering together the various non-interference conditions above,
  we obtain the following correctness criterion for a candidate
  renaming [f].  Note that this is a boolean-valued function, not
  a predicate; therefore, it can be used as a validator for
  a renaming computed by an untrusted heuristic. *)

Fixpoint correct_allocation (c: com) (L: VS.t) : bool :=
  match c with
  | SKIP =>
      true
  | x ::= a =>
      if VS.mem x L then
        match expr_is_var a with
        | Some y =>
            VS.for_all (fun z => beq_id z x || beq_id z y || negb (beq_id (f z) (f x))) L
        | None =>
            VS.for_all (fun z => beq_id z x || negb (beq_id (f z) (f x))) L
        end
      else true
  | (c1; c2) =>
      correct_allocation c1 (live c2 L) && correct_allocation c2 L
  | IFB b THEN c1 ELSE c2 FI =>
      correct_allocation c1 L && correct_allocation c2 L
  | WHILE b DO c END =>
      correct_allocation c (live (WHILE b DO c END) L)
  end.

Remark correct_allocation_assign_1:
  forall x y L,
  VS.for_all (fun z => beq_id z x || beq_id z y || negb (beq_id (f z) (f x))) L = true ->
  forall z, VS.In z L -> z <> x -> z <> y -> f z <> f x.
Proof.
  intros.
  set (g := fun z => beq_id z x || beq_id z y || negb (beq_id (f z) (f x))) in *.
  assert (VS.For_all (fun x => g x = true) L).
    apply VS.for_all_2.
    red; intros. congruence.
    auto.
  red in H3. generalize (H3 z H0). unfold g.
  rewrite not_eq_beq_id_false; auto.
  rewrite not_eq_beq_id_false; auto.
  simpl. remember (beq_id (f z) (f x)). destruct b; simpl; intros.
  congruence.
  apply beq_id_false_not_eq; auto.
Qed.

Remark correct_allocation_assign_2:
  forall x L,
  VS.for_all (fun z => beq_id z x || negb (beq_id (f z) (f x))) L = true ->
  forall z, VS.In z L -> z <> x -> f z <> f x.
Proof.
  intros.
  set (g := fun z => beq_id z x || negb (beq_id (f z) (f x))) in *.
  assert (VS.For_all (fun x => g x = true) L).
    apply VS.for_all_2.
    red; intros. congruence.
    auto.
  red in H2. generalize (H2 z H0). unfold g.
  rewrite not_eq_beq_id_false; auto.
  simpl. remember (beq_id (f z) (f x)). destruct b; simpl; intros.
  congruence.
  apply beq_id_false_not_eq; auto.
Qed.

(** The proof of semantic preservation is a straightforward adaptation
  of the proof for dead code elimination.  There are more cases to
  be considered in the assignment case [x ::= a], corresponding
  to variable-to-variable moves [x ::= y], either coalesced or not. *)

Theorem transf_correct_terminating:
  forall st c st', c / st ==> st' ->
  forall L st1,
  agree (live c L) st st1 ->
  correct_allocation c L = true ->
  exists st1', transf_com c L / st1 ==> st1' /\ agree L st' st1'.
Proof.
  induction 1; intros L st1 AG CORR; simpl; simpl in CORR.

(*Case skip *)
  exists st1; split. constructor. auto.

(* := *)
  rename l into x. simpl in AG. remember (VS.mem x L) as is_live. destruct is_live.
(* SSCase x is live after *)
    assert (aeval st1 (rename_aexp a1) = n).
      rewrite <- H. symmetry. eapply aeval_agree. eauto. fsetdec.
    remember (expr_is_var a1) as is_var. destruct is_var as [y | ].
    (*  SSCasemove x := y *)
      assert (a1 = AId y). apply expr_is_var_correct; auto. subst a1. simpl in *.
      remember (beq_id (f x) (f y)) as coalesced.  destruct coalesced.
      (*  SSCase coalesced move *)
        assert (f x = f y). apply beq_id_eq; auto.
        exists st1; split.
        apply E_Skip.
        rewrite <- H. apply agree_update_coalesced_move; auto.
        apply correct_allocation_assign_1; auto.
      (*  SSCase preserved move *)
        exists (update st1 (f x) n); split.
        apply E_Ass. simpl. auto.
        rewrite <- H at 1. rewrite <- H0.
        apply agree_update_move; auto.
        apply correct_allocation_assign_1; auto.
    (*  SSCase not a move *)
      exists (update st1 (f x) n); split.
      apply E_Ass. auto.
      apply agree_update_live.
      eapply agree_mon; eauto. fsetdec.
      apply correct_allocation_assign_2; auto.
  (*  SCase x is dead after *)
    exists st1; split.
    apply E_Skip.
    apply agree_update_dead. auto.
    red; intros. assert (VS.mem x L = true). apply VS.mem_1; auto. congruence.

(*  Case seq *)
  simpl in AG. destruct (andb_true _ _ CORR).
  destruct (IHceval1 _ _ AG H1) as [st1' [E1 A1]].
  destruct (IHceval2 _ _ A1 H2) as [st2' [E2 A2]].
  exists st2'; split.
  apply E_Seq with st1'; auto.
  auto.

(*  Case if true *)
  simpl in AG. destruct (andb_true _ _ CORR).
  assert (beval st1 (rename_bexp b1) = true).
    rewrite <- H. symmetry. eapply beval_agree; eauto. fsetdec.
  destruct (IHceval L st1) as [st1' [E A]].
    eapply agree_mon; eauto. fsetdec.
    auto.
  exists st1'; split.
  apply E_IfTrue; auto.
  auto.

(*  Case if false *)
  simpl in AG. destruct (andb_true _ _ CORR).
  assert (beval st1 (rename_bexp b1) = false).
    rewrite <- H. symmetry. eapply beval_agree; eauto. fsetdec.
  destruct (IHceval L st1) as [st1' [E A]].
    eapply agree_mon; eauto. fsetdec.
    auto.
  exists st1'; split.
  apply E_IfFalse; auto.
  auto.

(*  Case while end *)
  destruct (live_while_charact b1 c1 L) as [P [Q R]].
  assert (beval st1 (rename_bexp b1) = false).
    rewrite <- H. symmetry. eapply beval_agree; eauto.
  exists st1; split.
  apply E_WhileEnd. auto.
  eapply agree_mon; eauto.

(*  Case while loop *)
  destruct (live_while_charact b1 c1 L) as [P [Q R]].
  assert (beval st1 (rename_bexp b1) = true).
    rewrite <- H. symmetry. eapply beval_agree; eauto.
  destruct (IHceval1 (live (CWhile b1 c1) L) st1) as [st2 [E1 A1]].
    eapply agree_mon; eauto.
    auto.
  destruct (IHceval2 L st2) as [st3 [E2 A2]].
    auto. auto.
  exists st3; split.
  apply E_WhileLoop with st2; auto.
  auto.
Qed.

Theorem transf_correct_diverging:
  forall st c L st1,
  c / st ==> ∞  ->
  agree (live c L) st st1 ->
  correct_allocation c L = true ->
  transf_com c L / st1 ==> ∞.
Proof.
  cofix COINDHYP; intros until st1; intros DIV AG CORR; inv DIV.

(*  Case seq left *)
  simpl in *. destruct (andb_prop _ _ CORR).
  apply Einf_Seq_1. apply COINDHYP with st. auto. auto. auto.

(*  Case seq right *)
  simpl in *. destruct (andb_prop _ _ CORR).
  destruct (transf_correct_terminating _ _ _ H _ _ AG H1) as [st1' [E A]].
  apply Einf_Seq_2 with st1'. auto. apply COINDHYP with st2; auto.

(*  Case if true *)
  simpl in *. destruct (andb_prop _ _ CORR).
  assert (beval st1 (rename_bexp b) = true).
    rewrite <- H. symmetry. eapply beval_agree; eauto. fsetdec.
  apply Einf_IfTrue. auto.
  apply COINDHYP with st. auto. eapply agree_mon; eauto. fsetdec. auto.

(*  Case if false *)
  simpl in *. destruct (andb_prop _ _ CORR).
  assert (beval st1 (rename_bexp b) = false).
    rewrite <- H. symmetry. eapply beval_agree; eauto. fsetdec.
  apply Einf_IfFalse. auto.
  apply COINDHYP with st. auto. eapply agree_mon; eauto. fsetdec. auto.

(*  Case while body *)
  destruct (live_while_charact b c1 L) as [P [Q R]].
  assert (beval st1 (rename_bexp b) = true).
    rewrite <- H. symmetry. eapply beval_agree; eauto.
  apply Einf_WhileBody. auto.
  apply COINDHYP with st. auto. eapply agree_mon; eauto. auto.

(* while loop *)
  destruct (live_while_charact b c1 L) as [P [Q R]].
  assert (beval st1 (rename_bexp b) = true).
    rewrite <- H. symmetry. eapply beval_agree; eauto.
  destruct (transf_correct_terminating _ _ _ H0 (live (CWhile b c1) L) st1) as [st2 [E1 A1]].
    eapply agree_mon; eauto. auto.
  apply Einf_WhileLoop with st2. auto. apply E1.
  apply (COINDHYP st' (WHILE b DO c1 END) L st2). auto. auto. auto.
Qed.

End RENAMING.

(** * 3. Examples *)

(** If we give it the identity renaming, our code transformation
  behaves exactly like dead code elimination. *)

Definition trivial_alloc := fun (x: id) => x.

Eval vm_compute in (correct_allocation trivial_alloc prog (VS.singleton vr)).
Eval vm_compute in (transf_com trivial_alloc prog (VS.singleton vr)).

(** Result is:
<<
   r := a;                 ===>   r := a;
   q := 0;                        skip;
   while b <= r do                while b <= r do
     r := r - b;                    r := r - b;
     q := q + 1;                    skip;
   done                           done
>>
*)

(** Here is another allocation that collapses variables [r] and [a].*)

Definition my_alloc := fun (x: id) => if beq_id x vr then va else x.

Eval vm_compute in (correct_allocation my_alloc prog (VS.singleton vr)).
Eval vm_compute in (transf_com my_alloc prog (VS.singleton vr)).

(** Here is the result.  Note the removal of [r := a].
<<
   r := a;                 ===>   skip;
   q := 0;                        skip;
   while b <= r do                while b <= a do
     r := r - b;                    a := a - b;
     q := q + 1;                    skip;
   done                           done
>>
*)

(** Finally, if we try to collapse variable [r] and [b], the validation
  function [correct_allocation] rejects the allocation. *)

Definition wrong_alloc := fun (x: id) => if beq_id x vr then vb else x.

Eval vm_compute in (correct_allocation wrong_alloc prog (VS.singleton vr)).

(** * 4. Putting it all together *)

(** We assume given a register allocation heuristic that computes a candidate
  allocation. *)

Parameter regalloc_heuristic: com -> VS.t -> (id -> id).

(** Typically, this heuristic will be written in Caml and linked with
  the Caml code extracted from the present Coq development. *)

(** We then define the register allocation pass.  [prog] is the program to be
  transformed and [obs] is the set of variables we want to observe at the
  end of its execution.  This compilation pass can fail at compile-time,
  in which case it returns [None]. *)

Definition regalloc (prog: com) (obs: VS.t) : option com :=
  let f := regalloc_heuristic prog obs in
  if correct_allocation f prog obs
  then Some(transf_com f prog obs)
  else None.


Require Import VST.progs.conclib.
Require Import VST.progs.ghost.
Require Import RelationClasses.

Section Maps.

Context {A B : Type} {A_eq : EqDec A}.

Implicit Types (k : A) (v : B) (m : A -> option B).

Definition map_upd m k v k' := if eq_dec k' k then Some v else m k'.

Lemma map_upd_triv : forall m k v, m k = Some v -> map_upd m k v = m.
Proof.
  intros; extensionality; unfold map_upd.
  if_tac; subst; auto.
Qed.

Fixpoint map_upd_list m l :=
  match l with
  | [] => m
  | (k, v) :: rest => map_upd_list (map_upd m k v) rest
  end.

Definition map_add m1 m2 k := match m1 k with Some v' => Some v' | None => m2 k end.

Definition empty_map k : option B := None.

Definition singleton k v k1 := if eq_dec k1 k then Some v else None.

Definition map_incl m1 m2 := forall k v, m1 k = Some v -> m2 k = Some v.

Global Instance map_incl_refl : Reflexive map_incl.
Proof.
  repeat intro; auto.
Qed.

Global Instance map_incl_antisym : Antisymmetric _ _ map_incl.
Proof.
  intros x y Hx Hy a.
  specialize (Hx a); specialize (Hy a).
  destruct (x a); [erewrite Hx; eauto|].
  destruct (y a); auto.
Qed.

Global Instance map_incl_trans : Transitive map_incl.
Proof.
  repeat intro; auto.
Qed.

Lemma map_add_incl_compat : forall m1 m2 m3, map_incl m1 m2 -> map_incl (map_add m3 m1) (map_add m3 m2).
Proof.
  unfold map_add; repeat intro.
  destruct (m3 k); auto.
Qed.

Definition compatible m1 m2 := forall k v1 v2, m1 k = Some v1 -> m2 k = Some v2 -> v1 = v2.

Global Instance compatible_comm : Symmetric compatible.
Proof.
  repeat intro.
  symmetry; eauto.
Qed.

Lemma map_add_comm : forall m1 m2, compatible m1 m2 -> map_add m1 m2 = map_add m2 m1.
Proof.
  intros; extensionality x; unfold map_add.
  destruct (m1 x) eqn: Hm1, (m2 x) eqn: Hm2; eauto.
Qed.

Instance fmap_PCM : PCM (A -> option B) :=
  { join a b c := forall k v, c k = Some v <-> a k = Some v \/ b k = Some v }.
Proof.
  - intros.
    rewrite Hjoin; tauto.
  - intros.
    exists (fun k => match b k with Some v' => Some v' | None => d k end).
    assert (forall k v1 v2, b k = Some v1 -> d k = Some v2 -> v1 = v2) as Hbd.
    { intros ??? Hb Hd.
      specialize (Hjoin1 k v1).
      destruct Hjoin1 as (_ & Hc); lapply Hc; auto; intro Hc'.
      generalize (Hjoin2 k v1); intros (_ & He); lapply He; auto; intro He1.
      specialize (Hjoin2 k v2); destruct Hjoin2 as (_ & Hjoin2); lapply Hjoin2; auto; intro He2.
      rewrite He1 in He2; inv He2; auto. }
    split; intros; specialize (Hjoin1 k v); specialize (Hjoin2 k v).
    + destruct (b k) eqn: Hb; split; auto; intros [|]; auto; try discriminate.
      exploit Hbd; eauto.
    + rewrite Hjoin2, Hjoin1.
      destruct (b k) eqn: Hb; split; auto; intros [|]; auto.
      * specialize (Hbd _ _ _ Hb H); subst; auto.
      * destruct H; auto; discriminate.
Defined.

Lemma map_join_spec : forall m1 m2 m3, join m1 m2 m3 <-> compatible m1 m2 /\ m3 = map_add m1 m2.
Proof.
  simpl; split; intros.
  - split.
    + repeat intro.
      assert (m3 k = Some v1) as Hk by (rewrite H; auto).
      replace (m3 k) with (Some v2) in Hk by (symmetry; rewrite H; auto).
      inv Hk; auto.
    + extensionality x; unfold map_add.
      destruct (m1 x) eqn: Hm1; [rewrite H; auto|].
      destruct (m2 x) eqn: Hm2; [rewrite H; auto|].
      destruct (m3 x) eqn: Hm3; auto.
      rewrite H in Hm3; destruct Hm3 as [Hm3 | Hm3]; rewrite Hm3 in *; discriminate.
  - destruct H as [Hcompat]; subst; unfold map_add.
    destruct (m1 k) eqn: Hm1; split; auto; intros [?|?]; eauto; discriminate.
Qed.

Instance fmap_order : PCM_order map_incl.
Proof.
  constructor.
  - apply map_incl_refl.
  - apply map_incl_trans.
  - intros ??? Ha Hb; exists (map_add a b); split; simpl.
    + intros; unfold map_add; destruct (a k) eqn: Hk; split; auto; intros [|]; auto; try discriminate.
      specialize (Ha _ _ Hk); specialize (Hb _ _ H); rewrite Ha in Hb; auto.
    + unfold map_add; intros ???.
      destruct (a k) eqn: Hk; auto.
      inv H; auto.
  - split; repeat intro; specialize (H k v); rewrite H; auto.
  - split; auto; intros [|]; auto.
Defined.

Lemma map_snap_join : forall m1 m2 p,
  ghost_snap m1 p * ghost_snap m2 p = !!(compatible m1 m2) && ghost_snap (map_add m1 m2) p.
Proof.
  intros; rewrite ghost_snap_join'.
  apply mpred_ext.
  - Intros m.
    rewrite map_join_spec in H; destruct H; subst; entailer!.
  - Intros; Exists (map_add m1 m2).
    rewrite map_join_spec; entailer!.
Qed.

Lemma map_upd_list_app : forall l1 l2 m, map_upd_list m (l1 ++ l2) = map_upd_list (map_upd_list m l1) l2.
Proof.
  induction l1; auto; simpl; intros.
  destruct a; auto.
Qed.

Lemma map_upd_list_out : forall l m k, m k = None -> ~In k (map fst l) -> map_upd_list m l k = None.
Proof.
  induction l; auto; simpl; intros.
  destruct a; apply IHl.
  - unfold map_upd; if_tac; auto.
    subst; simpl in *; tauto.
  - tauto.
Qed.

Lemma compatible_incl : forall m1 m2 m (Hcompat : compatible m2 m) (Hincl : map_incl m1 m2), compatible m1 m.
Proof.
  repeat intro; eauto.
Qed.

Lemma compatible_k : forall m1 m2 (Hcompat : compatible m1 m2) k v, m2 k = Some v -> map_add m1 m2 k = Some v.
Proof.
  unfold compatible; intros.
  unfold map_add.
  destruct (m1 k) eqn: Hk; eauto.
Qed.

Lemma map_join_incl_compat : forall m1 m2 m' m'' (Hincl : map_incl m1 m2) (Hjoin : join m2 m' m''),
  exists m, join m1 m' m /\ map_incl m m''.
Proof.
  intros; apply join_comm in Hjoin.
  rewrite map_join_spec in Hjoin; destruct Hjoin as [Hjoin]; subst.
  do 2 eexists; [|apply map_add_incl_compat; eauto].
  symmetry in Hjoin; eapply compatible_incl in Hjoin; eauto.
  rewrite map_join_spec; split; auto.
  rewrite <- map_add_comm; auto.
Qed.

Lemma map_add_empty : forall m, map_add m empty_map = m.
Proof.
  intros; extensionality; unfold map_add, empty_map.
  destruct (m x); auto.
Qed.

Lemma map_add_assoc : forall m1 m2 m3, map_add (map_add m1 m2) m3 = map_add m1 (map_add m2 m3).
Proof.
  intros; extensionality; unfold map_add.
  destruct (m1 x); auto.
Qed.

Lemma map_incl_add : forall m1 m2, map_incl m1 (map_add m1 m2).
Proof.
  repeat intro; unfold map_add.
  rewrite H; auto.
Qed.

Lemma map_upd_incl : forall m1 m2 k v, map_incl m1 m2 ->
  m2 k = Some v -> map_incl (map_upd m1 k v) m2.
Proof.
  unfold map_upd; repeat intro.
  destruct (eq_dec k0 k); [congruence | auto].
Qed.

Lemma map_add_single : forall m k v, map_add (singleton k v) m = map_upd m k v.
Proof.
  intros; extensionality; unfold map_add, singleton, map_upd; if_tac; auto.
Qed.

Lemma compatible_add_assoc : forall m1 m2 m3, compatible m1 m2 ->
  compatible (map_add m1 m2) m3 -> compatible m1 (map_add m2 m3).
Proof.
  unfold compatible, map_add; intros.
  repeat match goal with H : forall _, _ |- _ => specialize (H k) end.
  replace (m1 k) with (Some v1) in *.
  destruct (m2 k); auto.
Qed.

Lemma map_incl_compatible : forall m1 m2 m3 (Hincl1 : map_incl m1 m3) (Hincl2 : map_incl m2 m3), compatible m1 m2.
Proof.
  intros; intros ??? Hk1 Hk2.
  apply Hincl1 in Hk1; apply Hincl2 in Hk2.
  rewrite Hk1 in Hk2; inv Hk2; auto.
Qed.

Lemma map_add_incl : forall m1 m2 m3, map_incl m1 m3 -> map_incl m2 m3 -> map_incl (map_add m1 m2) m3.
Proof.
  unfold map_add; intros.
  intros ?? Hk.
  destruct (m1 k) eqn: Hk1; auto.
  inv Hk; auto.
Qed.

Lemma incl_compatible : forall m1 m2, map_incl m1 m2 -> compatible m1 m2.
Proof.
  intros; intros ??? Hk1 Hk2.
  specialize (H _ _ Hk1); rewrite H in Hk2; inv Hk2; auto.
Qed.

Lemma map_add_redundant : forall m1 m2, map_incl m1 m2 -> map_add m1 m2 = m2.
Proof.
  intros; unfold map_add; extensionality k.
  destruct (m1 k) eqn: Hk; auto; symmetry; auto.
Qed.

Lemma empty_map_incl : forall m, map_incl empty_map m.
Proof.
  repeat intro; discriminate.
Qed.

End Maps.

Hint Resolve empty_map_incl.

Section ListMaps.

Context {A B : Type} {A_eq : EqDec A}.

Definition map_Znth i (L : A -> option (list B)) d k := option_map (fun v => Znth i v d) (L k).

Lemma map_Znth_single : forall i (k : A) (v : list B) d,
  map_Znth i (singleton k v) d = singleton k (Znth i v d).
Proof.
  intros; unfold map_Znth, singleton; extensionality.
  if_tac; auto.
Qed.

Lemma map_Znth_add : forall (m1 m2 : A -> option (list B)) i d,
  map_Znth i (map_add m1 m2) d = map_add (map_Znth i m1 d) (map_Znth i m2 d).
Proof.
  intros; unfold map_add, map_Znth; extensionality.
  destruct (m1 x); auto.
Qed.

Lemma map_Znth_eq : forall (L : A -> option (list B)) k vs d (Hlength : forall vs', L k = Some vs' -> Zlength vs' = Zlength vs)
  (Hnz : vs <> []) (Hall : forall i, 0 <= i < Zlength vs -> map_Znth i L d k = Some (Znth i vs d)),
  L k = Some vs.
Proof.
  intros.
  destruct (L k) eqn: Hk.
  specialize (Hlength _ eq_refl).
  apply f_equal, list_Znth_eq' with (d0 := d); auto.
  rewrite Hlength; intros j Hj; specialize (Hall _ Hj).
  unfold map_Znth in Hall; rewrite Hk in Hall; inv Hall; auto.
  { lapply (Hall 0).
    unfold map_Znth; rewrite Hk; discriminate.
    { pose proof (Zlength_nonneg vs).
      destruct (eq_dec (Zlength vs) 0); [|omega].
      apply Zlength_nil_inv in e; subst; contradiction. } }
Qed.

Lemma map_Znth_upd : forall (m : A -> option (list B)) k v i d,
  map_Znth i (map_upd m k v) d = map_upd (map_Znth i m d) k (Znth i v d).
Proof.
  intros; unfold map_Znth, map_upd; extensionality.
  if_tac; auto.
Qed.

Lemma map_incl_Znth : forall (m1 m2 : A -> option (list B)) i d, map_incl m1 m2 ->
  map_incl (map_Znth i m1 d) (map_Znth i m2 d).
Proof.
  unfold map_Znth; repeat intro.
  destruct (m1 k) eqn: Hm1; [|discriminate].
  rewrite (H _ _ Hm1); auto.
Qed.

End ListMaps.

Section Logs.
(* A log is a map from Z, and a finite log has a latest element. *)

Context {B : Type}.

Definition log_latest s (v1 : Z) (v2 : B) := s v1 = Some v2 /\ forall v', v1 < v' -> s v' = None.

Lemma log_latest_singleton : forall v1 v2, log_latest (singleton v1 v2) v1 v2.
Proof.
  unfold singleton; split.
  - rewrite eq_dec_refl; auto.
  - intros; if_tac; auto; omega.
Qed.

Lemma log_incl_latest : forall k1 k2 v1 v2 log1 log2 (Hincl : map_incl log1 log2)
  (Hv1 : log1 k1 = Some v1) (Hlatest : log_latest log2 k2 v2), k1 <= k2.
Proof.
  intros.
  destruct (zlt k2 k1); [|omega].
  destruct Hlatest as (? & Hlatest).
  specialize (Hlatest _ l).
  specialize (Hincl _ _ Hv1); rewrite Hincl in Hlatest; discriminate.
Qed.

Lemma log_latest_upd : forall log v1 v2 v1' v2', log_latest log v1 v2 -> v1 < v1' ->
  map_incl log (map_upd log v1' v2') /\ log_latest (map_upd log v1' v2') v1' v2'.
Proof.
  intros; destruct H as (? & Hlast); unfold map_upd; split.
  - repeat intro; if_tac; auto.
    subst; rewrite (Hlast v1') in *; auto; discriminate.
  - split; [rewrite eq_dec_refl; auto|].
    intros v' ?; lapply (Hlast v'); [|omega].
    intro; if_tac; auto; omega.
Qed.

Lemma log_latest_inj : forall log v1 v2 v1' v2' (H1 : log_latest log v1 v2) (H1' : log_latest log v1' v2'),
  v1 = v1' /\ v2 = v2'.
Proof.
  intros.
  assert (log v1 = Some v2) as Hv1 by (apply H1).
  assert (log v1' = Some v2') as Hv1' by (apply H1').
  pose proof (log_incl_latest _ _ _ _ _ _ (map_incl_refl log) Hv1 H1').
  pose proof (log_incl_latest _ _ _ _ _ _ (map_incl_refl log) Hv1' H1).
  assert (v1 = v1') by omega; subst.
  destruct H1 as [H1 _], H1' as [H1' _].
  rewrite H1 in H1'; inv H1'; auto.
Qed.

Lemma log_latest_add : forall m1 m2 k1 k2 (v1 v2 : B)
  (Hlatest1 : log_latest m1 k1 v1) (Hlatest2 : log_latest m2 k2 v2),
  log_latest (map_add m1 m2) (Z.max k1 k2) (if zlt k1 k2 then v2 else v1).
Proof.
  unfold log_latest, map_add; intros.
  destruct Hlatest1 as (Hv1 & Hk1), Hlatest2 as (Hv2 & Hk2).
  destruct (zlt k1 k2).
  - rewrite Z.max_r by omega.
    rewrite Hk1 by auto; split; auto.
    intros; rewrite Hk1, Hk2; auto; omega.
  - rewrite Z.max_l, Hv1 by omega; split; auto.
    intros; rewrite Hk1, Hk2; auto; omega.
Qed.

Lemma log_latest_upd_list : forall l (m : Z -> option B) k v k' v' (Hm : log_latest m k v)
  (Hlast : last l (k, v) = (k', v')) (Hlt : k <= k') (Hordered : Forall (fun '(k, v) => k <= k') l),
  log_latest (map_upd_list m l) k' v'.
Proof.
  intros.
  destruct (nil_dec l).
  { subst; inv Hlast; auto. }
  rewrite (app_removelast_last (k, v) n).
  rewrite map_upd_list_app; simpl.
  rewrite Hlast; split.
  - unfold map_upd; rewrite eq_dec_refl; auto.
  - intros; unfold map_upd.
    if_tac; [omega|].
    apply map_upd_list_out.
    + eapply Hm; omega.
    + rewrite in_map_iff; intros ((?, ?) & ? & ?); simpl in *; subst.
      rewrite Forall_forall in Hordered; exploit Hordered; [apply In_removelast; eauto|].
      simpl; omega.
Qed.

End Logs.

Lemma map_Znth_log_latest : forall {B} m k (v : list B) i d, log_latest m k v ->
  log_latest (map_Znth i m d) k (Znth i v d).
Proof.
  unfold log_latest, map_Znth; intros.
  destruct H as [-> H]; split; auto.
  intros; rewrite H; auto.
Qed.


(** * Combi.Basic.ordtype : Ordered Types *)
(******************************************************************************)
(*      Copyright (C) 2014-2021 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * Ordered type

Inhabited Types:

- [inhType] == interface for inhabited types
- [inhPordType] == interface for partially ordered inhabited types
- [inhOrdType] == interface for totally ordered inhabited types
- [inhOrdFinType] == interface for totally ordered finite types

Sequence on a totally ordered type:

- [maxL a L] == the maximum of [a] and the element of the sequence [L]
- [allLeq v a] == a is smaller or equal than all the element of [v]
- [allLnt v a] == a is strictly smaller than all the element of [v]

- [rembig w] == [w] minus last occurence of its largest letter
- [posbig w] == the position of the last occurence of the largest letter of [w]

- [shift_pos pos i] == if [i < pos] then [i] else [i.+1]
- [shiftinv_pos pos i] == if [i < pos] then [i] else [i.-1]

Cover relation:

- [covers x y] == [y] covers [x] where [x] and [y] belongs to a common
                  [finPOrderType].
 ********)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrfun ssrnat eqtype choice fintype seq.
From mathcomp Require Import finset order path fingraph.
Require Import tools.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope order_scope.
Import Order.TTheory.

(******************************************************************************)
(** * Induction on partially ordered types                                    *)
(******************************************************************************)

Lemma finord_wf (disp : unit) (T : finPOrderType disp) (P : T -> Type) :
  (forall x, (forall y, y < x -> P y) -> P x) -> forall x, P x.
Proof.
move=> IH x.
have [n] := ubnP #|[set y : T | y < x]|; elim: n => // n IHn in x *.
rewrite ltnS leq_eqVlt; case: eqP => [eqcn _ | _ ]; last exact: IHn.
apply: IH => y ltxy; apply: IHn.
rewrite -{}eqcn; apply proper_card; apply/andP; split; apply/subsetP.
- by move=> z; rewrite !inE => /lt_trans; apply.
- by move/(_ y); rewrite !inE => /(_ ltxy); rewrite ltxx.
Qed.

Lemma finord_wf_down (disp : unit) (T : finPOrderType disp) (P : T -> Type) :
  (forall x, (forall y, y > x -> P y) -> P x) -> forall x, P x.
Proof. exact: (@finord_wf _ [finPOrderType of T^d]). Qed.

(******************************************************************************)
(** * Covering relation                                                       *)
(******************************************************************************)

(** We only define covering relation for finite type, since it cannot be      *)
(** decided and it is not very useful for infinite orders.                    *)
Definition covers {disp : unit} {T : finPOrderType disp} :=
  [rel x y : T | (x < y) && [forall z, ~~(x < z < y)]].

Section CoversFinPOrder.

Variable (disp : unit) (T : finPOrderType disp).
Implicit Type (x y : T).

Lemma coversP x y : reflect (x < y /\ (forall z, ~(x < z < y))) (covers x y).
Proof.
apply (iffP andP) => /= [[ltxy /forallP Hcovers] | [ltxy Hcovers]].
- by split => // z; apply/negP.
- by split => //; apply/forallP => z; apply/negP.
Qed.

Lemma ltcovers x y : covers x y -> x < y.
Proof. by move/coversP => []. Qed.

Lemma coversEV x y : covers x y -> forall z, x <= z <= y -> z = x \/ z = y.
Proof.
move=> /coversP[ltxy Hcovers] z /andP [].
rewrite le_eqVlt => /orP[/eqP -> | ltxz]; first by left.
rewrite le_eqVlt => /orP[/eqP -> | ltzy]; first by right.
by exfalso; apply: (Hcovers z); rewrite ltxz ltzy.
Qed.

Lemma covers_dual x y :
  covers (T := [finPOrderType of T^d]) y x = covers x y.
Proof.
rewrite /= ltEdual; congr (_ && _); apply: eq_forallb => z.
by rewrite !ltEdual andbC.
Qed.

Lemma covers_ind (P : T -> Type) :
  (forall x y, covers x y -> P x -> P y) ->
  forall x, P x -> forall y, x <= y -> P y.
Proof.
move=> IH x Px; elim/finord_wf => y IHy.
rewrite le_eqVlt; case: eqP => [<-|] //= _ ltxy.
case: (boolP (covers x y)) => [/IH|]; first exact.
rewrite /covers /= ltxy /= -negb_exists negbK => /existsP/sigW [z0].
move/(arg_minP (P := [pred z | x < z < y]) (fun z => #|[pred t | z < t < y]|))
    => {z0} [zmin /andP[ltxz ltzy] Hzmin].
suff /IH : covers zmin y by apply; apply: (IHy _ ltzy (ltW ltxz)).
rewrite /= ltzy /=; apply/forallP => u; apply/negP => /andP [ltzu ltuy].
have /Hzmin : x < u < y by rewrite ltuy (lt_trans ltxz ltzu).
rewrite leNgt => /negP; apply.
apply proper_card; rewrite /= properE; apply/andP; split.
  by apply/subsetP => v; rewrite !unfold_in => /andP[/(lt_trans ltzu)->->].
apply/negP => /subsetP/(_ u); rewrite !unfold_in ltxx /= => Habs.
by have /Habs : zmin < u < y by rewrite ltzu ltuy.
Qed.

Lemma covers_connect x y : (connect covers x y) = (x <= y).
Proof.
apply/connectP/idP => [[s]|].
  elim: s x => [x /= _ -> // |s0 s IHs] x /= /andP[/andP[/ltW ltxs0 _]].
  by move => {}/IHs H{}/H /(le_trans ltxs0).
move: y; apply covers_ind; last by exists [::].
move=> z y Hcovers [pth Hpath Hlast].
exists (rcons pth y); last by rewrite last_rcons.
by rewrite rcons_path Hpath -Hlast andTb.
Qed.

Lemma covers_path x y :
  reflect (exists2 s, path covers x s & y = last x s) (x <= y).
Proof. by rewrite -covers_connect; apply: (iffP connectP). Qed.

End CoversFinPOrder.

Lemma covers_rind (disp : unit) (T : finPOrderType disp) (P : T -> Type) :
  (forall x y, covers y x -> P x -> P y) ->
  forall x, P x -> forall y, x >= y -> P y.
Proof.
move=> IH x Px y.
rewrite -leEdual; apply: covers_ind => // {Px y}x y.
by rewrite covers_dual => /IH.
Qed.

(******************************************************************************)
(** * Inhabited types                                                        *)
(******************************************************************************)
Module Inhabited.

Section ClassDef.

Structure mixin_of T := Mixin { _ : exists x : T, true }.

Set Primitive Projections.
Record class_of T := Class { base : Choice.class_of T; mixin : mixin_of T }.
Unset Primitive Projections.
Local Coercion base : class_of >->  Choice.class_of.

Structure type := Pack { sort; _ : class_of sort }.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c.

Definition pack m :=
  fun b bT & phant_id (Choice.class bT) b => Pack (@Class T b m).

(* Inheritance *)
Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.

End ClassDef.

Module Exports.

Coercion base : class_of >-> Choice.class_of.
Coercion sort : type >-> Sortclass.

Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.

Notation inhType := type.
Definition InhMixin {T : Type} (x : T) :=
  Mixin (ex_intro (fun=> true) x is_true_true).
Notation InhType T m := (@pack T m _ _ id).
Notation "[ 'inhMixin' 'of' T ]" := (class _ : mixin_of T)
  (at level 0, format "[ 'inhMixin'  'of'  T ]") : form_scope.
Notation "[ 'inhType' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'inhType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'inhType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'inhType'  'of'  T ]") : form_scope.

Definition inh {T : type} : T :=
  xchoose (let: Mixin pf := mixin (class T) in pf).

End Exports.

End Inhabited.
Export Inhabited.Exports.

Lemma inh_xchooseE (T : inhType) (exP : exists x0 : T, true) :
  xchoose exP = @inh T.
Proof. exact: eq_xchoose. Qed.

Lemma inh_chooseE (T : inhType) (x0 : T) :
  choose xpredT x0 = @inh T.
Proof.
rewrite /choose; case: insubP => //= [[x Px]] _ /= ->.
by rewrite inh_xchooseE.
Qed.

Section ProdInhType.

Variable T R : inhType.

Definition prod_inhMixin := InhMixin (@inh T, @inh R).
Canonical prod_inhType := Eval hnf in InhType (T * R) prod_inhMixin.

End ProdInhType.

Definition bool_inhMixin := InhMixin false.
Canonical bool_inhType := InhType bool bool_inhMixin.
Definition nat_inhMixin := InhMixin 0%N.
Canonical nat_inhType := InhType nat nat_inhMixin.
Definition seq_inhMixin (T : Type) := InhMixin (T := seq T) [::].
Canonical seq_inhType (T : choiceType) := InhType (seq T) (seq_inhMixin T).
Definition ordinal_inhMixin n := InhMixin (T := 'I_n.+1) ord0.
Canonical ordinal_inhType n := InhType 'I_n.+1 (ordinal_inhMixin n).

Section Tests.
Let bla : nat * seq bool := inh.
Let blo := [inhType of nat].

Let natt := nat.
Let natt_eqtype := [eqType of natt for [eqType of nat]].
Let natt_choicetype := [choiceType of natt for [choiceType of nat]].
Let natt_inhtype := [inhType of natt for [inhType of nat]].

End Tests.

(******************************************************************************)
(** ** Inhabited partially ordered types                                      *)
(******************************************************************************)
Module InhPOrder.

Section ClassDef.

Set Primitive Projections.
Record class_of (T : Type) : Type := Class {
  base : Order.POrder.class_of T;
  mixin : Inhabited.mixin_of T
}.
Unset Primitive Projections.
Definition base2 T m : Inhabited.class_of T :=
  Inhabited.Class (base m) (mixin m).
Local Coercion base : class_of >-> Order.POrder.class_of.
Local Coercion base2 : class_of >-> Inhabited.class_of.

Structure type (disp : unit) := Pack { sort; _ : class_of sort; }.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (disp : unit) (cT : type disp).
Definition class := let: Pack _ c := cT return class_of cT in c.
Definition clone c of phant_id class c := @Pack disp T c.
Definition clone_with disp' c of phant_id class c := @Pack disp' T c.

Definition pack :=
  fun bT b & phant_id (@Order.POrder.class disp bT) b =>
  fun mT m & phant_id (Inhabited.mixin (@Inhabited.class mT)) m =>
  Pack disp (@Class T b m).

Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.
Definition porderType := @Order.POrder.Pack disp cT class.
Definition inhType := @Inhabited.Pack cT class.

Definition porder_inhType := @Order.POrder.Pack disp inhType class.

End ClassDef.

Module Exports.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion porderType : type >-> Order.POrder.type.
Canonical porderType.
Coercion inhType : type >-> Inhabited.type.
Canonical inhType.
Canonical porder_inhType.
Coercion sort : type >-> Sortclass.
Notation inhPOrderType := type.

Notation "[ 'inhPOrderType' 'of' T ]" := (@pack T _ _ _ id _ _ id)
  (at level 0, format "[ 'inhPOrderType'  'of'  T ]") : form_scope.
End Exports.

End InhPOrder.
Export InhPOrder.Exports.

Canonical bool_inhPOrderType := [inhPOrderType of bool].
Canonical nat_inhPOrderType := [inhPOrderType of nat].

(******************************************************************************)
(** ** Inhabited totally ordered types                                        *)
(******************************************************************************)
Module InhTotal.

Section ClassDef.

Set Primitive Projections.
Record class_of (T : Type) : Type := Class {
  base : Order.Total.class_of T;
  mixin : Inhabited.mixin_of T
}.
Unset Primitive Projections.
Definition base2 T m : Inhabited.class_of T :=
  Inhabited.Class (base m) (mixin m).
Local Coercion base : class_of >-> Order.Total.class_of.
Local Coercion base2 : class_of >-> Inhabited.class_of.

Structure type (disp : unit) := Pack { sort; _ : class_of sort; }.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (disp : unit) (cT : type disp).
Definition class := let: Pack _ c := cT return class_of cT in c.

Definition pack :=
  fun bT b & phant_id (@Order.Total.class disp bT) b =>
  fun mT m & phant_id (Inhabited.mixin (@Inhabited.class mT)) m =>
  Pack disp (@Class T b m).

Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.
Definition porderType := @Order.POrder.Pack disp cT class.
Definition totalType := @Order.Total.Pack disp cT class.
Definition inhType := @Inhabited.Pack cT class.
Definition inhPOrderType :=
  @InhPOrder.Pack disp cT (@InhPOrder.Class _ class (mixin class)).

Definition order_inhType := @Order.Total.Pack disp inhType class.
Definition order_inhPOrderType := @Order.Total.Pack disp inhPOrderType class.

End ClassDef.

Module Exports.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion porderType : type >-> Order.POrder.type.
Canonical porderType.
Coercion totalType : type >-> Order.Total.type.
Canonical totalType.
Coercion inhType : type >-> Inhabited.type.
Canonical inhType.
Coercion inhPOrderType : type >-> InhPOrder.type.
Canonical inhPOrderType.

Canonical order_inhType.
(* Canonical order_inhPOrderType.  Breaks the inheritance orderType -> eqType*)

Coercion sort : type >-> Sortclass.

Notation inhOrderType := type.
Notation "[ 'inhOrderType' 'of' T ]" := (@pack T _ _ _ id _ _ id)
  (at level 0, format "[ 'inhOrderType'  'of'  T ]") : form_scope.
End Exports.

End InhTotal.

Export InhTotal.Exports.

Canonical bool_inhOrderType := [inhOrderType of bool].
Canonical nat_inhOrderType := [inhOrderType of nat].

Section Tests.

Variables (disp : unit) (T1 : orderType disp) (x : T1).
Goal x == x. Proof. by []. Qed.

End Tests.

(******************************************************************************)
(** ** Inhabited finite partially ordered types                               *)
(******************************************************************************)
Module InhFinPOrder.

Section ClassDef.

Set Primitive Projections.
Record class_of (T : Type) : Type := Class {
  base : Order.FinPOrder.class_of T;
  mixin : Inhabited.mixin_of T;
}.
Unset Primitive Projections.

Definition base2 T m : Inhabited.class_of T :=
  Inhabited.Class (base m) (mixin m).
Local Coercion base : class_of >-> Order.FinPOrder.class_of.
Local Coercion base2 : class_of >-> Inhabited.class_of.

Structure type (disp : unit) := Pack { sort; _ : class_of sort; }.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (disp : unit) (cT : type disp).
Definition class := let: Pack _ c := cT return class_of cT in c.

Definition pack :=
  fun bT b & phant_id (@Order.FinPOrder.class disp bT) b =>
  fun mT m & phant_id (Inhabited.mixin (@Inhabited.class mT)) m =>
    Pack disp (@Class T b m).

Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.
Definition countType := @Countable.Pack cT class.
Definition finType := @Finite.Pack cT class.
Definition porderType := @Order.POrder.Pack disp cT class.
Definition finPOrderType := @Order.FinPOrder.Pack disp cT class.

Definition inhType := @Inhabited.Pack cT class.
Definition inhPOrderType :=
  @InhPOrder.Pack disp cT (@InhPOrder.Class _ class (mixin class)).

Definition finporder_inhType := @Order.FinPOrder.Pack disp inhType class.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.

Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion countType : type >-> Countable.type.
Canonical countType.
Coercion finType : type >-> Finite.type.
Canonical finType.
Coercion porderType : type >-> Order.POrder.type.
Canonical porderType.
Coercion finPOrderType : type >-> Order.FinPOrder.type.
Canonical finPOrderType.
Coercion inhType : type >-> Inhabited.type.
Canonical inhType.
Coercion inhPOrderType : type >-> InhPOrder.type.
Canonical inhPOrderType.

Canonical finporder_inhType.

Notation inhFinPOrderType := type.
Notation "[ 'inhFinPOrderType' 'of' T ]" := (@pack T _ _ _ id _ _ id)
  (at level 0, format "[ 'inhFinPOrderType'  'of'  T ]") : form_scope.
End Exports.

End InhFinPOrder.
Export InhFinPOrder.Exports.

Canonical bool_FinPOrderType := [inhFinPOrderType of bool].

(******************************************************************************)
(** ** Inhabited finite totally ordered types                                 *)
(******************************************************************************)
Module InhFinTotal.

Section ClassDef.

Set Primitive Projections.
Record class_of (T : Type) : Type := Class {
  base : Order.FinTotal.class_of T;
  mixin : Inhabited.mixin_of T;
}.
Unset Primitive Projections.
Definition base2 T m : Inhabited.class_of T :=
  Inhabited.Class (base m) (mixin m).
Local Coercion base : class_of >-> Order.FinTotal.class_of.
Local Coercion base2 : class_of >-> Inhabited.class_of.

Structure type (disp : unit) := Pack { sort; _ : class_of sort; }.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (disp : unit) (cT : type disp).
Definition class := let: Pack _ c := cT return class_of cT in c.

Definition pack :=
  fun bT b & phant_id (@Order.FinTotal.class disp bT) b =>
  fun mT m & phant_id (Inhabited.mixin (@Inhabited.class mT)) m =>
    Pack disp (@Class T b m).

Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.
Definition countType := @Countable.Pack cT class.
Definition finType := @Finite.Pack cT class.
Definition porderType := @Order.POrder.Pack disp cT class.
Definition finPOrderType := @Order.FinPOrder.Pack disp cT class.
Definition totalType := @Order.Total.Pack disp cT class.
Definition finTotalType := @Order.FinTotal.Pack disp cT class.
Definition inhType := @Inhabited.Pack cT class.
Definition inhPOrderType :=
  @InhPOrder.Pack disp cT (@InhPOrder.Class _ class (mixin class)).
Definition inhTotalType :=
  @InhTotal.Pack disp cT (@InhTotal.Class _ class (mixin class)).
Definition inhFinPOrderType :=
  @InhFinPOrder.Pack disp cT (@InhFinPOrder.Class _ class (mixin class)).

Definition finTotal_inhType := @Order.FinTotal.Pack disp inhType class.
Definition finTotal_inhPOrderType :=
  @Order.FinTotal.Pack disp inhPOrderType class.
Definition finPOrder_inhTotalType :=
  @Order.FinPOrder.Pack disp inhTotalType class.
Definition finType_inhTotalType :=
  @Finite.Pack inhTotalType class.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.

Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion countType : type >-> Countable.type.
Canonical countType.
Coercion finType : type >-> Finite.type.
Canonical finType.
Coercion porderType : type >-> Order.POrder.type.
Canonical porderType.
Coercion finPOrderType : type >-> Order.FinPOrder.type.
Canonical finPOrderType.
Coercion totalType : type >-> Order.Total.type.
Canonical totalType.
Coercion finTotalType : type >-> Order.FinTotal.type.
Canonical finTotalType.
Coercion inhType : type >-> Inhabited.type.
Canonical inhType.
Coercion  inhPOrderType : type >-> InhPOrder.type.
Canonical inhPOrderType.
Coercion inhTotalType : type >-> InhTotal.type.
Canonical inhTotalType.
Coercion inhFinPOrderType : type >-> InhFinPOrder.type.
Canonical inhFinPOrderType.

Canonical finTotal_inhType.
Canonical finTotal_inhPOrderType.
Canonical finPOrder_inhTotalType.
Canonical finType_inhTotalType.

Notation inhFinOrderType := type.
Notation "[ 'inhFinOrderType' 'of' T ]" := (@pack T _ _ _ id _ _ id)
  (at level 0, format "[ 'inhFinOrderType'  'of'  T ]") : form_scope.
End Exports.

End InhFinTotal.
Export InhFinTotal.Exports.

Canonical bool_FinOrderType := [inhFinOrderType of bool].

Section Tests.

Variables (d : unit) (T : inhFinOrderType d) (x : T).
Goal x == x. Proof. by []. Qed.

End Tests.

(******************************************************************************)
(** * Increasing and nondecreasing maps                                      *)
(******************************************************************************)
Section IncrMap.

Variable (disp1 disp2 : unit).
Variable (T1 : orderType disp1) (T2 : orderType disp2).
Variable F : T1 -> T2.

Section Local.

Variable P : pred T1.
Hypothesis Hincr : {in P &, {homo F : x y / x < y}}.

Lemma in_incrE : {in P &, {mono F : x y / x < y}}.
Proof.
move=> x y Hx Hy.
case: (ltgtP x y) => [/Hincr -> //| /Hincr HFyx | ->].
- by rewrite lt_gtF // HFyx.
- by rewrite ltxx.
Qed.

Lemma in_incr_nondecr : {in P &, {homo F : x y / x <= y}}.
Proof using Hincr.
move=> x y Hx Hy /=; rewrite le_eqVlt => /orP [/eqP -> //=| H].
by rewrite le_eqVlt (Hincr Hx Hy H) orbT.
Qed.

Lemma in_incr_nondecrE : {in P &, {mono F : x y / x <= y}}.
Proof using Hincr.
move=> x y Hx Hy /=; rewrite !le_eqVlt.
case: (ltgtP x y) => /= [/Hincr -> //| /Hincr HFyx | ->].
- by rewrite orbT.
- by rewrite -le_eqVlt leNgt HFyx.
- by rewrite eq_refl.
Qed.

Lemma in_incr_inj : {in P &, injective F}.
Proof using Hincr.
move=> x y Hx Hy /eqP.
by rewrite !eq_le !in_incr_nondecrE // -!eq_le => /eqP.
Qed.

End Local.

Definition incrE Hincr := in2T (in_incrE (in2W Hincr)).
Definition incr_nondecr Hincr := in2T (in_incr_nondecr (in2W Hincr)).
Definition incr_nondecrE Hincr := in2T (in_incr_nondecr (in2W Hincr)).
Definition incr_inj Hincr := in2T (in_incr_inj (in2W Hincr)).

End IncrMap.

(******************************************************************************)
(** * sequences over an ordered types                                        *)
(******************************************************************************)
(** *** Maximum of a sequence *)
Section MaxSeq.

Variables (disp : unit) (T : orderType disp).
Implicit Type a b c : T.
Implicit Type u v : seq T.

Definition maxL a := foldl Order.max a.

Lemma maxLb a u : a <= maxL a u.
Proof using.
elim: u a => //= u0 u IHu a.
apply: (@le_trans _ _ (Order.max a u0)); last exact: IHu.
by rewrite le_maxr lexx.
Qed.

Lemma in_maxL a u : (maxL a u) \in a :: u.
Proof using.
elim: u a => [| u0 u IHu]//= a; first by rewrite mem_seq1.
case (leP a u0) => H.
+ by have:= H => /max_idPr ->; rewrite in_cons IHu orbT.
+ have:= ltW H => /max_idPl ->; rewrite !in_cons.
  by rewrite orbA [(_ == _) || (_ == _) ]orbC -orbA -in_cons IHu orbT.
Qed.

Lemma maxXL a b u : Order.max a (maxL b u) = maxL (Order.max a b) u.
Proof using. by elim: u b => //= u0 u IHu b; rewrite -maxA; apply: IHu. Qed.

Lemma maxL_cat a u b v : maxL a (u ++ b :: v) = Order.max (maxL a u) (maxL b v).
Proof using.
elim: u a => [| u0 u IHu]/= a; first by rewrite maxXL.
exact: IHu.
Qed.

End MaxSeq.

(** *** Comparison of the elements of a sequence to an element *)
Section AllLeqLtn.

Variables (disp : unit) (T : orderType disp).
Implicit Type a b c : T.
Implicit Type u v : seq T.

Definition allLeq v a := all (<= a) v.
Definition allLtn v a := all (< a) v.

Lemma allLtn_notin s b : allLeq s b -> b \notin s -> allLtn s b.
Proof using.
elim: s => //= s0 s IHs /andP [].
rewrite lt_neqAle => -> /IHs{IHs} Hrec.
by rewrite inE negb_or eq_sym => /andP [] ->.
Qed.

Lemma maxLPt a u : allLeq u (maxL a u).
Proof using.
rewrite/allLeq; apply/allP => x Hx.
elim: u Hx a => //= u0 u IHu; rewrite inE => /orP [/eqP -> | /IHu Hx] a.
- by rewrite maxC -maxXL le_maxr lexx.
- exact: Hx.
Qed.
Lemma maxLP a u : allLeq (a :: u) (maxL a u).
Proof using. by rewrite /= (maxLPt a u) (maxLb a u). Qed.

Lemma allLtnW v a : allLtn v a -> allLeq v a.
Proof using. by move/allP=> Hall; apply/allP=> x Hx; apply: ltW; apply: Hall. Qed.

Lemma allLeqE u a : allLeq u a -> maxL a u = a.
Proof using. by elim: u => //= u0 u IHu /andP [] /max_idPl -> /IHu. Qed.
Lemma allLeqP u a : reflect (maxL a u = a) (allLeq u a).
Proof using.
apply: (iffP idP); first exact: allLeqE.
rewrite/allLeq; elim: u a => //= u0 u IHu a.
rewrite maxC -maxXL => Hmax.
have Hu : maxL a u = a.
  by apply le_anti; rewrite maxLb andbT -{2}Hmax le_maxr lexx orbT.
by rewrite -{1}Hmax le_maxr lexx /= IHu.
Qed.

Lemma allLeqCons b u a : b <= a -> allLeq u a -> allLeq (b :: u) a.
Proof using.
move=> Hb /allP Hall; apply/allP => x.
by rewrite inE => /orP [/eqP -> //=|] /Hall.
Qed.
Lemma allLtnCons b u a : b < a -> allLtn u a -> allLtn (b :: u) a.
Proof using.
move=> Hb /allP Hall; apply/allP => x.
by rewrite inE => /orP [/eqP -> //=|] /Hall.
Qed.

Lemma allLeqConsE u a b : allLeq (b :: u) a = (maxL b u <= a).
Proof using.
elim: u b => [| u0 u IHu]/= b; first by rewrite andbT.
by rewrite maxC -maxXL le_maxl -IHu /= !andbA [(u0 <= a) && (b <= a)]andbC.
Qed.

Lemma allLtnConsE u a b : allLtn (b :: u) a = (maxL b u < a).
Proof using.
elim: u b => [| u0 u IHu]/= b; first by rewrite andbT.
by rewrite maxC -maxXL lt_maxl -IHu /= !andbA [(u0 < a) && (b < a)]andbC.
Qed.

Lemma allLeq_consK b u a : allLeq (b :: u) a -> allLeq u a.
Proof using.
move/allP => Hall; apply/allP => x Hx; apply: Hall.
by rewrite inE Hx orbT.
Qed.
Lemma allLtn_consK b u a : allLtn (b :: u) a -> allLtn u a.
Proof using.
move/allP => Hall; apply/allP => x Hx; apply: Hall.
by rewrite inE Hx orbT.
Qed.

Lemma allLeq_catE u v a : allLeq (u ++ v) a = allLeq u a && allLeq v a.
Proof using. by rewrite /allLeq all_cat. Qed.
Lemma allLtn_catE u v a : allLtn (u ++ v) a = allLtn u a && allLtn v a.
Proof using. by rewrite /allLtn all_cat. Qed.

Lemma maxL_perm a u b v : perm_eq (a :: u) (b :: v) -> maxL a u = maxL b v.
Proof using.
move/permP => Hperm.
have {}Hperm : forall x, (x \in (a :: u)) = (x \in (b :: v)).
  move=> x; move/(_ (xpred1 x)) : Hperm => Hperm.
  by apply/idP/idP => /count_memPn H; apply/count_memPn;
    rewrite ?Hperm // -?Hperm.
apply/eqP; rewrite eq_le; apply/andP; split.
- move/(_ (maxL a u)) : Hperm; rewrite (in_maxL a u) => /esym Hin.
  exact: (allP (maxLP b v)).
- move/(_ (maxL b v)) : Hperm; rewrite (in_maxL b v) => /esym Hin.
  exact: (allP (maxLP a u)).
Qed.

Lemma perm_allLeq u v a : perm_eq u v -> allLeq u a -> allLeq v a.
Proof using.
move=> Hperm /allLeqP; rewrite (maxL_perm (b := a) (v := v)).
- by move=> Hall; apply/allLeqP.
- by rewrite perm_cons.
Qed.
Lemma perm_allLeqE u v a : perm_eq u v -> allLeq u a = allLeq v a.
Proof using.
move=> H; apply/idP/idP; apply: perm_allLeq; first by [].
by rewrite perm_sym.
Qed.
Lemma perm_allLtn u v a : perm_eq u v -> allLtn u a -> allLtn v a.
Proof using.
move=> Hperm /allP Hall; apply/allP => X Hx.
by apply: Hall; rewrite (perm_mem Hperm).
Qed.
Lemma perm_allLtnE u v a : perm_eq u v -> allLtn u a = allLtn v a.
Proof using.
move=> H; apply/idP/idP; apply: perm_allLtn; first by [].
by rewrite perm_sym.
Qed.

Lemma allLeq_rev u a : allLeq (rev u) a = allLeq u a.
Proof using. by apply: perm_allLeqE; rewrite perm_rev. Qed.
Lemma allLtn_rev u a : allLtn (rev u) a = allLtn u a.
Proof using. by apply: perm_allLtnE; rewrite perm_rev. Qed.

Lemma allLeq_rconsK b u a : allLeq (rcons u b) a -> allLeq u a.
Proof using.
rewrite -allLeq_rev rev_rcons => /allLeq_consK.
by rewrite allLeq_rev.
Qed.
Lemma allLtn_rconsK b u a : allLtn (rcons u b) a -> allLtn u a.
Proof using.
rewrite -allLtn_rev rev_rcons => /allLtn_consK.
by rewrite allLtn_rev.
Qed.

Lemma allLeq_last b u a : allLeq (rcons u b) a -> b <= a.
Proof using. by rewrite -allLeq_rev rev_rcons /= => /andP []. Qed.
Lemma allLtn_last b u a : allLtn (rcons u b) a -> b < a.
Proof using. by rewrite -allLtn_rev rev_rcons /= => /andP []. Qed.

Lemma maxL_LbR a v L b R :
  a :: v = L ++ b :: R -> allLeq L b -> allLeq R b -> maxL a v = b.
Proof using.
rewrite /allLeq /maxL => Heq HL Hr.
apply/eqP; rewrite eq_le; apply/andP; split.
- have: all (<= b) (a :: v) by rewrite Heq all_cat HL /= lexx Hr.
  by move/allP => Hallv; apply: Hallv; exact: in_maxL.
- have:= maxLP a v => /allP; rewrite Heq; apply.
  by rewrite mem_cat inE eq_refl /= orbT.
Qed.

End AllLeqLtn.

(** *** Removing the largest letter of a sequence *)
Section RemoveBig.

Variables (disp : unit) (T : orderType disp).
Variable Z : T.
Implicit Type a b c : T.
Implicit Type u v w r : seq T.

(** Remove the last occurence of the largest letter from w *)
Fixpoint rembig w :=
  if w is a :: v then
    if allLtn v a then v else a :: rembig v
  else [::].

(** Position of the last occurence of the largest letter of w *)
Fixpoint posbig w :=
  if w is a :: v then
    if allLtn v a then 0 else (posbig v).+1
  else 0.

Lemma size_rembig w : size (rembig w) = (size w).-1.
Proof using.
elim: w => //= a w IHw.
case: w IHw => [//= | b w'] IHw.
by case (allLtn (b :: w') a); rewrite //= IHw.
Qed.

Lemma rembig_catR a u b v :
  maxL a u <= maxL b v -> rembig (a :: u ++ b :: v) = a :: u ++ rembig (b :: v).
Proof using.
rewrite /=; elim: u a => [| u0 u IHu] a.
  by rewrite allLtnConsE /= leNgt /= => /negbTE ->.
rewrite allLtnConsE maxL_cat /= -maxXL le_maxl => /andP [] Ha Hmax.
by rewrite ltNge le_maxr Ha orbT /= -(IHu _ Hmax).
Qed.

Lemma rembig_catL a u b v :
  maxL a u > maxL b v -> rembig (a :: u ++ b :: v) = rembig (a :: u) ++ b :: v.
Proof using.
rewrite /=; elim: u a => [| u0 u IHu] a.
  by rewrite allLtnConsE /= ltNge /= => /negbTE ->.
rewrite allLtn_catE !allLtnConsE /= -maxXL maxC /Order.max.
case: (ltP (maxL u0 u) a) => [H -> //= | H Hmax /=].
by rewrite IHu.
Qed.

Lemma rembig_cat u v :
  rembig (u ++ v) = (rembig u) ++ v \/ rembig (u ++ v) = u ++ (rembig v).
Proof using.
case: u => [/= | a u]; first by right.
case: v => [/= | b v]; first by rewrite !cats0; left.
case (leP (maxL a u) (maxL b v)) => Hcase.
- by rewrite (rembig_catR Hcase); right.
- by rewrite (rembig_catL Hcase); left.
Qed.

Lemma rembig_eq_permL u1 u2 v :
  perm_eq u1 u2 ->
  (rembig (u1 ++ v) = (rembig u1) ++ v /\
   rembig (u2 ++ v) = (rembig u2) ++ v)
  \/
  (rembig (u1 ++ v) = u1 ++ (rembig v) /\
   rembig (u2 ++ v) = u2 ++ (rembig v)).
Proof using.
case: u2 => [| a2 u2]; first by move/perm_size => /eqP /= /nilP ->; right.
case: u1 => [| a1 u1]; first by move/perm_size.
case: v => [/= | b v]; first by rewrite /= !cats0; left.
move/maxL_perm => Heq.
case (leP (maxL a1 u1) (maxL b v)) => H1; have := H1; rewrite Heq => H2.
- by right; rewrite (rembig_catR H1) (rembig_catR H2).
- by left;  rewrite (rembig_catL H1) (rembig_catL H2).
Qed.

Lemma rembig_eq_permR u v1 v2 :
  perm_eq v1 v2 ->
  (rembig (u ++ v1) = (rembig u) ++ v1 /\
   rembig (u ++ v2) = (rembig u) ++ v2)
  \/
  (rembig (u ++ v1) = u ++ (rembig v1) /\
   rembig (u ++ v2) = u ++ (rembig v2)).
Proof using.
case: v2 => [| b2 v2].
  by move/perm_size => /eqP /= /nilP ->; left; rewrite !cats0.
case: v1 => [//= | b1 v1]; first by move/perm_size.
case: u => [//= | a u]; first by right.
move/maxL_perm => Heq.
case (leP (maxL a u) (maxL b1 v1)) => H1; have := H1; rewrite Heq => H2.
- by right; rewrite (rembig_catR H1) (rembig_catR H2).
- by left;  rewrite (rembig_catL H1) (rembig_catL H2).
Qed.

Lemma rembigP w wb : wb != [::] ->
  reflect
    (exists u b v, [/\ w = u ++ v, wb = u ++ b :: v, allLeq u b & allLtn v b])
    (w == rembig wb).
Proof using.
move=> Hwb; apply: (iffP idP).
- elim: wb Hwb w => [| w0 wb IHwb _] //= w.
  case H : (allLtn wb w0) => /eqP -> {w}.
  + by exists [::], w0, wb; rewrite H !cat0s; split.
  + have Hwb : wb != [::] by move: H; case wb.
    move Hw : (rembig wb) => w.
    move: Hw => /esym/eqP/(IHwb Hwb w) [u] [b] [v] [Hcatw Hcatwb Hub Hvb].
    exists (w0 :: u), b, v; split.
    * by rewrite Hcatw.
    * by rewrite Hcatwb.
    * move: H; rewrite Hcatwb /= Hub andbT => /negbT.
      apply: contraR; rewrite -ltNge => Hb.
      rewrite allLtn_catE /= Hb /=; apply/andP; split.
      + move: Hub => /allP /= Hub; apply/allP => x Hx /=.
        exact: (le_lt_trans (Hub x Hx)).
      + move: Hvb => /allP /= Hvb; apply/allP => x Hx /=.
        exact: (lt_trans (Hvb x Hx)).
    * exact: Hvb.
- move=> [u] [b] [v] [] {Hwb}.
  elim: u w wb => [w wb -> -> _ /= -> // | u0 u IHu].
  move=> w wb -> {w} -> {wb} Hleqb Hltnb /=.
  move Hw : (u ++ v) => w; move: Hw => /esym Hw.
  move Hwb : (u ++ b :: v) => wb; move: Hwb => /esym => Hwb.
  have:= IHu _ _ Hw Hwb (allLeq_consK Hleqb) Hltnb => /eqP ->.
  rewrite allLeqConsE in Hleqb.
  have:= le_trans (maxLb u0 u) Hleqb; rewrite {2}Hwb.
  case H : (allLtn (u ++ b :: v) u0) => //=.
  move: H; rewrite allLtn_catE allLtnConsE => /andP [] _.
  move/(le_lt_trans (maxLb _ _)) => H1 H2.
  by have:= lt_le_trans H1 H2; rewrite ltxx.
Qed.

Lemma perm_rembig u v :
  perm_eq u v -> perm_eq (rembig u) (rembig v).
Proof using.
case Hu: u => [/= | u0 u']; case Hv: v => [//= | v0 v'].
- by move=> /perm_size /=.
- by move=> /perm_size /=.
move=> Hperm; have Hmax:= maxL_perm Hperm; move: Hmax Hperm.

have/(congr1 rembig):= Hu => /eqP/rembigP Htmp.
have /Htmp {Htmp} : u0 :: u != [::] by [].
move=> [u1] [bu] [u2] []; rewrite {1}Hu => -> Hub Hlequ Hltnu.
rewrite (maxL_LbR Hub Hlequ (allLtnW Hltnu)) {Hlequ Hltnu}.
rewrite Hub {u Hu Hub u0 u'}.

have/(congr1 rembig):= Hv => /eqP/rembigP Htmp.
have /Htmp {Htmp} : v0 :: v != [::] by [].
move=> [v1] [bv] [v2] []; rewrite {1}Hv => -> Hvb Hleqv Hltnv.
rewrite (maxL_LbR Hvb Hleqv (allLtnW Hltnv)) {Hleqv Hltnv}.
rewrite Hvb {v Hv Hvb v0 v'}.

rename bv into mx; move ->.
rewrite -[mx :: u2]cat1s -[mx :: v2]cat1s.
rewrite -[perm_eq (u1 ++ u2) _](perm_cons mx).
have Hlemma u v : perm_eq (u ++ [:: mx] ++ v) (mx :: u ++ v).
  rewrite catA -[mx :: u ++ v]/((mx :: u) ++ v) perm_cat2r -[mx :: u]cat1s.
  apply: permEl; exact: perm_catC.
move=> H; have:= Hlemma u1 u2; rewrite perm_sym.
move/perm_trans; apply.
by apply: (perm_trans H); apply: Hlemma.
Qed.

Lemma rembig_rev_uniq s : uniq s -> rev (rembig s) = rembig (rev s).
Proof using.
case: (altP (s =P [::])) => [-> /= |]; first by rewrite /rev.
move=> /rembigP /(_ (eq_refl (rembig s))) [u] [b] [v] [] -> -> Hu Hb.
rewrite -rev_uniq !rev_cat rev_cons -cats1 -catA cat1s.
rewrite cat_uniq => /and3P [_ _ /= /andP []].
rewrite mem_rev => Hbu _.
apply/eqP/rembigP; first by case: (rev v).
exists (rev v), b, (rev u); split => //.
- by rewrite allLeq_rev; apply: allLtnW.
- by rewrite allLtn_rev; apply: allLtn_notin.
Qed.

Lemma rembig_subseq s : subseq (rembig s) s.
Proof using.
elim: s => //= s0 s IHs.
case: allLtn; last by rewrite eq_refl.
case: s {IHs} => [//| s1 s].
by case: eqP => _; [apply: subseq_cons | apply: subseq_refl].
Qed.

Lemma rembig_uniq s : uniq s -> uniq (rembig s).
Proof using. by apply: subseq_uniq; apply: rembig_subseq. Qed.

Open Scope nat_scope.

Lemma posbig_size_cons l s : posbig (l :: s) < size (l :: s).
Proof using.
elim H : s l => [//= | s0 s' IHs] l; rewrite -H /=.
by case (allLtn s l); rewrite // H ltnS; apply: IHs.
Qed.

Lemma posbig_size s : s != [::] -> posbig s < size s.
Proof using. by case: s => //= s l _; apply: posbig_size_cons. Qed.

Lemma posbigE u b v :
  (allLeq u b && allLtn v b) = (posbig (u ++ b :: v) == size u).
Proof using.
apply/andP/idP => [[Hu Hv]|].
- elim: u Hu => [| u0 u IHu] /=; first by rewrite Hv.
  move=> /andP [Hub Hall]; rewrite allLtn_catE /= ltNge Hub andbF eqSS.
  exact: IHu.
- elim: u => [/= | u0 u /= IHu]; first by case (allLtn v b).
  case (boolP (allLtn (u ++ b :: v) u0)) => [| Hall] //=.
  rewrite eqSS => /IHu {IHu} [Hub Hvb].
  split; last exact: Hvb.
  rewrite Hub andbT.
  move: Hall; apply: contraR; rewrite -ltNge => H.
  rewrite allLtn_catE /= H /=.
  apply/andP; split; apply/allP => x.
  + by move: Hub => /allP X/X{X} /= H1; apply: (le_lt_trans H1 H).
  + by move: Hvb => /allP X/X{X} /= H1; apply: (lt_trans H1 H).
Qed.

Lemma posbig_take_dropE l s :
  take (posbig (l :: s)) (rembig (l :: s)) ++
     maxL l s
     :: drop (posbig (l :: s)) (rembig (l :: s)) = l :: s.
Proof using.
elim Hs : s l => [// | s0 s' IHs] l; rewrite -Hs /=.
case (boolP (allLtn s l)) => Hl /=.
- by rewrite take0 drop0 /=; have:= (allLtnW Hl) => /allLeqE ->.
- move: Hl; rewrite Hs allLtnConsE -leNgt /= -maxXL => /max_idPr ->.
  by rewrite (IHs s0).
Qed.

Lemma nth_posbig l s : nth Z (l :: s) (posbig (l :: s)) = maxL l s.
Proof using.
rewrite /=; case: (boolP (allLtn s l)).
- by move/allLtnW/allLeqP => ->.
- elim Hs : s l => [| s0 s' IHs] //= l.
  rewrite maxC /Order.max.
  case: (ltP s0 l) => Hl /= H.
  + rewrite -(IHs l H).
    suff -> : allLtn s' s0 = false by [].
    apply: negbTE; move: H; apply: contra; apply: sub_all => i /= Hi.
    exact: (lt_trans Hi).
  + case (boolP (allLtn s' s0)) => /= [|Hs0].
    * by move /allLtnW/allLeqP ->.
    * exact: (IHs s0 Hs0).
Qed.

Lemma allLeq_posbig l s :
  allLeq (take (posbig (l :: s)) (l :: s)) (maxL l s).
Proof using.
have:= maxLP l s; rewrite -{1}[l :: s](cat_take_drop (posbig (l :: s))).
by rewrite allLeq_catE => /andP [].
Qed.

Lemma allLtn_posbig l s :
  allLtn (drop (posbig (l :: s)).+1 (l :: s)) (maxL l s).
Proof using.
elim Hs : s l => [//= | s0 s'] IHs l; rewrite -Hs /=.
move/(_ (Order.max l s0)) : IHs; rewrite /= maxC /Order.max.
case: (ltP s0 l) => Hs0; rewrite Hs /=.
- rewrite Hs0 /=; have:= ltW Hs0 => /max_idPl ->.
  case (boolP (allLtn s' l)) => Hall.
  + rewrite drop0 /= => ->.
    have /allLeqE -> := allLtnW Hall.
    by rewrite Hs0.
  + suff -> : allLtn s' s0 = false by [].
    apply: negbTE; move: Hall; apply: contra; apply: sub_all => i /= Hi.
    exact: (lt_trans Hi).
- rewrite ltNge Hs0 /=.
  by move: Hs0 => /max_idPr ->.
Qed.

Lemma rembigE l s :
  take (posbig (l :: s)) (l :: s) ++
       drop (posbig (l :: s)).+1 (l :: s) = rembig (l :: s).
Proof using Z.
apply/eqP/rembigP; first by [].
set ss := l :: s; set pos := posbig (l :: s).
exists (take pos ss), (nth Z ss pos), (drop pos.+1 ss); split.
- by [].
- rewrite [X in _ ++ X](_ : _ = drop pos ss) ?cat_take_drop //.
  rewrite /ss /pos /= {ss pos}.
  elim H : s => [//= | s0 s']; rewrite -H.
  case (boolP (allLtn s l)) => Hmax /=; first by rewrite drop0.
  move: Hmax; rewrite H => Hmax /=.
  case (boolP (allLtn s' s0)) => Hmax0 /=; first by rewrite drop0.
  suff -> : allLtn s' l = false by [].
  apply: negbTE; move: Hmax; apply: contra => /= Hmax.
  apply: allLtnCons; last exact Hmax.
  case: s' Hmax0 Hmax {H} => [//= | s1 s']; rewrite !allLtnConsE.
  by rewrite -leNgt; apply: le_lt_trans.
- by rewrite /ss /pos {ss pos} nth_posbig; apply: allLeq_posbig.
- by rewrite /ss /pos {ss pos} nth_posbig; apply: allLtn_posbig.
Qed.

Lemma nth_lt_posbig i s : i < posbig s -> nth Z (rembig s) i = nth Z s i.
Proof using.
  case H : s => [//= | s0 s'] => Hi.
  rewrite -rembigE -H -{5}[s](cat_take_drop (posbig s)) !nth_cat.
  by rewrite size_take posbig_size H //= Hi.
Qed.

Definition shift_pos    pos i := if i < pos then i else i.+1.
Definition shiftinv_pos pos i := if i < pos then i else i.-1.

Lemma shift_posK pos i : shiftinv_pos pos (shift_pos pos i) = i.
Proof using.
rewrite /shift_pos /shiftinv_pos.
case (ltnP i pos) => [-> // | Hi].
by rewrite ltnNge (leq_trans Hi (leqnSn _)).
Qed.

Lemma shiftinv_posK pos i : i != pos -> shift_pos pos (shiftinv_pos pos i) = i.
Proof using.
rewrite /shift_pos /shiftinv_pos => Hipos.
case (ltnP i pos) => [-> // | Hi].
case: i Hipos Hi => [| i] /=.
- move=> H1 H2; exfalso.
  move: H2; rewrite leqn0 => /eqP H.
  by rewrite H in H1.
- rewrite ltnNge => H1 H2.
  rewrite eq_sym in H1.
  by rewrite -ltnS ltn_neqAle H1 H2 /=.
Qed.

Lemma nth_rembig s i :
  nth Z s (shift_pos (posbig s) i) = nth Z (rembig s) i.
Proof using.
case Hs : s => [//= | s0 s'].
rewrite /shift_pos -rembigE nth_cat -Hs.
rewrite size_take posbig_size; last by rewrite Hs.
case (ltnP i (posbig s)) => Hipos.
- by rewrite nth_take.
- by rewrite nth_drop addSn subnKC.
Qed.

Lemma nth_inspos s pos i n :
  pos <= size s ->
  nth Z ((take pos s) ++ n :: (drop pos s)) i =
  if i == pos then n else nth Z s (shiftinv_pos pos i).
Proof using.
move=> Hpos.
case: (altP (i =P pos)) => [-> {i} | Hipos].
  by rewrite nth_cat size_takel // ltnn subnn.
rewrite /shiftinv_pos nth_cat size_take.
case (ltnP pos (size s)) => [{}Hpos | Hpos2].
- case: (ltnP i pos) => Hi; first by rewrite (nth_take _ Hi).
  have {Hipos}Hi : pos < i by rewrite ltn_neqAle eq_sym Hipos Hi.
  case: i Hi => //= i; rewrite ltnS => Hi.
  by rewrite (subSn Hi) /= nth_drop (subnKC Hi).
- have {Hpos2}Hpos : pos = size s by apply anti_leq; rewrite Hpos Hpos2.
  subst pos.
  case: (ltnP i (size s)) => Hisz; first by rewrite (nth_take _ Hisz).
  have {Hipos Hisz} : size s < i by rewrite ltn_neqAle eq_sym Hisz Hipos.
  case: i => //= i; rewrite ltnS => Hi.
  by rewrite (subSn Hi) /= nth_drop (subnKC Hi).
Qed.

Lemma shift_pos_incr pos : {homo shift_pos pos : i j / i <= j}.
Proof using.
move=> i j Hij; rewrite /shift_pos; case (ltnP j pos) => Hj.
- by rewrite (leq_ltn_trans Hij Hj).
- case (ltnP i pos) => Hi.
  + exact: (leq_trans Hij).
  + exact: (leq_ltn_trans Hij).
Qed.

Lemma shiftinv_pos_incr pos : {homo shiftinv_pos pos : i j / i <= j}.
Proof using.
move=> i j Hij; rewrite /shiftinv_pos; case (ltnP j pos) => Hj.
- by rewrite (leq_ltn_trans Hij Hj).
- case (ltnP i pos) => Hi.
  + by have:= leq_trans Hi Hj; case j.
  + by case: i Hij {Hj Hi} => //= i; case: j.
Qed.

End RemoveBig.

Prenex Implicits rembig posbig.

Lemma maxL_iota n i : maxL i (iota i.+1 n) = i + n.
Proof.
elim: n i => [|n IHn] i /=; first by rewrite addn0.
by rewrite /Order.max ltEnat /= ltnSn IHn addSnnS.
Qed.

Lemma maxL_iota_n n : maxL 0%N (iota 1 n) = n.
Proof. by rewrite -{2}[n]add0n maxL_iota. Qed.

Lemma rembig_iota n i : rembig (iota i n.+1) = iota i n.
Proof.
elim: n i => //= n IHn i.
move/(_  i.+1) : IHn => /= ->.
by rewrite ltEnat /= ltnNge leqnSn.
Qed.

(** ** The order on ordinals ***)

(** TODO : replace the following by
    Export Order.OrdinalOrder.Exports when integrated in mathcomp*)

Section OrdinalOrder.
Variable n : nat.
Definition ord_porderMixin := [porderMixin of 'I_n by <:].
Canonical ord_porderType :=
  POrderType Order.NatOrder.nat_display 'I_n ord_porderMixin.
Definition ord_totalOrderMixin := [totalOrderMixin of 'I_n by <:].
Canonical ord_latticeType := LatticeType 'I_n ord_totalOrderMixin.
Canonical ord_distrLatticeType := DistrLatticeType 'I_n ord_totalOrderMixin.
Canonical sub_orderType := OrderType 'I_n ord_totalOrderMixin.
End OrdinalOrder.

Section OrdinalInhabited.
Variable n0 : nat.
Local Notation n := n0.+1.
Implicit Type x : 'I_n.

Lemma ord_bottom x : (ord0 <= x)%O.
Proof. by []. Qed.
Lemma ord_top x : (x <= ord_max)%O.
Proof. by case: x => x ltx /=. Qed.

Definition ord_bottomMixin := BottomMixin ord_bottom.
Canonical ord_blatticeType := BLatticeType 'I_n ord_bottomMixin.
Definition ord_topMixin := TopMixin ord_top.
Canonical ord_tblatticeType := TBLatticeType 'I_n ord_topMixin.
Canonical ord_finLatticeType := Eval hnf in [finLatticeType of 'I_n].
Canonical ord_bDistrLatticeType := Eval hnf in [bDistrLatticeType of 'I_n].
Canonical ord_tbDistrLatticeType := Eval hnf in [tbDistrLatticeType of 'I_n].
Canonical ord_finDistrLatticeType :=
  Eval hnf in [finDistrLatticeType of 'I_n].
Canonical ord_finOrderType := [finOrderType of 'I_n].

Canonical ord_inhPOrderType := [inhPOrderType of 'I_n].
Canonical ord_inhOrderType := [inhOrderType of 'I_n].
Canonical ord_inhfinOrderType := [inhFinOrderType of 'I_n].
End OrdinalInhabited.


(* Generated by coq-of-rust *)
Require Import CoqOfRust.CoqOfRust.

Import Root.std.prelude.rust_2015.

Definition main (_ : unit) : unit :=
  fizzbuzz_to 100 ;;
  tt.

Definition is_divisible_by (lhs : u32) (rhs : u32) : bool :=
  if (eqb rhs 0 : bool) then
    Return false ;;
    tt
  else
    tt ;;
  eqb (rem lhs rhs) 0.

Definition fizzbuzz (n : u32) :  :=
  if (is_divisible_by n 15 : bool) then
    _crate.io._print (_crate.fmt.ImplArguments.new_v1 [ "fizzbuzz\n" ] [  ]) ;;
    tt ;;
    tt
  else
    if (is_divisible_by n 3 : bool) then
      _crate.io._print (_crate.fmt.ImplArguments.new_v1 [ "fizz\n" ] [  ]) ;;
      tt ;;
      tt
    else
      if (is_divisible_by n 5 : bool) then
        _crate.io._print (_crate.fmt.ImplArguments.new_v1 [ "buzz\n" ] [  ]) ;;
        tt ;;
        tt
      else
        _crate.io._print
          (_crate.fmt.ImplArguments.new_v1
            [ ""; "\n" ]
            [ _crate.fmt.ImplArgumentV1.new_display n ]) ;;
        tt ;;
        tt.

Definition fizzbuzz_to (n : u32) : unit :=
  match into_iter (range_inclusive_new 1 n) with
  | iter =>
    loop
      match next iter with
      | None => Break
      | Some {| Some.0 := n; |} =>
        fizzbuzz n ;;
        tt
      end ;;
      tt
      from
      for
  end.


Set Implicit Arguments.

Require Import Coq.Lists.List.

Section TopSection.

  Require Import Platform.Cito.GeneralTactics2.

  Lemma NoDup_cons_cons : forall A (x y : A) ls, List.NoDup (x :: y :: ls) -> x <> y.
    intros.
    inversion H.
    not_not.
    subst.
    intuition.
  Qed.

  Lemma NoDup_cons_elim : forall A ls (e : A), List.NoDup (e :: ls) -> forall e', List.In e' ls -> e' <> e.
    induction ls; simpl; intuition.
    subst.
    eapply NoDup_cons_cons in H.
    intuition.
    subst.
    inversion H; subst.
    intuition.
  Qed.

  Require Import Coq.Classes.Morphisms.

  Lemma Forall2_map : forall A B (f1 f2 : A -> B) R ls, pointwise_relation _ R f1 f2 -> Forall2 R (List.map f1 ls) (List.map f2 ls).
    unfold pointwise_relation.
    induction ls; simpl; intuition.
  Qed.

  Fixpoint fold_right_2 A (f : A -> A -> A) def ls :=
    match ls with
      | nil => def
      | x :: nil => x
      | x :: xs => f x (fold_right_2 f def xs)
    end.

End TopSection.


(** In this file, we build a strong normalization model of the
    Calculus of Constructions extended with natural numbers and
    the usual recursor.
    This file supports universes.
 *)

Set Implicit Arguments.
Require Import basic ZF ZFcoc ZFuniv_real ZFnats.
Require Import Sat SATnat SN_CC_Real.
Module Lc:=Lambda.

(* Building the realizability on the nats of ZFnats *)
Require ModelZF.
Module natARG <: SimpleNats ModelZF.ZFsets.
  Include ZFnats.
  Definition Nbot := N.
 Definition N_Nbot : forall x:X, x∈N -> x ∈Nbot := fun _ h => h.
 Definition Ndec n (h:n∈Nbot) : n∈N \/ ~n∈N := or_introl _ h.
End natARG.
Module SAT_nat := SATnat.Make(ModelZF.ZFsets)(natARG).
Export natARG SAT_nat.
Export CC_Real.

(** * Nat and its constructors *)

Definition Zero : term.
(*begin show*)
left; exists (fun _ => zero) (fun _ => ZE).
(*end show*)
 do 2 red; reflexivity.
 do 2 red; reflexivity.
 red; reflexivity.
 red; reflexivity.
Defined.

Definition Succ : term.
(*begin show*)
left; exists (fun _ => CC_Real.lam (mkTY N cNAT) succ) (fun _ => SU).
(*end show*)
 do 2 red; reflexivity.
 do 2 red; reflexivity.
 red; reflexivity.
 red; reflexivity.
Defined.

Definition Nat : term.
(*begin show*)
left; exists (fun _ => mkTY N cNAT) (fun _ => Lc.K).
(*end show*)
 do 2 red; reflexivity.
 do 2 red; reflexivity.
 red; reflexivity.
 red; reflexivity.
Defined.

Lemma mt_in_N : cc_bot N == N.
apply eq_intro; intros.
 apply union2_elim in H; destruct H; trivial.
 apply singl_elim in H; rewrite H.
 apply zero_typ.

 apply union2_intro2; trivial.
Qed.
Definition eqNbot := mt_in_N.

Lemma ElNat_eq i : El (int Nat i) == N.
simpl; rewrite El_def.
apply mt_in_N.
Qed.

Lemma RealNat_eq i n :
  n ∈ N ->
  eqSAT (Real (int Nat i) n) (cNAT n).
intros.
simpl int.
rewrite Real_def; intros; trivial.
 reflexivity.

 apply cNAT_morph; trivial.

 rewrite mt_in_N; trivial.
Qed.

  Notation "[ x , t ] \real A" := (x ∈ El A  /\ inSAT t (Real A x)) (at level 60).

Lemma realNat_def : forall i n t,
  [n,t] \real int Nat i <-> n ∈ N /\ inSAT t (cNAT n).
intros.
rewrite ElNat_eq.
split; destruct 1; split; trivial.
 rewrite RealNat_eq in H0; trivial.
 rewrite RealNat_eq; trivial.
Qed.

(** Typing rules of constructors *)
Lemma typ_0 : forall e, typ e Zero Nat.
intros.
apply typ_common;[exact I|intros].
apply realNat_def; split.
 apply zero_typ.

 apply cNAT_ZE.
Qed.

Lemma sn_SU : Lc.sn SU.
unfold SU.
constructor; intros ? h.
apply Lc.nf_norm in h;[contradiction|repeat constructor].
Qed.

Lemma typ_S : forall e, typ e Succ (Prod Nat (lift 1 Nat)).
intros.
apply typ_common;[exact I|intros i j isval].
rewrite intProd_eq.
apply rprod_intro_sn.
 red; red; intros.
 rewrite H0; reflexivity.

 red; intros.
 rewrite H0; reflexivity.

 apply sn_SU.

 destruct 1; split; unfold inX in *.
  rewrite int_cons_lift_eq.
  unfold CC_Real.inX in H|-*; rewrite ElNat_eq in H|-*.
  apply succ_typ; trivial.

  rewrite int_cons_lift_eq.
  unfold CC_Real.inX in H; rewrite ElNat_eq in H.
  rewrite RealNat_eq in H0|-*; trivial.
  2:apply succ_typ; trivial.
  apply cNAT_SU; trivial.
Qed.

Lemma typ_N : forall e, typ e Nat kind.
red; red; simpl; intros.
split;[discriminate|].
split; trivial.
exact Lc.sn_K.
Qed.

(** Recursor *)
Definition NatRec (f g n:term) : term.
(*begin show*)
left; exists (fun i => natrec (int f i) (fun n y => app (app (int g i) n) y) (int n i))
             (fun j => Lc.App2 (tm n j) (tm f j) (tm g j)).
(*end show*)
 do 2 red; intros.
 apply natrec_morph.
  rewrite H; reflexivity.
(**)
  do 2 red; intros.
  rewrite H; rewrite H0; rewrite H1; reflexivity.
(**)
  rewrite H; reflexivity.
(**)
 do 2 red; intros.
 rewrite H; auto.
(**)
 red; intros; simpl.
 repeat rewrite tm_liftable; trivial.
(**)
 red; intros; simpl.
 repeat rewrite tm_substitutive; trivial.
Defined.

(** Typing rule of the eliminator *)
Lemma typ_Nrect : forall e n f g P,
  typ e n Nat ->
  typ e f (App P Zero) ->
  typ e g (Prod Nat (Prod (App (lift 1 P) (Ref 0))
              (App (lift 2 P) (App Succ (Ref 1))))) ->
  typ e (NatRec f g n) (App P n).
intros.
apply typ_common; [exact I|intros].
red in H; specialize H with (1:=H2).
red in H0; specialize H0 with (1:=H2).
red in H1; specialize H1 with (1:=H2).
apply in_int_not_kind in H;[|discriminate].
apply in_int_not_kind in H0;[|discriminate].
apply in_int_not_kind in H1;[|discriminate].
destruct H as (tyn, satn).
destruct H0 as (tyf, satf).
destruct H1 as (tyg, satg).
simpl.
set (gg := fun n y => app (app (int g i) n) y).
assert (ggm : morph2 gg).
 unfold gg; do 3 red; intros.
 rewrite H;rewrite H0; reflexivity.
red in tyn, tyf, tyg.
rewrite ElNat_eq in tyn.
rewrite RealNat_eq in satn; trivial.
rewrite El_int_prod in tyg.
rewrite Real_int_prod in satg; trivial.
assert (tygg :forall k h : set,
   k ∈ N -> h ∈ El (app (int P i) k) -> gg k h ∈ El (app (int P i) (succ k))).
 intros.
 rewrite <- ElNat_eq with (i:=i) in H.
 apply cc_prod_elim with (2:=H) in tyg.
 rewrite El_int_prod in tyg.
 assert (tyh : h ∈ El (app (int (lift 1 P) (V.cons k i)) k)).
  rewrite int_cons_lift_eq; trivial.
 apply cc_prod_elim with (2:=tyh) in tyg.
 simpl in tyg.
 rewrite int_lift_eq in tyg.
 rewrite CC_Real.beta_eq in tyg; auto with *.
 red; intros; apply succ_morph; trivial.
assert (NRtyp : forall n, n ∈ N ->
  natrec (int f i) gg n ∈ El (app (int P i) n)).
 intros.
 apply natrec_typ with (P:=fun x => El (app (int P i) x)); trivial.
 do 2 red; intros.
 rewrite <- H0; reflexivity.
apply and_split; intros.
 red; apply NRtyp; trivial.

 red in H.
 apply fNAT_def with (P:=fun k => Real (app (int P i) k) (natrec (int f i) gg k))
    (A:=cNAT).
  rewrite cNAT_eq in satn; trivial.

  do 2 red; intros.
  rewrite H0; reflexivity.

  rewrite natrec_0; trivial.

  apply depSAT_intro.
   apply sat_sn in satg; trivial.
  intros m tym.
  apply prodSAT_intro'; intros mt satm.
  apply prodSAT_intro'; intros v satv.
  rewrite natrec_S; trivial.
  apply piSAT0_elim' in satg; red in satg.
  rewrite <- RealNat_eq with (i:=i) in satm; trivial.
  rewrite <- ElNat_eq with (i:=i) in tym.
  specialize satg with (1:=tym) (2:=satm).
  rewrite Real_int_prod in satg.
   apply piSAT0_elim' in satg; red in satg.
   specialize satg with (x:=natrec (int f i) gg m) (u:=v).
   simpl in satg.
   rewrite int_cons_lift_eq in satg.
   rewrite ElNat_eq in tym.
   specialize satg with (1:=NRtyp _ tym) (2:=satv).
   rewrite int_lift_eq in satg.
   rewrite CC_Real.beta_eq in satg; auto with *.
    red; intros; apply succ_morph; trivial.

    red; rewrite El_def; auto.
    apply cc_prod_elim with (2:=tym) in tyg.
    rewrite El_int_prod in tyg; trivial.
Qed.

(** beta-reduction on the realizers simulates the reduction of
    the eliminator *)

Lemma red_iota_simulated_0 : forall f g,
  red_term (NatRec f g Zero) f.
red; simpl; intros.
unfold ZE.
eapply t_trans;[apply Lc.redp_app_l;apply t_step;apply Lc.red1_beta; reflexivity|].
unfold Lc.subst; simpl.
apply t_step.
apply Lc.red1_beta.
unfold Lc.subst; rewrite Lc.simpl_subst; trivial.
rewrite Lc.lift0; trivial.
Qed.

Lemma red_iota_simulated_S : forall f g n,
  red_term (NatRec f g (App Succ n)) (App (App g n) (NatRec f g n)).
red; simpl; intros.
unfold SU.
eapply t_trans.
 do 2 apply Lc.redp_app_l.
 apply t_step; apply Lc.red1_beta; reflexivity.
unfold Lc.subst; simpl.
eapply  t_trans.
 apply Lc.redp_app_l.
 apply t_step; apply Lc.red1_beta; reflexivity.
unfold Lc.subst; simpl.
rewrite Lc.simpl_subst; auto.
apply t_step; apply Lc.red1_beta.
unfold Lc.subst; simpl.
rewrite Lc.simpl_subst; auto.
rewrite Lc.simpl_subst; auto.
do 3 rewrite Lc.lift0.
reflexivity.
Qed.
Print Assumptions typ_Nrect.


Welcome to Coq 8.4pl4 (August 2014)

Coq < Section Math014.

Coq < Require Import Arith.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]

Coq < Load CpdtTactics.

Coq < Goal forall x, x * 2 = x + x.
1 subgoal

  ============================
   forall x : nat, x * 2 = x + x

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined

Coq <