(** This is an implementation of finite integers using Z with constraints.
  Warning: proof terms may blow up during computation.
 *)

From Coq Require Import NArith ZArith.
From Coq Require Import Bool Eqdep_dec.
From Coq Require Import Lia.

From EVM Require Import Logic2 Arith2.

Local Open Scope Z_scope.

Definition bound_int (lower upper: Z) := { a: Z | ((lower <=? a) && (a <? upper)) = true}.

Definition Z_of_bound_int {lower upper: Z} (n: bound_int lower upper): Z := proj1_sig n.

Lemma bound_int_irrel {lower upper: Z} {n m: bound_int lower upper}
                      (E: Z_of_bound_int n = Z_of_bound_int m):
  n = m.
Proof.
destruct n as (n, okN). destruct m as (m, okM).
cbn in E. subst m. f_equal.
apply eq_proofs_unicity. decide equality.
Qed.

Lemma bound_int_lower {lower upper: Z} (b: bound_int lower upper):
  lower <= Z_of_bound_int b.
Proof.
unfold Z_of_bound_int.
rewrite<- Z.leb_le.
exact (proj1 (andb_prop _ _ (proj2_sig b))).
Qed.

Lemma bound_int_upper {lower upper: Z} (b: bound_int lower upper):
  Z_of_bound_int b < upper.
Proof.
unfold Z_of_bound_int.
rewrite<- Z.ltb_lt.
exact (proj2 (andb_prop _ _ (proj2_sig b))).
Qed.

Definition bound_int_both {lower upper: Z} (b: bound_int lower upper):
  lower <= Z_of_bound_int b < upper
:= conj (bound_int_lower b) (bound_int_upper b).

Definition bound_int_of_Z {lower upper: Z} (n: Z) (LB: lower <= n) (UB: n < upper)
: bound_int lower upper
:= exist _ n (andb_true_intro (conj (proj2 (Z.leb_le _ _) LB)
                                    (proj2 (Z.ltb_lt _ _) UB))).

Definition bound_int_of_Z_conj {lower upper: Z} (n: Z) (B: lower <= n < upper)
: bound_int lower upper
:= bound_int_of_Z n (proj1 B) (proj2 B).

Definition bound_int_of_N_bound_by_Z {upper: Z} (n: N) (UB: (Z.of_N n < upper)%Z)
: bound_int 0%Z upper
:= bound_int_of_Z (Z.of_N n) (N2Z.is_nonneg n) UB.

Definition bound_int_of_N_bound_by_N {upper: N} (n: N) (UB: (n < upper)%N)
: bound_int 0%Z (Z.of_N upper)
:= bound_int_of_Z (Z.of_N n) (N2Z.is_nonneg n) (proj1 (N2Z.inj_lt _ _) UB).

(****************************************************************************)

Definition bound_N upper := { a: N | (a <? upper)%N = true}.
Definition uint' (width: N) := bound_N (2 ^ width).
Definition N_of_uint' {width: N} (n: uint' width) := proj1_sig n.
Definition Z_of_uint' {width: N} (n: uint' width) := Z.of_N (N_of_uint' n).

Lemma uint'_bound {width: N} (n: uint' width):
  (N_of_uint' n < 2 ^ width)%N.
Proof.
assert (B := proj2_sig n).
unfold N_of_uint'.
apply N.ltb_lt.
apply B.
Qed.

Lemma N_of_Z_of_uint' {width: N} (n: uint' width):
  Z.to_N (Z_of_uint' n) = N_of_uint' n.
Proof.
unfold Z_of_uint'.
now rewrite N2Z.id.
Qed.

Definition uint (width: N) := bound_int 0 (2 ^ (Z.of_N width)).
Definition Z_of_uint {width: N} (n: uint width): Z := Z_of_bound_int n.
Definition N_of_uint {width: N} (n: uint width): N := Z.to_N (Z_of_uint n).

Lemma Z_of_N_of_uint {width: N} (n: uint width):
  Z.of_N (N_of_uint n) = Z_of_uint n.
Proof.
unfold N_of_uint.
rewrite Z2N.id. { trivial. }
apply (bound_int_lower n).
Qed.

(* This is an N bound. For a Z bound, use bound_int_upper. *)
Lemma uint_bound {width: N} (n: uint width):
  (N_of_uint n < 2 ^ width)%N.
Proof.
assert (B := bound_int_upper n).
apply N2Z.inj_lt.
rewrite Z_of_N_of_uint.
now rewrite N2Z.inj_pow.
Qed.

Lemma uint_mod_bound_N (width: N) (n: N):
  (n mod 2^width < 2^width)%N.
Proof.
apply N.mod_upper_bound.
apply N.pow_nonzero.
discriminate.
Qed.

Lemma uint_mod_bound_Z (width: N) (n: N):
  (Z.of_N (n mod 2^width) < 2 ^ Z.of_N width)%Z.
Proof.
replace 2%Z with (Z.of_N 2%N). 2:{ trivial. }
rewrite<- N2Z.inj_pow.
apply N2Z.inj_lt.
apply uint_mod_bound_N.
Qed.

Lemma uint_land_ones_bound_Z (width: N) (n: N):
  (Z.of_N (N.land n (N.ones width)) < 2 ^ Z.of_N width)%Z.
Proof.
rewrite N.land_ones.
apply uint_mod_bound_Z.
Qed.

Local Lemma uint_of_N_pow_spec {width: N} {n: N} (B: (n < 2 ^ width)%N):
  Z.of_N n < 2 ^ Z.of_N width.
Proof.
replace 2%Z with (Z.of_N 2%N). 2:{ trivial. }
rewrite<- N2Z.inj_pow.
apply N2Z.inj_lt.
exact B.
Qed.

Definition uint_of_N {width: N} (n: N) (B: (n < 2 ^ width)%N)
: uint width
:= bound_int_of_N_bound_by_Z n (uint_of_N_pow_spec B).

Definition uint_of_N_mod {width: N} (n: N)
: uint width
:= bound_int_of_N_bound_by_Z (N.land n (N.ones width)) (uint_land_ones_bound_Z width n).

Definition uint_0 (width: N)
: uint width
:= uint_of_N 0%N (N_0_lt_pow2 width).

Lemma uint_1_bound (width: positive):
  (1 < 2 ^ N.pos width)%N.
Proof.
replace 1%N with (2 ^ 0)%N by trivial.
apply N.pow_lt_mono_r; lia.
Qed.

Definition uint_1 (width: positive)
: uint (N.pos width)
:= uint_of_N 1%N (uint_1_bound width).

Lemma uint_highest_bound (width: N):
  (N.ones width < 2 ^ width)%N.
Proof.
rewrite N.ones_equiv.
assert (V := N_0_lt_pow2 width).
lia.
Qed.

Definition uint_highest (width: N)
: uint width
:= uint_of_N (N.ones width) (uint_highest_bound width).

Local Lemma uint_of_Z_mod_bound (width: N) (n: Z):
  0 <= n mod 2 ^ Z.of_N width < 2 ^ Z.of_N width.
Proof.
replace 2%Z with (Z.of_N 2%N). 2:{ trivial. }
rewrite<- N2Z.inj_pow.
apply (Z.mod_pos_bound _ _ (proj1 (N2Z.inj_lt _ _) (N_0_lt_pow2 width))).
Qed.

Local Lemma uint_of_Z_land_ones_bound (width: N) (n: Z):
  0 <= Z.land n (Z.ones (Z.of_N width)) < 2 ^ Z.of_N width.
Proof.
rewrite Z.land_ones.
apply uint_of_Z_mod_bound.
apply N2Z.is_nonneg.
Qed.

Definition uint_of_Z_mod (width: N) (n: Z)
: uint width
:= bound_int_of_Z_conj (Z.land n (Z.ones (Z.of_N width)))
                       (uint_of_Z_land_ones_bound width n).

Lemma Z_of_uint_of_Z_mod (width: N) (n: Z):
  Z_of_uint (uint_of_Z_mod width n) = n mod 2 ^ Z.of_N width.
Proof.
cbn. rewrite Z.land_ones. { trivial. } apply N2Z.is_nonneg.
Qed.

(*********************************************************************************)

Lemma N_land_bound {width: N} {n m: N}
                   (BN: (n < 2 ^ width)%N)
                   (BM: (m < 2 ^ width)%N):
  (N.land n m < 2 ^ width)%N.
Proof.
assert (CN := N.eq_0_gt_0_cases n).
assert (CM := N.eq_0_gt_0_cases m).
assert (CA := N.eq_0_gt_0_cases (N.land n m)).
case CN; intro ZN. { now subst. }
case CM; intro ZM. { subst. now rewrite N.land_comm. }
case CA; intro ZA. { rewrite ZA. apply N_0_lt_pow2. }
rewrite N.log2_lt_pow2 in *; try assumption.
apply (N.le_lt_trans _ _ _ (N.log2_land _ _)).
apply N.min_lt_iff.
right. assumption.
Qed.

Definition uint_and {width: N} (a b: uint width)
: uint width
:= uint_of_N (N.land (N_of_uint a) (N_of_uint b))
             (N_land_bound (uint_bound a) (uint_bound b)).

Lemma N_lor_bound {width: N} {n m: N}
                  (BN: (n < 2 ^ width)%N)
                  (BM: (m < 2 ^ width)%N):
  (N.lor n m < 2 ^ width)%N.
Proof.
assert (CN := N.eq_0_gt_0_cases n).
assert (CM := N.eq_0_gt_0_cases m).
assert (CA := N.eq_0_gt_0_cases (N.lor n m)).
case CN; intro ZN. { now subst. }
case CM; intro ZM. { subst. now rewrite N.lor_comm. }
case CA; intro ZA. { rewrite ZA. apply N_0_lt_pow2. }
rewrite N.log2_lt_pow2 in *; try assumption.
rewrite N.log2_lor.
apply N.max_lub_lt; assumption.
Qed.

Definition uint_or {width: N} (a b: uint width)
: uint width
:= uint_of_N (N.lor (N_of_uint a) (N_of_uint b))
             (N_lor_bound (uint_bound a) (uint_bound b)).

Lemma N_lxor_bound {width: N} {n m: N}
                   (BN: (n < 2 ^ width)%N)
                   (BM: (m < 2 ^ width)%N):
  (N.lxor n m < 2 ^ width)%N.
Proof.
assert (CN := N.eq_0_gt_0_cases n).
assert (CM := N.eq_0_gt_0_cases m).
assert (CA := N.eq_0_gt_0_cases (N.lxor n m)).
case CN; intro ZN. { now subst. }
case CM; intro ZM. { subst. now rewrite N.lxor_comm. }
case CA; intro ZA. { rewrite ZA. apply N_0_lt_pow2. }
rewrite N.log2_lt_pow2 in *; try assumption.
apply (N.le_lt_trans _ _ _ (N.log2_lxor _ _)).
apply N.max_lub_lt; assumption.
Qed.

Definition uint_xor {width: N} (a b: uint width)
: uint width
:= uint_of_N (N.lxor (N_of_uint a) (N_of_uint b))
             (N_lxor_bound (uint_bound a) (uint_bound b)).

Lemma N_lnot_bound {width: N} {n: N}
                   (BN: (n < 2 ^ width)%N):
  (N.lnot n width < 2 ^ width)%N.
Proof.
unfold N.lnot. apply N_lxor_bound. { assumption. }
rewrite N.ones_equiv.
apply N.lt_pred_l.
apply N.pow_nonzero.
discriminate.
Qed.

Definition uint_not {width: N} (a: uint width)
: uint width
:= uint_of_N (N.lnot (N_of_uint a) width)
             (N_lnot_bound (uint_bound a)).

Example uint_not_example:
  N_of_uint (uint_not (uint_0 8)) = 255%N.
Proof. trivial. Qed.

Lemma N_shiftr_bound {width: N} {n: N}
                     (BN: (n < 2 ^ width)%N)
                     (shift: N):
  (N.shiftr n shift < 2 ^ width)%N.
Proof.
rewrite N.shiftr_div_pow2.
assert (CN := N.eq_0_gt_0_cases n).
assert (CS := N.eq_0_gt_0_cases shift).
case CN; intro. { subst. cbn. apply N_0_lt_pow2. }
case CS; intro. { subst. cbn. now rewrite N.div_1_r. }
enough (n / 2 ^ shift < n)%N. { now refine (N.lt_trans _ _ _ _ BN). }
apply N.div_lt. { assumption. }
apply N.pow_gt_1. { now rewrite<- N.ltb_lt. }
now apply N_ne_0_gt_0.
Qed.

Definition uint_shr_N {width: N} (a: uint width) (shift: N)
: uint width
:= uint_of_N (N.shiftr (N_of_uint a) shift)
             (N_shiftr_bound (uint_bound a) shift).

(*********************************************************************************)

Lemma N_div_bound {width: N} {n: N}
                  (BN: (n < 2 ^ width)%N)
                  (d: N):
  (n / d < 2 ^ width)%N.
Proof.
apply (N.le_lt_trans _ _ _ (N_div_le n d) BN).
Qed.

Definition uint_div_N {width: N} (a: uint width) (d: N)
: uint width
:= uint_of_N ((N_of_uint a) / d)%N
             (N_div_bound (uint_bound a) d).

(*********************************************************************************)

Definition uint_add {width: N} (a b: uint width)
: uint width
:= uint_of_Z_mod width (Z_of_uint a + Z_of_uint b)%Z.

Definition uint_sub {width: N} (a b: uint width)
: uint width
:= uint_of_Z_mod width (Z_of_uint a - Z_of_uint b)%Z. (* may not be via N since N.sub truncates *)

Definition uint_mul {width: N} (a b: uint width)
: uint width
:= uint_of_Z_mod width (Z_of_uint a * Z_of_uint b)%Z.

Definition uint_shl_N {width: N} (a: uint width) (shift: N)
: uint width
:= uint_of_N_mod (N.shiftl (N_of_uint a) shift).

(* This version is mathematically correct but too slow to compute;
   see uint_pow below.
 *)
Definition uint_pow_ideal {width: N} (a b: uint width)
: uint width
:= uint_of_Z_mod width (Z_of_uint a ^ Z_of_uint b)%Z.

(*********************************************************************************)

Lemma uint_0_pow_0_is_1 {width: positive}:
  uint_pow_ideal (uint_0 (Npos width)) (uint_0 (Npos width)) = uint_1 width.
Proof.
unfold uint_pow_ideal. apply bound_int_irrel. cbn.
assert(T: 1 < 2 ^ (Z.pos width)).
{
  replace 1 with (2 ^ 0)%Z by trivial.
  apply Z.pow_lt_mono_r; lia.
}
assert(P: 0 < Z.ones (Z.pos width)).
{ rewrite Z.ones_equiv. lia. }
remember (Z.ones (Z.pos width)) as ones.
destruct ones; try lia.
assert (Odd: Z.odd (Z.pos p) = true).
{
  rewrite Heqones.
  rewrite Z.ones_equiv.
  rewrite Z.odd_pred.
  rewrite Z.even_pow.
  apply Z.even_2.
  trivial.
}
now destruct p.
Qed.

Fixpoint uint_pow_pos {width: N} (a: uint width) (b: positive)
: uint width
:= match b with
   | 1%positive => a
   | p~0%positive => let x := uint_pow_pos a p in uint_mul x x
   | p~1%positive => let x := uint_pow_pos a p in uint_mul a (uint_mul x x)
   end.

Lemma uint_pow_pos_ok {width: N} (a: uint width) (b: positive):
  uint_pow_pos a b = uint_of_Z_mod width (Z_of_uint a ^ Z.pos b)%Z.
Proof.
induction b.
{
  replace (Z.pos b~1) with (2 * Z.pos b + 1) by trivial.
  rewrite Z.pow_add_r; try lia.
  rewrite Z.pow_1_r.
  rewrite Z.pow_twice_r.
  cbn. unfold uint_mul.
  apply bound_int_irrel.
  cbn. repeat rewrite Z.land_ones; try apply N2Z.is_nonneg.
  rewrite IHb.
  repeat rewrite Z_of_uint_of_Z_mod.
  clear IHb. rewrite Z.pow_pos_fold.
  remember (Z_of_uint a) as n. remember (Z.pos b) as p. remember (2 ^ Z.of_N width) as m.
  rewrite<- Zmult_mod.
  rewrite<- Z.mul_assoc.
  rewrite<- Z.mul_comm.
  rewrite Zmult_mod_idemp_l.
  now rewrite<- Z.mul_assoc.
}
{
  replace (Z.pos b~0) with (2 * Z.pos b) by trivial.
  rewrite Z.pow_twice_r.
  cbn. unfold uint_mul.
  apply bound_int_irrel.
  cbn. repeat rewrite Z.land_ones; try apply N2Z.is_nonneg.
  rewrite IHb.
  repeat rewrite Z_of_uint_of_Z_mod.
  clear IHb. rewrite Z.pow_pos_fold.
  remember (Z_of_uint a) as n. remember (Z.pos b) as p. remember (2 ^ Z.of_N width) as m.
  now rewrite<- Zmult_mod.
}
cbn. apply bound_int_irrel.
cbn. rewrite Z.land_ones; try apply N2Z.is_nonneg.
rewrite Z.mul_1_r.
rewrite Z.mod_small. { trivial. }
exact (bound_int_both a).
Qed.

Definition uint_pow_N {width: positive} (a: uint (Npos width)) (b: N)
: uint (Npos width)
:= match b with
   | 0%N => uint_1 width
   | Npos p => uint_pow_pos a p
   end.

Lemma uint_pow_N_ok {width: positive} (a: uint (Npos width)) (b: N):
  uint_pow_N a b = uint_of_Z_mod (Npos width) (Z_of_uint a ^ Z.of_N b)%Z.
Proof.
destruct b. 2:{ apply uint_pow_pos_ok. }
cbn. apply bound_int_irrel.
replace Z_of_bound_int with (@Z_of_uint (N.pos width)) by trivial.
rewrite Z_of_uint_of_Z_mod.
cbn.
rewrite Z.pow_pos_fold.
symmetry. apply Z.mod_small.
split. { now rewrite<- Z.leb_le. }
replace 1 with (2 ^ 0) by trivial.
apply Z.pow_lt_mono_r; lia.
Qed.

Definition uint_pow {width: positive} (a b: uint (Npos width))
: uint (Npos width)
:= uint_pow_N a (N_of_uint b).

Lemma uint_pow_ok {width: positive} (a b: uint (Npos width)):
  uint_pow a b = uint_pow_ideal a b.
Proof.
unfold uint_pow. rewrite uint_pow_N_ok.
unfold uint_pow_ideal.
now rewrite Z_of_N_of_uint.
Qed.


Set Implicit Arguments.
Require Import LibTactics LibOption LibList LibProd LibLogic LibReflect LibNat LibEpsilon.
Require Import List.
Export ListNotations.
Require Export LibVar.
Generalizable Variable A.

Module Export VariablePath : VariablesType.

Check nat.

Inductive IPE: Type :=
 | zero_pe
 | one_pe.

Inductive PE : Type :=
 | i_pe      : IPE -> PE
 | u_pe      : PE.

Definition Path : Type := list PE.

(* I'm making a new Var for this path and it ain't going to work. *)
Definition varpath := prod nat Path.
Definition var     := varpath.
Check (0, [i_pe zero_pe]) : var.

Lemma var_inhab : Inhab var.
Proof. apply (prove_Inhab (0, [i_pe zero_pe])). Qed.

Function beq_ipe (i i' : IPE) : bool :=
  match i, i' with
    | zero_pe, zero_pe => true
    | one_pe, one_pe => true
    | _, _ => false
  end.

Function beq_pe (p p' : PE) : bool :=
  match p, p' with
    | i_pe x, i_pe y => beq_ipe x y
    | u_pe, u_pe => true
    | _, _ => false
  end.

Function beq_path (p q : Path) : bool :=
  match p, q with
    | [], [] => true
    | x :: p', y :: q' => andb (beq_pe x y) (beq_path p' q')
    | _  , _ => false
  end.

Function varpath_compare (u u' : varpath) : bool :=
  match u, u' with
    | (x,p), (x', p') => If x = x' then beq_path p p' else false
  end.

Instance varpath_comparable : Comparable nat.
Proof.
  apply (comparable_varpath_compare varpath_compare).
  induction x; destruct y; simpl.
  auto*.
  auto_false.
  auto_false.
  asserts_rewrite ((S x = S y) = (x = y)).
    extens. iff; omega.
  auto*.
Qed.

Lemma varpath_comp : Comparable varpath.
Proof. apply varpath_comparable. Qed.

Instance var_comparable : Comparable var := var_comp.

Definition vars := fset var.

Definition var_gen_list (l : list nat) :=
  1 + fold_right plus O l.

Lemma var_gen_list_spec : forall n l,
  n \in from_list l -> n < var_gen_list l.
Proof.
  unfold var_gen_list. induction l; introv I.
  rewrite from_list_nil in I. false (in_empty_elim I).
  rewrite from_list_cons in I. rew_list.
   rewrite in_union in I. destruct I as [H|H].
     rewrite in_singleton in H. subst. nat_math.
     specializes IHl H. nat_math.
Qed.

Definition var_gen (E : vars) : var :=
  var_gen_list (epsilon (fun l => E = from_list l)).

Lemma var_gen_spec : forall E, (var_gen E) \notin E.
Proof.
  intros. unfold var_gen. spec_epsilon as l.
  applys fset_finite. rewrite Hl. introv H.
  forwards M: var_gen_list_spec H. nat_math.
Qed.

Lemma var_fresh : forall (L : vars), { x : var | x \notin L }.
Proof. intros L. exists (var_gen L). apply var_gen_spec. Qed.

End VariablePath.


Require Import Grammar.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Import ListNotations.

Inductive nonterminal : Type :=
| NT : string -> nonterminal.

Inductive terminal : Type :=
| Te : string -> terminal.

Definition production : Type := terminal * option nonterminal.
Definition grammar : Type := (nonterminal -> list (production)).
Definition token : Type := string.

Definition a : string := "a".
Definition b : string := "b".
Definition c : string := "c".

Definition simple_grammar : grammar :=
  fun s =>
    match s with
    | NT "S" => [(Te "a", Some (NT "B"))]
    | NT "B" => [(Te "a", Some (NT "B"));(Te "b", None)]
    | _ => []
    end.

Fixpoint check_rec (str : list string) (g : grammar) (p : production) : bool :=
  match str, p with
  | _ :: _ :: _, (Te _, None) => false
  | f :: r, (Te x, None) => if string_dec x f then true else false
  | f :: r, (Te x, Some (NT n)) =>
    if string_dec x f
    then (fold_left orb (map (check_rec r g) (g (NT n))) false)
    else false
  | _, _ => false
  end.

Definition check (str : list string) (g : grammar) (start : nonterminal) : bool :=
  fold_left orb (map (check_rec str g) (g start)) false.

Compute check [a] simple_grammar (NT "S").
Compute check [a;b;b] simple_grammar (NT "S").
Compute check [a;b;b;b] simple_grammar (NT "S").
Compute check [a;b;b;b;b] simple_grammar (NT "S").
Compute check [a;a;b;c] simple_grammar (NT "S").
Compute check [a;a;b;c;c] simple_grammar (NT "S").
Compute check [a;a;b] simple_grammar (NT "S").
Compute check [a;a;c] simple_grammar (NT "S").

Inductive tree : Type :=
  | Leaf : terminal -> tree
  | Node : nonterminal -> list tree -> tree.

Fixpoint left_branching (t : tree) : Prop :=
  match t with
  | Leaf _ => True
  | Node _ ((Leaf _) :: tr) => fold_left and (map left_branching tr) True
  | Node _ ((Node _ _) :: tr) => False
  | Node _ [] => False
  end.

Definition option_left_branching (t : option tree) : Prop :=
  match t with
  | Some t => left_branching t
  | None => False
  end.

Lemma lbleaf : left_branching (Leaf (Te "a")) = True.
Proof. unfold left_branching. reflexivity. Qed.

Fixpoint first_true (str : list string) (g : grammar) (ps : list production) : option production :=
  match ps with
  | p :: t => if check_rec str g p then Some p else first_true str g t
  | [] => None
  end.

Fixpoint parse (str : list string) (g : grammar) (n : nonterminal) : option tree :=
  match first_true str g (g n) with
  | Some p =>
    match str, p with
    | f :: r, (t, None) => Some (Node n [Leaf t])
    | f :: r, (t, Some n') =>
      match parse r g n' with
      | None => None
      | Some t' => Some (Node n ([Leaf t; t']))
      end
    | _, _ => None
    end
  | None => None
  end.

Compute parse [a;a;b] simple_grammar (NT "S").
Compute parse [a;b] simple_grammar (NT "S").
Compute parse [a] simple_grammar (NT "S").
Compute parse [a;a;b;b] simple_grammar (NT "S").

Definition parse_exists (str : list string) (g : grammar) (s : nonterminal) : Prop :=
  match parse str g s with
  | Some _ => True
  | None => False
  end.

Lemma check_equal_to_parse : forall (g : grammar) (str : list string) (s : nonterminal),
    check str g s = true -> parse_exists str g s.
Admitted.

Lemma parse_left_branching : forall (g : grammar) (str : list string) (s : nonterminal),
    parse_exists str g s -> option_left_branching (parse str g s).
Admitted.


From Coq Require Import
     List
     Classes.RelationClasses
     Morphisms
     Arith.Arith
     Lia
     Logic.FinFun
     Program.Basics
.

From ExtLib Require Import
     Structures.Monads
     .

From ITree Require Import
     ITree.

From Equations Require Import
     Equations.

Import ListNotations.
Import Relation_Definitions.

Import Monads.
Import MonadNotation.

Local Open Scope monad_scope.
Local Open Scope list_scope.

Inductive bij : nat -> Set :=
| bij_id : forall (n:nat), bij n
| bij_swap : forall (n:nat), bij (2 + n)
| bij_comp : forall (n:nat) (s1 s2 : bij n), bij n
| bij_plus : forall (n m:nat) (s1 : bij n) (s2 : bij m),
    bij (n + m)
.
Arguments bij_comp {_}.
Arguments bij_plus {_ _}.

Equations Derive NoConfusion for nat.
Equations Derive NoConfusion NoConfusionHom for list.
Equations Derive Signature NoConfusion for bij.

Notation "'ι' [ n ]" := (bij_id n).
Notation "'σ' [ n ]" := (bij_swap n).
(* NOTE: [⨾] is a "fatsemi" not a regular semi and it is written as \fcmp *)
Notation "b1 ⨾ b2" := (bij_comp b1 b2) (at level 55, right associativity).
Infix  "⊎" := (bij_plus) (at level 60, right associativity).

Notation "f >>> g" := (compose g f) (at level 55, right associativity).

Definition size_bij (n:nat) (s:bij n) : nat :=
  match s with
  | bij_id n => n
  | bij_swap n => 2 + n
  | @bij_comp n _ _ => n
  | @bij_plus n m _ _ => n + m
  end.

Fixpoint bijection {n : nat} (b : bij n) : nat -> nat :=
  match b with
  | bij_id _ => fun (i:nat) => i
  | bij_swap _ => fun (i:nat) =>
                   match i with
                   | 0 => 1
                   | 1 => 0
                   | n => n
                   end
  | bij_comp b1 b2 =>
      fun i => (bijection b2 (bijection b1 i))
  | @bij_plus n _ b1 b2 =>
      fun i =>
        if Nat.ltb i n
        then (bijection b1) i
        else n + (bijection b2) (i - n)
  end.

Notation "⟦ b ⟧" := (@bijection _ b).

Definition bij_shift (n:nat) {m:nat} (b : bij m) : bij (n + m) :=
 ι[n] ⊎ b.

Notation "b >> [ n ]" := (bij_shift n b) (at level 35).

(* Assuming [f i < n] makes this into a PER, not an equivalence *)
Definition nat_fun_eq n (f : nat -> nat) (g : nat -> nat) : Prop :=
  forall i, i < n -> f i = g i /\ f i < n.

Infix "≈[ n ]" := (nat_fun_eq n) (at level 70, no associativity).

Definition bij_equiv (n:nat) : bij n -> bij n -> Prop :=
  fun b1 b2 => ⟦b1⟧ ≈[n] ⟦b2⟧.

Infix "≡[ n ]" := (bij_equiv n) (at level 70, no associativity).

(*
#[global] Instance refl_nat_fun_eq : forall n, Reflexive (nat_fun_eq n).
Proof.
  intros. repeat red.
  intros. reflexivity.
Qed.
*)

#[global] Instance sym_nat_fun_eq : forall n, Symmetric (nat_fun_eq n).
Proof.
  intros. repeat red.
  intros. edestruct (H i) as [HE HLT]; auto.
  rewrite <- HE. auto.
Qed.

#[global] Instance trans_nat_fun_eq : forall n, Transitive (nat_fun_eq n).
Proof.
  intros. repeat red.
  intros.
  destruct (H i) as [HE1 HLT1]; auto.
  destruct (H0 i) as [HE2 HLT2]; auto.
  rewrite <- HE2, <- HE1. auto.
Qed.

#[global]
Instance Proper_comp: forall {n}, Proper (nat_fun_eq n ==> nat_fun_eq n ==> (nat_fun_eq n)) (compose).
Proof.
  repeat red.
  intros.
  unfold compose.
  destruct (H0 i) as [HE2 HLT2]; auto.
  destruct (H (x0 i)) as [HE1 HLT1]; auto.
  rewrite <- HE2, <- HE1; auto.
Qed.

#[global]
Instance Proper_comp': forall {n}, Proper (nat_fun_eq n ==> nat_fun_eq n ==> flip (nat_fun_eq n)) (compose).
Proof.
  repeat red.
  intros.
  unfold compose.
  destruct (H0 i) as [HE2 HLT2]; auto.
  destruct (H (x0 i)) as [HE1 HLT1]; auto.
  rewrite <- HE2, <- HE1; auto.
Qed.

#[global] Instance bij_equiv_Symmetric : forall n, Symmetric (bij_equiv n).
Proof.
  intros.
  do 2 red. intros. symmetry. apply H.
Qed.

#[global] Instance bij_equiv_Transitive : forall n, Transitive (bij_equiv n).
Proof.
  intros.
  do 2 red. intros. eapply transitivity; eauto.
Qed.

#[global] Instance bijection_bij_equiv_Proper: forall n, Proper (bij_equiv n ==> nat_fun_eq n) (@bijection n).
Proof.
  do 2 red.
  intros. apply H.
Qed.

Lemma bij_bounds : forall (n:nat) (b : bij n),
  forall i (LT : i < n), ⟦b⟧ i < n.
Proof.
  intros n b.
  induction b; intros; auto.
  - destruct i; simpl.
    + lia.
    + destruct i; lia.
  - simpl; auto.
  - simpl.
    destruct (Nat.ltb_spec0 i n).
    + apply IHb1 in l. lia.
    + assert (i - n < m). { lia.  }
      specialize (IHb2 (i -n)). apply IHb2 in H.
      lia.
Qed.

#[global] Instance bij_equiv_Reflexive : forall n, Reflexive (bij_equiv n).
Proof.
  do 2 red. intros.
  split. reflexivity. apply bij_bounds. assumption.
Qed.

Lemma bij_comp_assoc : forall (n:nat) (b1 b2 b3 : bij n),
    ⟦b1 ⨾ (b2 ⨾ b3) ⟧ ≈[n] ⟦(b1 ⨾ b2) ⨾ b3 ⟧.
Proof.
  intros.
  repeat red. intros.
  split.
  reflexivity.
  simpl. repeat apply bij_bounds. assumption.
Qed.

Lemma bij_comp_comp : forall (n:nat) (b1 b2 : bij n),
    ⟦b1 ⨾ b2⟧  ≈[n]  ⟦b1⟧ >>> ⟦b2⟧.
Proof.
  repeat red; intros.
  split. reflexivity.
  repeat apply bij_bounds. assumption.
Qed.

Lemma bij_comp_eq : forall n (b1 b2 : bij n) (x:nat),
    ⟦b2⟧ (⟦b1⟧ x) = ⟦b1 ⨾ b2⟧ x.
Proof.
  reflexivity.
Qed.

Lemma bij_comp_eq_parts1 : forall n (b11 b12 : bij n) (b21 b22 : bij n),
    ⟦b11⟧ ≈[n] ⟦b12⟧ ->
    ⟦b21⟧ ≈[n] ⟦b22⟧ ->
    ⟦b11⟧ >>> ⟦b21⟧ ≈[n] ⟦b12⟧ >>> ⟦b22⟧.
Proof.
  intros.
  apply Proper_comp; auto.
Qed.

Lemma bij_comp_eq_parts : forall n (b11 b12 : bij n) (b21 b22 : bij n),
    ⟦b11⟧ ≈[n] ⟦b12⟧ ->
    ⟦b21⟧ ≈[n] ⟦b22⟧ ->
    ⟦b11 ⨾ b21⟧ ≈[n] ⟦b12 ⨾ b22⟧.
Proof.
  intros.
  simpl.
  intros x LT.
  split.
  destruct (H x) as [HE HLT]; auto.
  rewrite HE.
  destruct (H0 (⟦b12⟧ x)) as [HE2 HLT2]; auto.
  apply bij_bounds. assumption.
  repeat apply bij_bounds. assumption.
Qed.

#[global] Instance bij_comp_bij_equiv_Proper : forall (n:nat), Proper (bij_equiv n ==> bij_equiv n ==> bij_equiv n) (@bij_comp n).
Proof.
  intros.
  do 3 red. intros.
  apply bij_comp_eq_parts; auto.
Qed.

Lemma bij_id_ident : forall (n i : nat),
    ⟦ι[n]⟧ i = i.
Proof.
  reflexivity.
Qed.

Lemma bij_comp_plus : forall n m (b11 b12 : bij n) (b21 b22 : bij m),
    ⟦(b11 ⊎ b21) ⨾ (b12 ⊎ b22)⟧ ≈[n + m] ⟦(b11 ⨾ b12) ⊎ (b21 ⨾ b22)⟧.
Proof.
  intros.
  repeat red.
  intros.
  simpl.
  destruct (Nat.ltb_spec0 i n).
  - assert (⟦ b11 ⟧ i < n) by (apply bij_bounds; auto).
    destruct (Nat.ltb_spec0 (⟦ b11 ⟧ i) n).
    + split. reflexivity. specialize (bij_bounds _ b12 _ H0). intros. lia.
    + contradiction.
  - destruct (Nat.ltb_spec0 (n + ⟦ b21 ⟧ (i - n)) n).
    + lia.
    + assert ((n + ⟦ b21 ⟧ (i - n) - n) = ⟦ b21 ⟧ (i - n)). { lia. }
      rewrite H0.
      split. reflexivity. assert (⟦ b22 ⟧ (⟦ b21 ⟧ (i - n)) < m). { repeat apply bij_bounds. lia. }
      lia.
Qed.

Lemma bij_comp_plus_equiv : forall n m (b11 b12 : bij n) (b21 b22 : bij m),
    (b11 ⊎ b21) ⨾ (b12 ⊎ b22) ≡[n + m] (b11 ⨾ b12) ⊎ (b21 ⨾ b22).
Proof.
  intros. apply bij_comp_plus.
Qed.

Lemma bij_zero_plus : forall n (b: bij n), ⟦ι[0] ⊎ b⟧ ≈[n] ⟦b⟧.
Proof.
  intros.
  simpl.
  red. intros.
  rewrite Nat.sub_0_r.
  split. reflexivity.  apply bij_bounds. assumption.
Qed.

Lemma bij_zero_plus_equiv : forall n (b: bij n), ι[0] ⊎ b ≡[n] b.
Proof.
  intros. apply bij_zero_plus.
Qed.

Lemma bij_plus_zero : forall n (b: bij n), ⟦b ⊎ ι[0]⟧ ≈[n] ⟦b⟧.
Proof.
  simpl.
  red. intros.
  assert (i <? n = true). { apply Nat.ltb_lt. assumption. }
  rewrite H0.
  split. reflexivity. apply bij_bounds. assumption.
Qed.

(* Annoyingly, can't state this one because the type doesn' align *)
(*
Lemma bij_plus_zero_equiv : forall n (b: bij n), (b ⊎ ι[0]) ≡[n+0] b.
*)

Lemma bij_swap_swap : forall n, ⟦σ[n] ⨾ σ[n]⟧ ≈[2+n] ⟦ι[2+n]⟧.
Proof.
  simpl. red.
  intros n i LT.
  destruct i.
  - split; [reflexivity | lia].
  - destruct i. split; [reflexivity | lia].
    split; [reflexivity | lia].
Qed.

Lemma bij_swap_swap_equiv : forall n, σ[n] ⨾ σ[n] ≡[2+n] ι[2+n].
Proof.
  apply bij_swap_swap.
Qed.

Lemma bij_id_plus_id : forall n m, ⟦ι[n] ⊎ ι[m]⟧ ≈[n+m] ⟦ι[n+m]⟧.
Proof.
  simpl. red.
  intros.
  specialize (Nat.ltb_lt i n) as LT.
  destruct (i <? n).
  split; [reflexivity | lia].
  lia.
Qed.

Lemma bij_id_plus_id_equiv : forall n m, (ι[n] ⊎ ι[m]) ≡[n+m] ι[n+m].
Proof.
  apply bij_id_plus_id.
Qed.

Lemma bij_plus_eq_parts : forall n m (b11 b12 : bij n) (b21 b22 : bij m),
    ⟦b11⟧ ≈[n] ⟦b12⟧ ->
    ⟦b21⟧ ≈[m] ⟦b22⟧ ->
    ⟦b11 ⊎ b21⟧ ≈[n + m] ⟦b12 ⊎ b22⟧.
Proof.
  intros.
  simpl.
  red. intros.
  destruct (Nat.ltb_spec0 i n).
  - destruct (H i) as [HI HL].
    assumption. split. apply HI. lia.
  - assert (i - n < m) by lia.
    destruct (H0 (i-n)) as [HI HL].
    assumption.
    split.
    rewrite HI; auto.
    lia.
Qed.

#[global] Instance bij_plus_equiv_Proper : forall n m, Proper (bij_equiv n ==> bij_equiv m ==> bij_equiv (n+m)) (@bij_plus n m).
Proof.
  do 3 red.
  intros.
  apply bij_plus_eq_parts; auto.
Qed.

Lemma bij_id_comp_left : forall n (b : bij n),
    ⟦ ι[n] ⨾ b ⟧ ≈[n] ⟦ b ⟧.
Proof.
  intros.
  simpl.
  red.
  intros.
  split. reflexivity. apply bij_bounds. auto.
Qed.

Lemma bij_id_comp_right : forall n (b : bij n),
    ⟦ b ⨾ ι[n] ⟧ ≈[n] ⟦ b ⟧.
Proof.
  intros.
  simpl.
  red.
  intros.
  split. reflexivity. apply bij_bounds. auto.
Qed.

Lemma bij_id_comp_left_equiv : forall n (b : bij n),
    ι[n] ⨾ b  ≡[n] b.
Proof.
  apply bij_id_comp_left.
Qed.

Lemma bij_id_comp_right_equiv : forall n (b : bij n),
    b ⨾ ι[n]  ≡[n] b.
Proof.
  apply bij_id_comp_right.
Qed.

Equations invert {n : nat} (b : bij n) : bij n :=
| ι[n] => ι[n]
| σ[n] => σ[n]
| b1 ⨾ b2 => (invert b2) ⨾ (invert b1)
| b1 ⊎ b2 => (invert b1) ⊎ (invert b2)
.

#[global]
 Transparent invert.

Lemma bij_invert : forall n (b : bij n),
    ⟦b ⨾ invert b⟧ ≈[n] ⟦ι[n]⟧.
Proof.
  intros n b.
  induction b.
  - split. reflexivity. simpl. assumption.
  - red. intros.
    destruct i; split; try reflexivity. simpl. lia.
    destruct i; split; try reflexivity. simpl.  destruct i; lia.
  - replace (invert (b1 ⨾ b2)) with ((invert b2) ⨾ (invert b1)) by reflexivity.
    rewrite <- bij_comp_assoc.
    rewrite bij_comp_comp.
    rewrite bij_comp_assoc.
    rewrite bij_comp_comp.
    rewrite IHb2.
    rewrite <- bij_comp_comp.
    rewrite bij_id_comp_left_equiv.
    apply IHb1.
  - replace (invert (b1 ⊎ b2)) with (invert b1 ⊎ invert b2) by reflexivity.
    rewrite bij_comp_plus.
    rewrite <- bij_id_plus_id.
    rewrite bij_plus_eq_parts; eauto.
    apply bij_equiv_Reflexive.
Qed.

Lemma bij_invert_equiv : forall n (b : bij n),
    b ⨾ invert b ≡[n] ι[n].
Proof.
  apply bij_invert.
Qed.

Lemma invert_bij : forall n (b : bij n),
    ⟦invert b ⨾ b⟧ ≈[n] ⟦ι[n]⟧.
Proof.
  intros n b.
  induction b.
  - split. reflexivity. assumption.
  - red. intros.
    destruct i; split; try reflexivity. simpl.  lia.
    destruct i; split; try reflexivity. simpl. destruct i; lia.
  - replace (invert (b1 ⨾ b2)) with ((invert b2) ⨾ (invert b1)) by reflexivity.
    rewrite <- bij_comp_assoc.
    rewrite bij_comp_comp.
    rewrite bij_comp_assoc.
    rewrite bij_comp_comp.
    rewrite IHb1.
    rewrite <- bij_comp_comp.
    rewrite bij_id_comp_left_equiv.
    apply IHb2.
  - replace (invert (b1 ⊎ b2)) with (invert b1 ⊎ invert b2) by reflexivity.
    rewrite bij_comp_plus.
    rewrite <- bij_id_plus_id.
    rewrite bij_plus_eq_parts; eauto.
    apply bij_equiv_Reflexive.
Qed.

Lemma invert_bij_equiv : forall n (b : bij n),
    invert b ⨾ b ≡[n] ι[n].
Proof.
  apply invert_bij.
Qed.

Lemma invert_invert : forall n (b : bij n),
    ⟦ invert (invert b) ⟧ ≈[n] ⟦b⟧.
Proof.
  intros.
  induction b.
  - simpl. split. reflexivity. assumption.
  - simpl.  split. reflexivity. destruct i. lia. destruct i; lia.
  - simpl.
    red. intros.
    destruct (IHb1 i) as [IH1 LT1]; auto.
    destruct (IHb2 (⟦b1⟧ i)) as [IH2 LT2]; auto.
    apply bij_bounds. assumption.
    split.
    rewrite IH1. rewrite IH2. reflexivity.
    rewrite IH1. apply LT2.
  - simpl.
    red.
    intros.
    destruct (Nat.ltb_spec i n).
    split. apply IHb1. assumption. destruct (IHb1 i) as [_ HL]. assumption.
    lia.
    destruct (IHb2 (i -n)) as [HB HL]. lia.
    split.
    rewrite HB. reflexivity.
    lia.
Qed.

Lemma invert_invert_equiv : forall n (b : bij n),
    invert (invert b) ≡[n] b.
Proof.
  apply invert_invert.
Qed.

Lemma coerce_bij : forall n m, m = n -> bij n -> bij m.
Proof.
  intros. subst. assumption.
Defined.

Lemma coerce_bijection : forall n m (EQ:m = n) (b:bij n) (i:nat),
    ⟦b⟧ i = ⟦coerce_bij n m EQ b⟧ i.
Proof.
  intros. subst. split.
Qed.

Lemma bij_inv : forall n (b : bij n),
  forall (i:nat) (LT : i < n), exists j, (j < n) /\ ⟦b⟧j = i.
Proof.
  intros.
  exists (⟦invert b⟧ i).
  split.
  - apply bij_bounds. assumption.
  - rewrite bij_comp_eq. specialize (invert_bij _ b i LT). intros H.
    destruct H as [H1 H2].
    rewrite H1. reflexivity.
Qed.

Inductive Permutation {A:Type} : list A -> list A -> Type :=
| perm_id: forall l, Permutation l l
| perm_swap x y l : Permutation ([y] ++ [x] ++ l) ([x] ++ [y] ++ l)
| perm_comp l1 l2 l3 :
    Permutation l1 l2 -> Permutation l2 l3 -> Permutation l1 l3
| perm_plus l11 l12 l21 l22 :
  Permutation l11 l21 -> Permutation l12 l22 -> Permutation (l11 ++ l12) (l21 ++ l22).

Lemma Permutation_length : forall {A} (l1 l2 : list A) (HP : Permutation l1 l2),
    length l1 = length l2.
Proof.
  intros.
  induction HP; simpl; auto.
  rewrite IHHP1. rewrite IHHP2. reflexivity.
  do 2 rewrite app_length. rewrite IHHP1. rewrite IHHP2.
  reflexivity.
Qed.

(* Not very useful *)
Definition Permutation_eq {A:Type} {l11 l12 l21 l22 : list A}
           (p1 : Permutation l11 l12)
           (p2 : Permutation l21 l22) :=
  l11 = l21 /\ l12 = l22.

Infix "≡" := (Permutation_eq) (at level 80).

Lemma Permutation_symmetric :
  forall {A:Type} (xs ys: list A)
    (H:Permutation xs ys), Permutation ys xs.
Proof.
  intros.
  induction H.
  - apply perm_id.
  - apply perm_swap.
  - eapply perm_comp; eauto.
  - apply perm_plus; eauto.
Qed.

(** For working with setoid rewriting? *)
(** Propositional characterization *)
Definition Permutation_rel {A:Type} : relation (list A) :=
  fun l1 l2 => exists (p:Permutation l1 l2), True.

Lemma Permutation_rel_Reflexive : forall {A:Type}, Reflexive (@Permutation_rel A).
Proof.
  repeat red.
  intros. exists (perm_id x). auto.
Qed.

Lemma Permutation_rel_Symmetric : forall {A:Type}, Symmetric (@Permutation_rel A).
Proof.
  repeat red.
  intros. destruct H as [P _].
  exists (Permutation_symmetric x y P).  auto.
Qed.

Lemma Permutation_rel_Transitive : forall {A:Type}, Transitive (@Permutation_rel A).
Proof.
  repeat red.
  intros. destruct H as [P _]. destruct H0 as [Q _].
  exists (perm_comp x y z P Q).  auto.
Qed.

#[global]
Existing Instance Permutation_rel_Reflexive.

#[global]
Existing Instance Permutation_rel_Symmetric.

#[global]
Existing Instance Permutation_rel_Transitive.

Section PERM.

(** Thorsten Altenkirch's Characterization of Permutations - a more "canonical" form
    that is built on insertion sort.
 *)

  Context {A : Type}.

Inductive Add : A -> list A -> list A -> Type :=
| zero : forall a aS, Add a aS (a :: aS)
| succ : forall a b aS bs, Add a aS bs -> Add a (b :: aS) (b :: bs).

Arguments zero {_ _}.
Arguments succ {_ _ _ _}.

Inductive Perm : list A -> list A -> Type :=
| perm_nil  : Perm [] []
| perm_cons : forall a aS bs cs, Perm aS cs -> Add a cs bs -> Perm (a :: aS) bs.

Arguments perm_cons {_ _ _ _}.

Fixpoint reflPerm (xs:list A) : Perm xs xs :=
  match xs with
  | [] => perm_nil
  | x::xs => perm_cons (reflPerm xs) zero
  end.

Lemma addLem : forall {a b aS bs cs} (P : Add a aS bs) (Q : Add b bs cs),
    {ds : list A & Add b aS ds * (Add a ds cs)}%type.
Proof.
  intros.
  revert b cs Q.
  induction P; intros.
  - inversion Q; subst.
    + exists (b :: aS). split.  apply zero. apply succ. apply zero.
    + eexists. split. apply X. apply zero.
  - inversion Q; subst.
    + eexists. split. apply zero. apply succ. apply succ. apply P.
    + specialize (IHP b0 bs0 X).
      destruct IHP as [ds [HP HQ]].
      eexists (b::ds). split. eapply succ. assumption. eapply succ. assumption.
Qed.

Lemma transLem : forall {a bs cs bs'} (P : Perm bs cs) (H : Add a bs' bs),
    { cs' : list A & Perm bs' cs' * Add a cs' cs}%type.
Proof.
  intros.
  revert a bs' H.
  induction P; intros.
  - inversion H.
  - remember (a :: aS) as xs.
    revert a aS P a0 IHP Heqxs.
    inversion H; intros; inversion Heqxs; subst; clear Heqxs.
    + exists cs. split; auto.
    + destruct (IHP _ _ X) as [cs' [P' Q']].
      destruct (addLem Q' a2) as [ds [Y Z]].
      exists ds. split. eapply perm_cons; eauto. apply Z.
Qed.

Lemma transPerm : forall {aS bs cs} (P : Perm aS bs) (Q : Perm bs cs),
    Perm aS cs.
Proof.
  intros aS bs cs P Q.
  revert cs Q.
  induction P; intros.
  - assumption.
  - destruct (transLem Q a0) as [cs' [Q' Y]].
    apply (perm_cons (IHP cs' Q')).
    assumption.
Qed.

Lemma symLem : forall {a aS bs cs} (P: Perm cs aS) (X : Add a cs bs),
    Perm bs (a :: aS).
Proof.
  intros a aS bs cs P X.
  revert aS P.
  induction X; intros.
  - eapply perm_cons. apply P. apply zero.
  - inversion P; subst.
    eapply perm_cons.
    apply (IHX _ X0). apply succ. assumption.
Qed.

Lemma symPerm : forall {aS bs} (P : Perm aS bs),
    Perm bs aS.
Proof.
  intros.
  induction P.
  - apply perm_nil.
  - eapply symLem. apply IHP. assumption.
Qed.

Lemma remPerm : forall {a aS bs} (P : Perm (a::aS) (a::bs)),
    Perm aS bs.
Proof.
  intros.
  inversion P; subst.
  inversion X0; subst.
  - assumption.
  - eapply transPerm. apply X.
    eapply perm_cons. apply reflPerm.
    assumption.
Qed.

Lemma swapPerm : forall {a b aS}, (Perm (a::b::aS) (b::a::aS)).
Proof.
  intros.
  eapply perm_cons.
  2: { eapply succ. eapply zero. }
  apply reflPerm.
Qed.

Lemma appendAdd : forall a aS bs cs,
    Add a aS bs -> Add a (aS ++ cs) (bs ++ cs).
Proof.
  intros a aS bs cs H.
  revert cs.
  induction H; intros.
  - apply zero.
  - simpl. apply succ. apply IHAdd.
Qed.

Lemma appendPerm : forall aS bs cs ds,
    Perm aS bs -> Perm cs ds -> Perm (aS++cs) (bs++ds).
Proof.
  intros aS bs cs ds H.
  revert cs ds.
  induction H; intros.
  - simpl. assumption.
  - simpl. eapply perm_cons.
    apply IHPerm. apply X.
    apply appendAdd.
    assumption.
Qed.

Lemma Permutation_Perm : forall xs ys, Permutation xs ys -> Perm xs ys.
Proof.
  intros.
  induction X.
  - apply reflPerm.
  - apply swapPerm.
  - eapply transPerm. apply IHX1. apply IHX2.
  - apply appendPerm; auto.
Qed.

Lemma Permutation_AddLem : forall a cs bs,
    Add a cs bs -> Permutation (a::cs) bs.
Proof.
  intros.
  induction X.
  - apply perm_id.
  - eapply perm_comp.
    eapply perm_swap.
    replace (b :: bs) with ([b] ++ bs) by reflexivity.
    apply perm_plus. apply perm_id.
    apply IHX.
Qed.

Lemma Permutation_Add : forall a aS bs cs,
    Permutation aS cs -> Add a cs bs -> Permutation (a :: aS) bs.
Proof.
  intros.
  revert a bs X0.
  induction X; intros.
  - apply Permutation_AddLem. assumption.
  - apply Permutation_AddLem in X0.
    replace (a :: [y] ++ [x] ++ l) with ([a] ++ (y::x::l)) by reflexivity.
    eapply perm_comp. eapply perm_plus. apply perm_id.
    eapply perm_swap. assumption.
  - apply IHX2 in X0.
    eapply perm_comp. eapply Permutation_symmetric.
    replace (a :: l1) with ([a] ++ l1) by reflexivity.
    apply perm_plus. apply perm_id.
    apply Permutation_symmetric. apply X1.
    apply X0.
  - apply Permutation_AddLem in X0.
    eapply perm_comp.
    2: { apply X0. }
    replace (a :: l11 ++ l12) with ([a] ++ (l11 ++ l12)) by reflexivity.
    replace (a :: l21 ++ l22) with ([a] ++ (l21 ++ l22)) by reflexivity.
    apply perm_plus. apply perm_id.
    apply perm_plus; assumption.
Qed.

Lemma Perm_Permutation : forall aS bs,
    Perm aS bs -> Permutation aS bs.
Proof.
  intros.
  induction X.
  - apply perm_id.
  - eapply Permutation_Add; eauto.
Qed.

End PERM.

Set Equations Transparent.

Equations perm_bij {A:Type} (l1 l2 : list A) (p : Permutation l1 l2) : bij (length l1) :=
  perm_bij ?(l) ?(l) (perm_id l)

  := bij_id (length l)
  ;

  perm_bij ?([y] ++ [x] ++ l) ?([x] ++ [y] ++ l) (perm_swap x y l)

  := bij_swap (length l)
  ;

  perm_bij ?(l1) ?(l3) (perm_comp l1 l2 l3 q1 q2) with
    perm_bij l1 l2 q1, perm_bij l2 l3 q2 => {
    | b1, b2 => bij_comp b1 (coerce_bij _ _ (Permutation_length l1 l2 q1) b2)
    }

  ;
  perm_bij ?(l11 ++ l12) ?(l21 ++ l22) (perm_plus l11 l12 l21 l22 q1 q2)
    with
    perm_bij ?(l11) ?(l21) q1, perm_bij ?(l12) ?(l22) q2 => {
    | b1, b2 => (coerce_bij _ _ _ (bij_plus b1 b2))
    }
.
Next Obligation.
  apply app_length.
Defined.

Arguments perm_bij {_ _ _}.

Fixpoint split {A:Type} (n m:nat) (l:list A) (L : length l = n + m) :
  { l1 & { l2 & length l1 = n /\ length l2 = m /\ l1 ++ l2 = l} }.
  revert m l L.
  induction n.
  - intros.
    exists []. exists l. do 2 split. apply L. reflexivity.
  - intros.
    assert ((S n + m) = S (n + m)) by lia.
    rewrite H in L.
    destruct l.
    + inversion L.
    + simpl in L.
      inversion L.
      specialize (IHn m l H1).
      destruct IHn as [l1 [l2 [L1 [L2 EQ]]]].
      exists (a::l1). exists l2. split.
      * simpl. rewrite L1. reflexivity.
      * split.
        -- assumption.
        -- simpl. rewrite EQ. reflexivity.
Defined.

Lemma coerce_perm {A:Type} (l l1 l2 l3 : list A) (EQ: l1 ++ l2 = l) (p : Permutation (l1 ++ l2) l3) :
  Permutation l l3.
Proof.
  rewrite EQ in p. assumption.
Defined.

Fixpoint split_option {A:Type} (n:nat) (l:list A) : option (list A * list A) :=
  match n with
  | 0 => Some ([], l)
  | S n => match l with
          | x::xs =>
              '(ys, zs) <- split_option n xs ;;
              ret (x::ys, zs)
          | _ => None
          end
  end.

Lemma split_option_correct {A:Type} (n:nat) (l:list A) (xs ys : list A) :
  split_option n l = Some (xs, ys) -> l = xs ++ ys /\ length xs = n /\ length ys = (length l - n).
Proof.
  revert l xs ys.
  induction n; intros.
  - simpl in H. inversion H. subst. split. reflexivity. split. reflexivity. lia.
  - simpl in H.
    destruct l eqn:HEQ; inversion H.
    subst.
    destruct (split_option n l0) eqn:HEQ2.
    + destruct p. inversion H; subst.
      apply IHn in HEQ2.
      destruct  HEQ2 as [Hys [Hlen HEQ]].
      subst. split. reflexivity. split.  reflexivity. simpl. rewrite HEQ. reflexivity.
    + inversion H.
Qed.

Lemma split_option_total {A:Type} (n:nat) (l:list A) (HL:length l >= n) :
  exists xs ys, split_option n l = Some (xs, ys).
Proof.
  revert l HL.
  induction n; intros.
  - exists []. exists l. reflexivity.
  - destruct l.
    + inversion HL.
    + simpl in HL. assert (length l >= n) by lia.
      destruct (IHn l H) as [xs [ys HEQ]].
      exists (a::xs). exists ys. simpl.
      rewrite HEQ. reflexivity.
Qed.

Fixpoint bij_list {A:Type} {n : nat} (b : bij n) : list A -> option (list A) :=
  match b with
  | bij_id n =>
      fun l => if Nat.eqb (length l) n then ret l else None

  | bij_swap n =>
      fun l =>
        match l with
        | y::x::l => if Nat.eqb (length l) n then ret (x::y::l) else None
        | _ => None
        end

  | bij_comp b1 b2 =>
      fun l =>
        l1 <- bij_list b1 l;;
        bij_list b2 l1

  | @bij_plus n _ b1 b2 =>
      fun l =>
        '(xs, ys) <- split_option n l ;;
        xs' <- bij_list b1 xs ;;
        ys' <- bij_list b2 ys ;;
        ret (xs' ++ ys')
  end.

Lemma bij_list_len1 {A:Type} {n:nat} (b : bij n) (l1 l2 : list A) :
  bij_list b l1 = Some l2 -> n = length l1.
Proof.
  revert l1 l2.
  induction b; intros.
  - simpl in H. destruct (Nat.eqb_spec (length l1) n).
    + auto. + inversion H.
  - simpl in H. destruct l1; inversion H. destruct l1; inversion H.
    destruct (Nat.eqb_spec (length l1) n). simpl. rewrite e. reflexivity.
    inversion H.
  - simpl in H.
    destruct (bij_list b1 l1) eqn:HEQ.
    apply IHb1 in HEQ. assumption.
    inversion H.
  - simpl in H.
    destruct (split_option n l1) eqn:HEQ.
    destruct p.
    apply split_option_correct in HEQ.
    destruct HEQ as [Hl [Hlen _]].
    subst.
    destruct (bij_list b1 l) eqn:HEQ.
    destruct (bij_list b2 l0) eqn:HEQ2.
    apply IHb2 in HEQ2.
    subst. rewrite app_length. reflexivity.
    inversion H.
    inversion H.
    inversion H.
Qed.

Lemma bij_list_len2 {A:Type} {n:nat} (b : bij n) (l1 l2 : list A) :
  bij_list b l1 = Some l2 -> n = length l2.
Proof.
  revert l1 l2.
  induction b; intros.
  - simpl in H. destruct (Nat.eqb_spec (length l1) n); inversion H.
    subst. reflexivity.
  - simpl in H. destruct l1; inversion H. destruct l1; inversion H.
    destruct (Nat.eqb_spec (length l1) n).
    inversion H. subst. reflexivity.
    inversion H.
  - simpl in H.
    destruct (bij_list b1 l1) eqn:HEQ.
    apply IHb1 in HEQ.
    eapply IHb2. eauto. inversion H.
  - simpl in H.
    destruct (split_option n l1) eqn:HEQ.
    destruct p.
    apply split_option_correct in HEQ.
    destruct HEQ as [Hl [Hlen _]].
    subst.
    destruct (bij_list b1 l) eqn:HEQ.
    destruct (bij_list b2 l0) eqn:HEQ2.
    apply IHb2 in HEQ2.
    inversion H. subst.
    rewrite app_length.
    apply IHb1 in HEQ. rewrite HEQ. reflexivity.
    inversion H.
    inversion H.
    inversion H.
Qed.

Lemma bij_list_total {A:Type} (n:nat) (b : bij n) (l1 : list A) (EQ:length l1 = n) :
  exists l2, bij_list b l1 = Some l2.
Proof.
  revert l1 EQ.
  induction b; intros.
  - exists l1. simpl.
    destruct (Nat.eqb_spec (length l1) n).
    + reflexivity.
    + contradiction.
  - destruct l1; try inversion EQ.
    destruct l1; try inversion EQ.
    exists (a0::a::l1). simpl.
    destruct (Nat.eqb (length l1) (length l1)) eqn:HEQ.
    + reflexivity.
    + rewrite Nat.eqb_refl in HEQ. inversion HEQ.
  - specialize (IHb1 l1 EQ).
    destruct IHb1 as [l2 HL2].
    assert (length l2 = n). { symmetry. eapply bij_list_len2. apply HL2. }
    specialize (IHb2 l2 H).
    destruct IHb2 as [l3 HL3].
    exists l3. simpl.
    rewrite HL2. assumption.
  - assert (length l1 >= n) by lia.
    apply split_option_total in H.
    destruct H as [xs [ys HEQ]].
    specialize (split_option_correct _ _ _ _ HEQ). intros.
    destruct H as [HEQ2 [HLX HLY]].
    assert (length ys = m) by lia.
    destruct (IHb1 xs HLX) as [xs2 HB1].
    destruct (IHb2 ys H) as [ys2 HB2].
    exists (xs2 ++ ys2). simpl.
    rewrite HEQ. rewrite HB1. rewrite HB2. reflexivity.
Qed.

Lemma bij_list_correct {A:Type} (n:nat) (b : bij n) (l1 l2 : list A) (EQ:n = length l1)
  (H: bij_list b l1 = Some l2) :
  exists p : Permutation l1 l2,
    ⟦perm_bij p⟧ ≈[n] ⟦b⟧.
Proof.
  revert l1 l2 EQ H.
 induction b; intros.
  - simpl in H.
    assert (Nat.eqb (length l1) n = true). { subst. apply Nat.eqb_refl. }
    rewrite H0 in H.
    inversion H. subst.
    exists (perm_id l2). simpl. split. reflexivity. assumption.
  - simpl in H.
    destruct l1; inversion H.
    destruct l1; inversion H.
    simpl in EQ. inversion EQ.
    assert (Nat.eqb (length l1) n = true). { subst. apply Nat.eqb_refl. }
    rewrite H0 in H. inversion H.
    exists (perm_swap a0 a l1). split. reflexivity. simpl. destruct i. lia. destruct i; lia.
  - simpl in H.
    destruct (bij_list b1 l1) eqn:HL1.
    specialize (IHb1 l1 l EQ HL1).
    destruct IHb1 as [p1 EQP1].
    assert (n = length l2). { eapply bij_list_len2. apply H. }
    assert (n = length l). { eapply bij_list_len2. apply HL1. }
    specialize (IHb2 l l2 H1 H).
    destruct IHb2 as [p2 EQP2].
    exists (perm_comp l1 l l2 p1 p2). simpl.
    subst.
    eapply bij_comp_eq_parts1.
    assumption.
    eapply transitivity.
    2: { apply EQP2. }
    symmetry. split. apply coerce_bijection. rewrite H1. apply bij_bounds. lia.
    inversion H.
  - simpl in H.
    destruct (split_option n l1) eqn:HS; try inversion H.
    destruct p.
    destruct (bij_list b1 l) eqn:HL; try inversion H.
    destruct (bij_list b2 l0) eqn:HL0; try inversion H.
    apply split_option_correct in HS.
    destruct HS as [HL1 [Hlen1 HEQ1]].
    rewrite HL1 in EQ, HEQ1.
    rewrite app_length in EQ, HEQ1.
    assert (m  = length l0)  by lia.
    symmetry in Hlen1.
    specialize (IHb1 l l3 Hlen1 HL).
    destruct IHb1 as [p1 EQP1].
    specialize (IHb2 l0 l4 H0 HL0).
    destruct IHb2 as [p2 EQP2].
    rewrite HL1.
    exists (perm_plus l l0 l3 l4 p1 p2).
    simpl.
    unfold perm_bij_clause_4, perm_bij_clause_4_clause_1.
    eapply transitivity.
    1: { symmetry. split. apply coerce_bijection. assert (i < length l + length l0) by lia.
         simpl.
         destruct (Nat.ltb_spec i (length ?(l))).
         +  destruct (EQP1 i) as [HP HLT]. rewrite Hlen1. assumption. apply lt_plus_trans. assumption.
         + subst.
           destruct (EQP2 (i - length ?(l))). assert (?(l) = l) by reflexivity. rewrite H0.
           rewrite H0 in H6. lia.
           assert (length ?(l) = length l) by reflexivity.
           rewrite H7. rewrite H7 in H3.
           apply plus_lt_compat_l. assumption.
    }
    simpl.
    red. intros.
    destruct (Nat.ltb_spec i (length ?(l))).
    + destruct (EQP1 i). rewrite Hlen1. apply H5.
      destruct (Nat.ltb_spec i n).
      -- split. apply EQP1. assumption. apply lt_plus_trans. assumption.
      -- subst. assert (i < length l). apply H5. lia.
    +  destruct (Nat.ltb_spec i n).
       -- split. assert (n <= i). rewrite Hlen1. apply H5. lia.
          assert (n = length ?(l)). apply Hlen1. rewrite <- H7.
          apply plus_lt_compat_l. apply EQP2. lia.
       -- assert (n = length ?(l)). apply Hlen1. rewrite <- H7.
          split.
          ++ destruct (EQP2 (i -n)) as [HQ HL2].
             lia. rewrite <- HQ. reflexivity.
          ++ apply plus_lt_compat_l. rewrite H0. apply bij_bounds. lia.
Qed.

Lemma bij_list_fun {A:Type} (n:nat) (b : bij n) (l1 : list A) (EQ:n = length l1) :
  exists l2, exists p : Permutation l1 l2,
    ⟦perm_bij p⟧ ≈[n] ⟦b⟧.
Proof.
  destruct (bij_list_total n b l1) as [l2 H]. symmetry. assumption.
  exists l2. apply bij_list_correct; auto.
Qed.

Lemma bij_list_coerce : forall (A:Type) (n m : nat) (H: m = n) (b : bij n) (l:list A),
    bij_list b l = bij_list (coerce_bij n m H b) l.
Proof.
  intros a n m H b.
  revert m H.
  induction b; intros; subst; auto.
Qed.

Lemma app_length_inversion : forall (A:Type) (xs1 xs2 ys1 ys2 : list A),
    xs1 ++ xs2 = ys1 ++ ys2 -> length xs1 = length ys1 -> xs1 = ys1 /\ xs2 = ys2.
Proof.
  induction xs1; intros; simpl in *.
  - destruct ys1.  split.  reflexivity. apply H.
    inversion H0.
  - destruct ys1. inversion H0.
    simpl in *.
    inversion H0.
    inversion H. subst.
    specialize (IHxs1 xs2 ys1 ys2 H4 H2).
    destruct IHxs1. subst. split; auto.
Qed.

Lemma perm_bij_correct : forall (A:Type) (l1 l2 : list A) (p : Permutation l1 l2),
    bij_list (perm_bij p) l1 = Some l2.
Proof.
  intros.
  induction p; simpl.
  - rewrite Nat.eqb_refl. reflexivity.
  - rewrite Nat.eqb_refl. reflexivity.
  - rewrite IHp1. rewrite <- bij_list_coerce. assumption.
  - unfold perm_bij_clause_4, perm_bij_clause_4_clause_1.
    unfold perm_bij_obligations_obligation_1.
    rewrite <- bij_list_coerce.
    simpl.
    destruct (@split_option_total A (length (?(l11))) (l11 ++ l12)) as [l11' [l12' H]].
    { rewrite app_length. assert (length ?(l11) = length l11) by reflexivity. rewrite H. lia. }
    rewrite H.
    apply split_option_correct in H.
    destruct H as [HEq1 [HEq2 HEq3]].
    destruct (app_length_inversion _ l11 l12 l11' l12' HEq1). apply symmetry. apply HEq2.
    (* Annoying - the type indices don't line up so you can't just rewrite. *)
    subst. assert (l11' = ?(l11')) by reflexivity.
    assert (@bij_list A (@length A ?(l11')) (@perm_bij A ?(l11') ?(l21) p1) l11' = @Some (list A) l21).
    { eapply transitivity.  2: { apply IHp1. } reflexivity. }
    rewrite H0.
    assert (@bij_list A (@length A ?(l12')) (@perm_bij A ?(l12') ?(l22) p2) l12' = @Some (list A) l22).
    { eapply transitivity. 2: { apply IHp2. } reflexivity. }
    rewrite H1. reflexivity.
Qed.

(** Connection to bFun and Bijections *)

Lemma bFun_bij : forall (n:nat) (b : bij n), bFun n ⟦b⟧.
Proof.
  intros.
  unfold bFun.
  apply bij_bounds.
Defined.

Definition bij_to_fin (n:nat) (b : bij n) : (Fin.t n -> Fin.t n) :=
  Fin2Restrict.restrict (bFun_bij n b).

(** Missing from the library? *)
Lemma Bijective_Injective : forall {A B} (f : A -> B), (Bijective f) -> Injective f.
Proof.
  unfold Bijective, Injective.
  intros.
  destruct H as [g [H1 H2]].
  rewrite <- H1. rewrite <- H0. rewrite H1.
  reflexivity.
Qed.

Lemma Bijective_Surjective : forall {A B} (f : A -> B), (Bijective f) -> Surjective f.
Proof.
  unfold Bijective, Surjective.
  intros.
  destruct H as [g [H1 H2]].
  exists (g y). apply H2.
Qed.

(*
  0    1    2    3  ...   n

f(0) f(1) f(2) f(3) ... f(n)
  g    g    g    g       g

  0    1    2    3  ...   n

remove n  / f(n)

0 1 2 3 4

1 2 4 3 0

f 0 = 1
f 1 = 2
f 2 = 4
f 3 = 3
f 4 = 0

0 1 2 3

0 1 3 2

0 1 2 3 4

1 2 4 0 3

f(0) = 1
f(1) = 2
f(2) = 4
f(3) = 0
f(4) = 3

0 1 2 3

1 2 3 0

0 1 2 3

2 0 3 1

i -> if f (i) < f(n) then f(i)
     else (f i) - 1

*)

(* Remove 0 -> f(0) from the (bijection) f by
   0 1 2 ... ..... .. n

   0 1 2 ... (f 0)

*)
Definition thin (f:nat -> nat) (n:nat) (i:nat) : nat :=
  if (f (S i)) <? (f 0) then (f (S i)) else (f (S i)) - 1.

(* Extend bijection f with f 0 = j    (where j < S n)
*)
Definition thickx (f:nat -> nat) (n:nat) (j:nat) (i:nat) : nat :=
  if i =? 0 then j else
    if (f (i-1)) <? j then (f (i-1)) else 1 + (f (i-1)).

Example f_ex (n:nat) :=
  match n with
  | 0 => 1
  | 1 => 2
  | 2 => 4
  | 3 => 0
  | 4 => 3
  | _ => n
  end.

Example g_ex (n:nat) :=
  match n with
  | 0 => 1
  | 1 => 3
  | 2 => 0
  | 3 => 2
  | _ => n
  end.

Example h_ex (n:nat) :=
  match n with
  | 0 => 2
  | 1 => 0
  | 2 => 1
  | 3 => 2
  | _ => n
  end.

Lemma bFun_f_ex : bFun 5 f_ex.
Proof.
  unfold bFun.
  induction x; intros.
  - simpl.  lia.
  - destruct x; simpl. lia. destruct x. lia. destruct x. lia. destruct x. lia.
    assumption.
Qed.

(*
Eval compute in (thin f_ex 5 0).
Eval compute in (thin f_ex 5 1).
Eval compute in (thin f_ex 5 2).
Eval compute in (thin f_ex 5 3).

Eval compute in (thin h_ex 4 0).
Eval compute in (thin h_ex 4 1).
Eval compute in (thin h_ex 4 2).

Eval compute in (thickx (thin h_ex 4) 4 2 0).
Eval compute in (thickx (thin h_ex 4) 4 2 1).
Eval compute in (thickx (thin h_ex 4) 4 2 2).
Eval compute in (thickx (thin h_ex 4) 4 2 3).

Definition g := (thin f_ex 5).

Eval compute in (thickx f_ex 5 3 0).
Eval compute in (thickx f_ex 5 3 1).
Eval compute in (thickx f_ex 5 3 2).
Eval compute in (thickx f_ex 5 3 3).
Eval compute in (thickx f_ex 5 3 4).
Eval compute in (thickx f_ex 5 3 5).

Eval compute in (thickx g 4 1 0).
Eval compute in (thickx g 4 1 1).
Eval compute in (thickx g 4 1 2).
Eval compute in (thickx g 4 1 3).
Eval compute in (thickx g 4 1 4).
*)

Lemma thin_bfun : forall (f:nat -> nat) (n:nat) (HF:bFun (S n) f),
    bFun n (thin f n).
Proof.
  intros.
  unfold bFun in *.
  intros i LT.
  unfold thin.
  destruct (Nat.ltb_spec (f (S i)) (f 0)).
  - assert (f 0 < S n).
    apply HF. lia. lia.
  - assert (f (S i) < S n). apply HF. lia.
    lia.
Qed.

Lemma thickx_bfun : forall (f:nat -> nat) (n:nat) (j:nat) (HJ:j < S n) (HF:bFun n f),
    bFun (S n) (thickx f n j).
Proof.
  intros.
  unfold bFun in *.
  intros i LT.
  unfold thickx.
  destruct (Nat.eqb_spec i 0).
  - assumption.
  - destruct (Nat.ltb_spec (f (i-1)) j).
    + lia.
    + assert (f (i-1) < n). apply HF. lia. lia.
Qed.

(*
This is only true if f doesn't map to contain f 0
*)
Lemma thin_thickx : forall (f:nat -> nat) (n:nat) (HF:bFun (S n) f)
    (HUnique: forall k, f 0 <> f (S k)),
    thickx (thin f n) n (f 0) ≈[S n] f.
Proof.
  intros f n HF HUnique.
  intros i LT.
  assert (bFun n (thin f n)) as HB2. apply thin_bfun. assumption.
  unfold bFun in HB2.
  assert (f 0 < S n). apply HF. lia.
  split.
  - unfold thickx in *.
    destruct (Nat.eqb_spec i 0).
    + subst.  reflexivity.
    + simpl.
      unfold thin in *.
      assert (S (i-1) = i) by lia.
      rewrite H0.
      destruct (Nat.ltb_spec (f i) (f 0)).
      * assert (f i <? f 0 = true). apply Nat.ltb_lt; auto.
        rewrite H2. reflexivity.
      * inversion H1.
        ** destruct i.  contradiction. apply HUnique in H3. inversion H3.
        ** assert (f 0 < f i) by lia. simpl.
           destruct (Nat.ltb_spec (m - 0) (f 0)); lia.
  - unfold thickx in *.
    destruct (Nat.eqb_spec i 0).
    + subst.  assumption.
    + simpl.
      unfold thin in *.
      assert (S (i-1) = i) by lia.
      rewrite H0.
      destruct (Nat.ltb_spec (f i) (f 0)).
      * assert (f i <? f 0 = true). apply Nat.ltb_lt; auto.
        rewrite H2. lia.
      * inversion H1.
        ** destruct i. contradiction. apply HUnique in H3. inversion H3.
        ** assert (f 0 < f i) by lia. simpl.
           destruct (Nat.ltb_spec (m - 0) (f 0)). lia.
           unfold bFun in HF.
           replace (S (m - 0)) with (S m) by lia.
           rewrite H2. apply HF. lia.
Qed.

Fixpoint up_to (n:nat) : list nat :=
  match n with
  | 0 => []
  | S n => 0::(List.map S (up_to n))
  end.

(*
 Assuming j < n, yields a permutation that puts the element at index j
 at index 0, leaving the other elements in the same order.

 Example:  to_front 2 4 [0; 1; 2; 3] ==> [2 ; 0 ; 1; 3]

 [to_front_0] characterizes the idea that [j] will be at the front
 of the list.

 [to_front_lt] and [to_front_gt] say what happens to the indices
 permutated by the [to_front] operation.
*)
Program Fixpoint to_front (j:nat) (n:nat) : bij n :=
  match j with
  | 0 => bij_id n
  | S j =>
      match j with
      | 0 => match n with
            | 0 => bij_id 0
            | 1 => bij_id 1
            | S (S k) => (bij_swap k)
            end
      | S j' => match n with
               | 0 => bij_id 0
               | 1 => bij_id 1
               | S (S k) => bij_comp (bij_swap _) (coerce_bij _ (2 + k) _ (bij_plus (bij_id 1) (to_front j (S k))))
               end
      end
  end.

Example ex1 : nat -> nat := ⟦to_front 2 4⟧.
(* Eval compute in List.map ex1 (up_to 4). *)

(* These two helper functions re-compute the indices of the
   function [f] so that, once [f 0], has been pulled to the
   front, [adjust f] still gives the same results as [f].

   See the lemma [to_front_adjust] below.
*)
Definition adjust_index (v i :nat) :=
  if i <? v then i else i - 1.

Definition adjust (f : nat -> nat) :=
  fun i => adjust_index (f 0) (f (i+1)).

(* Builds a data structure that represents the bijection [f] by
   repeatedly pulling the next element to the head of the
   permutation.  The tricky part is that each use of [to_front]
   re-indexes the tail of the permutation, so we have to
   adjust the indices.
*)
Program Fixpoint build_bij (n:nat) (f : nat -> nat) : bij n :=
  match n with
  | 0 => bij_id 0
  | S m =>
      bij_comp (bij_plus (bij_id 1) (build_bij m (adjust f)))
               (to_front (f 0) (S m))
  end.

Definition run n b := List.map ⟦build_bij n b⟧ (up_to n).

Example hex (i:nat) : nat :=
  match i with
  | 0 => 2
  | 1 => 1
  | 2 => 3
  | 3 => 4
  | 4 => 0
  | _ => i
  end.

(*
Eval compute in run 5 hex.
*)

Lemma bFun_adjust : forall n (f:nat -> nat), bFun (S n) f -> bFun n (adjust f).
Proof.
  intros.
  unfold bFun in *.
  intros. unfold adjust, adjust_index.
  assert (f 0 < S n). apply H. lia.
  destruct (Nat.ltb_spec (f (x + 1)) (f 0)).
  - lia.
  - assert (f (x+1) < S n).
    apply H. lia. lia.
Qed.

Lemma to_front_0 : forall (j n : nat) (HLT: j < n),
    ⟦to_front j n⟧ 0 = j.
Proof.
  induction j; intros; simpl.
  - reflexivity.
  - destruct j.
    + destruct n.
      * lia.
      * destruct n.
        -- lia.
        -- simpl. reflexivity.
    + destruct n.
      * lia.
      * destruct n.
        -- lia.
        -- rewrite <- bij_comp_eq.
           rewrite <- coerce_bijection.
           destruct n.
           ** lia.
           ** assert (((@bijection (S (S (S n))) (bij_swap (S n)) O)) = 1). { reflexivity. }
              rewrite H.
              cbn -[to_front].
              rewrite IHj. reflexivity. lia.
Qed.

Lemma to_front_lt : forall j n k
  (HJ: j < S n)
  (HLT: k < j),
    ⟦to_front j (S n)⟧ (S k) = k.
Proof.
  induction j; intros.
  - lia.
  - simpl.
    destruct j.
    + destruct n.
      * lia.
      * assert (k = 0) by lia.
        subst. simpl. reflexivity.
    + destruct n.
      * lia.
      * rewrite <- bij_comp_eq.
        rewrite <- coerce_bijection.
        cbn -[to_front].
        destruct k.
        ** simpl. reflexivity.
        ** cbn -[to_front].
           rewrite IHj; auto. lia. lia.
Qed.

Lemma to_front_gt :
  forall j n k
    (HJ: j < S n)
    (HK: k < S n)
    (HLT: j < k),
    ⟦to_front j (S n)⟧ k = k.
Proof.
  induction j; intros.
  - reflexivity.
  - simpl.
    destruct j.
    + destruct n.
      * lia.
      * simpl.
        destruct k. lia. destruct k. lia. reflexivity.
    + destruct n.
      * lia.
      * rewrite <- bij_comp_eq.
        rewrite <- coerce_bijection.
        cbn -[to_front].
        destruct k.
        ** lia.
        ** destruct k.
        -- lia.
        -- cbn -[to_front].
           rewrite IHj; lia.
Qed.

Lemma to_front_adjust :
  forall (i n:nat) (f : nat -> nat)
    (HB : bFun (S n) f)
    (HBij: bInjective (S n) f)
    (HLI : i < S n)
    (HNZ : 1 <= i),
    ⟦to_front (f 0) (S n)⟧ (S ((adjust f) (i-1))) = f i.
Proof.
  intros.
  unfold adjust, adjust_index.
  assert (i - 1 + 1 = i) by lia.
  rewrite H.
  destruct (Nat.ltb_spec (f i) (f 0)).
  - apply to_front_lt; auto. apply HB. lia.
  - destruct (Nat.eqb_spec (f 0) (f i)).
    { assert (0 = i). apply HBij; lia. lia. }
    assert (f 0 < f i) by lia.
    assert (S (f i - 1) = f i) by lia.
    rewrite H2.
    apply to_front_gt.
    + apply HB. lia.
    + apply HB. assumption.
    + destruct (Nat.eqb_spec (f 0) (f i)).
      * unfold bInjective in HBij.
        apply HBij in e; lia.
      * lia.
Qed.

Lemma bInjective_lt :
  forall n m (f : nat -> nat)
    (HBij : bInjective n f)
    (HLT: m < n),
    bInjective m f.
Proof.
  intros.
  unfold bInjective in *.
  intros.
  apply HBij; lia.
Qed.

Lemma bInjective_adjust :
  forall (n:nat) (f : nat -> nat)
    (HB: bFun (S n) f)
    (HBij : bInjective (S n) f),
    bInjective n (adjust f).
Proof.
  intros.
  unfold bInjective in *.
  intros.
  unfold adjust, adjust_index in H1.
  unfold bFun in HB.
  destruct (Nat.ltb_spec (f (x+1)) (f 0)).
  - destruct (Nat.ltb_spec (f (y+1)) (f 0)).
    + assert (x + 1 = y + 1).
      apply HBij; lia. lia.
    + destruct (Nat.eqb_spec (f 0) (f (y + 1))).
      apply HBij in e; lia.
      lia.
  - destruct (Nat.ltb_spec (f (y+1)) (f 0)).
    + destruct (Nat.eqb_spec (f 0) (f (x + 1))).
      apply HBij in e; lia.
      lia.
    + destruct (Nat.eqb_spec (f 0) (f (x + 1))).
      apply HBij in e; lia.
      destruct (Nat.eqb_spec (f 0) (f (y + 1))).
      apply HBij in e; lia.
      assert (x + 1 = y + 1).
      apply HBij; lia.
      lia.
Qed.

Lemma build_bij_correct :
  forall (n:nat) (f : nat -> nat)
    (HB: bFun n f)
    (HBij: bInjective n f),
    ⟦build_bij n f⟧ ≈[n] f.
Proof.
  induction n; intros.
  - simpl. intros i HI. lia.
  - simpl.
    red. intros. split.
    + destruct (Nat.ltb_spec i 1).
      * assert (i = 0) by lia. subst.
        apply to_front_0. apply HB. assumption.
      * assert (i - 1 < n) by lia.
        specialize (IHn (adjust f) (bFun_adjust n f HB) (bInjective_adjust n f HB HBij) (i-1) H1).
        destruct IHn.
        rewrite H2.
        apply to_front_adjust; auto.
    + destruct (Nat.ltb_spec i 1).
      * assert (i = 0) by lia. subst.
        rewrite to_front_0. apply HB. assumption. apply HB. assumption.
      * assert (i - 1 < n) by lia.
        specialize (IHn (adjust f) (bFun_adjust n f HB) (bInjective_adjust n f HB HBij) (i-1) H1).
        destruct IHn.
        rewrite H2.
        rewrite to_front_adjust; auto.
Qed.

Lemma bInjecive_comp : forall n (f : nat -> nat) (g : nat -> nat),
    bFun n f -> bInjective n f -> bInjective n g -> bInjective n (f >>> g).
Proof.
  intros.
  unfold bInjective in *.
  intros. unfold compose in H4.
  apply H1 in H4. apply H0; auto. apply H; auto. apply H; auto.
Qed.

Lemma bInjective_bij : forall n (b : bij n), bInjective n ⟦b⟧.
Proof.
  intros n b.
  induction b.
  - simpl. red; intros; tauto.
  - simpl. red; intros.
    destruct x; destruct y; auto.
    destruct y; auto. inversion H1.
    destruct x; auto. inversion H1.
    destruct x. destruct y. auto. inversion H1. destruct y. inversion H1. auto.
  - simpl. apply bInjecive_comp. apply bFun_bij. apply IHb1.
    apply IHb2.
  - simpl.
    red.  intros.
    destruct (Nat.ltb_spec x n).
    + destruct (Nat.ltb_spec y n).
      * apply IHb1; auto.
      * assert (bFun n ⟦b1⟧). apply bFun_bij.
        assert (⟦b1⟧ x < n). apply H4. assumption. lia.
    + destruct (Nat.ltb_spec y n).
      * assert (bFun n ⟦b1⟧). apply bFun_bij.
        assert (⟦b1⟧ (y) < n). apply H4.   lia.  lia.
      * assert (⟦ b2 ⟧ (x - n) = ⟦ b2 ⟧ (y - n)) by lia.
        apply IHb2 in H4; lia.
Qed.

Lemma build_bij_bij :
  forall n (b : bij n),
    (build_bij n ⟦b⟧) ≡[n] b.
Proof.
  intros.
  apply build_bij_correct.
  apply bFun_bij.
  apply bInjective_bij.
Qed.

Lemma bij_bBijective : forall (n:nat) (b : bij n),
  exists (g : nat -> nat), bFun n g /\ forall x, x < n -> g (⟦b⟧ x) = x /\ ⟦b⟧ (g x) = x.
Proof.
  intros.
  apply bSurjective_bBijective.
  - apply bFun_bij.
  - apply bInjective_bSurjective.
    apply bFun_bij.
    apply bInjective_bij.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Basic_Cons.CCC.
Require Import Coq_Cats.Coq_Cat.

(*
**********************************************************
***************                          *****************
***************     Prop Category        *****************
***************                          *****************
**********************************************************
*)

(* The category of Types in Coq's "Prop" universe (Coq's Proposits) *)

Program Definition Prop_Cat : Category := Coq_Cat Prop.

Local Hint Extern 1 => contradiction.

Program Instance False_init : Initial Prop_Cat := {|terminal := False|}.

Local Hint Extern 1 => match goal with |- ?A = ?B :> True => destruct A; destruct B end.

Program Instance True_term : Terminal Prop_Cat := {terminal := True}.

Local Hint Extern 1 => match goal with |- ?A = ?B :> _ ∧ _ => destruct A; destruct B end.

Local Hint Extern 1 => tauto.

Section Prod.
  Context (P Q : Prop).

  Program Definition Conj_Product : @Product Prop_Cat P Q := {|product := (P ∧ Q)|}.

  Local Obligation Tactic := idtac.

  Next Obligation. (* Prod_morph_unique *)
  Proof.
    intros p' r1 r2 f g H1 H2 H3 H4.
    rewrite <- H3 in H1.
    rewrite <- H4 in H2.
    clear H3 H4.
    extensionality x.
    apply (fun p => equal_f p x) in H1; apply (fun p => equal_f p x) in H2.
    cbn in H1, H2.
  destruct (f x); destruct (g x); cbn in *; subst; trivial.
  Qed.

End Prod.

Program Instance Prop_Cat_Has_Products : Has_Products Prop_Cat := Conj_Product.

Local Hint Extern 1 => match goal with H : _ ∧ _ |- _ => destruct H end.

Section Exp.
  Context (P Q : Prop).

  Program Definition implication_exp :
    @Exponential Prop_Cat _ P Q
    :=
      {|
        exponential := (P -> Q)
      |}.

  Local Obligation Tactic := idtac.

  Next Obligation. (* Exp_morph_unique *)
  Proof.
    intros z f u u' H1 H2.
    rewrite H1 in H2; clear H1.
    extensionality a; extensionality x.
    apply (fun p => equal_f p (conj a x)) in H2.
    assumption.
  Qed.

End Exp.

Program Instance Prop_Cat_Has_Exponentials : Has_Exponentials Prop_Cat := implication_exp.

Program Instance Prop_Cat_CCC : CCC Prop_Cat.

Local Hint Extern 1 => match goal with H : _ ∨ _ |- _ => destruct H end.

Section Sum.
  Context (P Q : Prop).
  Program Definition Disj_Sum  : @Sum Prop_Cat P Q := {|product := (P ∨ Q)|}.

  Local Obligation Tactic := idtac.

  Next Obligation. (* Sum_morph_unique *)
  Proof.
    intros p' r1 r2 f g H1 H2 H3 H4.
    rewrite <- H3 in H1.
    rewrite <- H4 in H2.
    clear H3 H4.
    extensionality x.
    destruct x as [x1|x2].
    + apply (fun p => equal_f p x1) in H1; auto.
    + apply (fun p => equal_f p x2) in H2; auto.
  Qed.

End Sum.

Program Instance Prop_Cat_Has_Sums : Has_Sums Prop_Cat := Disj_Sum.


Require Import Lib.Normalization.
Require Import Lib.EqDec.
Require Import Lib.HoTT.
Require Import Lib.LinearOrder.
Require Import Lib.Deduplicated.
Require Import Lib.DedupSort.

Theorem dedupSort_is_normalization (A: Type) `{LinearOrder A} :
  normalzation dedupSort.
Proof.
  unfold normalzation. intros x. apply dedupsorted_unique_representation. Search dedupSort.
  - apply same_elements_dedupSort.
  - apply sorted_dedupSort.
  - apply sorted_dedupSort.
  - apply dedup_dedupSort.
  - apply dedup_dedupSort.
Qed.

Definition FiniteSet (A: Type) `{LO: LinearOrder A} : Type :=
  QuotientNorm (A := list A) (N := dedupSort_is_normalization A) dedupSort.

Definition make_FiniteSet {A: Type} `{LO: LinearOrder A} (l: list A) :=
  make_QN dedupSort l (N := dedupSort_is_normalization A).

Definition getElems {A: Type} `{LO: LinearOrder A} (m: FiniteSet A) : list A :=
  val m.

Lemma dedupSort_is_sort_elem_eq {A: Type} `{LO: LinearOrder A} (l l': list A) :
  dedupSort l = dedupSort l' <-> Elem_eq l l'.
Proof.
  split.
  - intros H. apply (Elem_eq_trans (dedupSort l)).
    + apply same_elements_dedupSort.
    + rewrite H, Elem_eq_sym. apply same_elements_dedupSort.
  - intros H. apply dedupsorted_unique_representation;
    [| apply sorted_dedupSort | apply sorted_dedupSort | apply dedup_dedupSort
     | apply dedup_dedupSort ].
    apply (Elem_eq_trans l).
    + rewrite Elem_eq_sym. apply same_elements_dedupSort.
    + apply (Elem_eq_trans l'); [auto|]. apply same_elements_dedupSort.
Qed.

Theorem unique_repr_FiniteSet {A: Type} `{LO: LinearOrder A} (m m': FiniteSet A) :
  Elem_eq (getElems m) (getElems m') -> m = m'.
Proof.
  intros H. apply quotient_unique_representation. unfold norm_equiv, getElems in *.
  rewrite dedupSort_is_sort_elem_eq. auto.
Qed.

Theorem all_repr_FiniteMultiSet {A: Type} `{LO: LinearOrder A} (m: list A) :
  Elem_eq m (getElems (make_FiniteSet m)).
Proof.
  cbn. apply same_elements_dedupSort.
Qed.


Require Import Reals Coquelicot.Coquelicot.
Require Import Interval.Tactic.

Lemma constant :
  3 <= RInt (fun x => 1) 0 3 <= 3.
Proof.
integral.
Qed.

Lemma exp_0_3 :
  Rabs (RInt (fun x => exp x) 0 3 - (exp 1 ^ 3 - 1)) <= 1/(1000*1000).
Proof.
integral with (i_fuel 1).
Qed.

Lemma x_ln1p_0_1 :
  Rabs (RInt (fun x => x * ln (1 + x)) 0 1 - 1/4) <= 1/1000.
Proof.
integral with (i_fuel 1).
Qed.

Lemma circle :
  Rabs (RInt (fun x => sqrt (1 - x * x)) 0 1 - PI / 4) <= 1/100.
Proof.
integral with (i_fuel 7, i_degree 1).
Qed.

Lemma exp_cos_0_1 :
  Rabs (RInt (fun x => sin x * exp (cos x)) 0 1 - (exp 1 - exp (cos 1))) <= 1/1000.
Proof.
integral with (i_fuel 1).
Qed.

Lemma arctan_0_1 :
  Rabs (RInt (fun x => 1 / (1 + x*x)) 0 1 - PI / 4) <= 1/1000.
Proof.
integral with (i_fuel 1).
Qed.


(**
<<

  Sections
    - Dual_para: List-paramorphisms

     2016.01.27 v1.01  Added based on Dual_beta.v and Dual_hylo_para.v.

>>
*)

  Require Import Coq.Arith.Wf_nat.                 (* [lt_wf] *)
  Require Import Coq.Wellfounded.Inverse_Image.    (* [wf_inverse_image] *)

  Require Import dual.FoldLib.
  Require Export dual.MyLib.
  Require Import Recdef.

  Section Dual_para.
    Context { A B: Type }.

    Variable cr: (A * list A) -> B -> B.
    Variable cl: B -> (A * list A) -> B.
    Variable e: B.

    Definition g_lt (m1 m2: list A) := lt_length m1 m2.

    Definition g (m: list A) := m.

    Lemma g_lt_is_wf : well_founded g_lt.
    Proof.
      apply lt_length_wf.
    Qed.

    Lemma g_ind__onlyif__g_lt:
      forall m x xs,
        g m = x::xs ->
        g_lt xs m.
    Proof.
      intros * G.
      unfold g in G.
      subst m.
      unfold g_lt.
      unfold lt_length.
      simpl.
      auto.
    Qed.

    Function paraU
           (seed: B)
           (m: list A) {wf g_lt m} : B:=
      match g m with
        | [] => seed
        | x::xs => cr (x, xs) (paraU seed xs)
      end.
    Proof.
      intros.
      apply g_ind__onlyif__g_lt with (x:=x).
      now unfold g.
      exact g_lt_is_wf.
    Defined.

    Function paraD
             (acc: B)
             (m: list A) {wf g_lt m}: B :=
      match g m with
        | [] => acc
        | x::xs => paraD (cl acc (x,xs)) xs
      end.
    Proof.
      intros.
      apply g_ind__onlyif__g_lt with (x:=x).
      now unfold g.
      exact g_lt_is_wf.
    Defined.

    Hypothesis Associative:
      forall x y z,
        cr x (cl y z) =
        cl (cr x y) z.

    Hypothesis Unit:
      forall x,
        cr x e = cl e x.

    Lemma Hoisting : forall x:B, x = x.
    auto.
    Qed.

    Definition Meta_Lemma :=
      forall m xs x acc,
        cr (x, xs) (paraD acc m) =
        paraD (cr (x, xs) acc) m.

    Lemma paraU__paraD:
      forall m,
        paraU e m = paraD e m.
    Proof.

      Unset Ltac Debug.

      Main_Abs
        paraD
        paraU
        paraD_equation             (* unaryDown_equation *)
        paraU_equation            (* unaryUp_equation *)
        Associative
        Unit
        Hoisting
        Meta_Lemma
      .
      Unset Ltac Debug.
    Qed.

  End Dual_para.


Require Export Arith. (* to use ring for natural numbers *)
Require Export Ltac.
Require Export Numbers_facts.

Lemma Zmult_lt_reg_l: forall n m p : Z, (0 < p)%Z -> (p * n  < p * m)%Z -> (n < m)%Z.
Proof.
intros.
rewrite (Zmult_comm p n) in *.
rewrite (Zmult_comm p m) in *.
eapply Zmult_lt_reg_r; eassumption.
Qed.

(** *************************************************************************************************************)
(**                      Laugwitz-Schmieden                                                                     *)
(** *************************************************************************************************************)

Module LS <: Num_facts.

Definition A :=nat->Z.

(** Operations **)

Definition a0 : A := fun (n:nat) => 0%Z.
Definition a1: A := fun (n:nat) => 1%Z.

Definition plusA (u v:A) : A := fun (n:nat) => Zplus (u n) (v n).
Definition oppA (u:A) : A := fun (n:nat) => Z.opp (u n).

Definition minusA x y := plusA x (oppA y).

Definition multA (u v:A) : A := fun (n:nat) => Zmult (u n) (v n).

Definition divA (u v:A) : A := fun (n:nat) => Z.div (u n) (v n).
Definition modA (u v:A) : A := fun (n:nat) => Z.modulo (u n) (v n).

Definition absA (u:A) : A := fun (n:nat) => Z.abs (u n).

Notation "x + y " := (plusA  x y).
Notation "x * y " := (multA  x y).
Notation "x / y " := (divA  x y).
Notation "x mod% y" := (modA  x y) (at level 60).
Notation "0" := (a0).
Notation "1" := (a1).
Notation "- x" := (oppA x).
Notation "| x |" := (absA x) (at level 60).

(** Relations **)
Definition equalA (u v:A) :=
   exists N:nat, forall n:nat, n>N -> (u n)=(v n).

Notation "x =A y" := (equalA x y) (at level 80).

Definition leA (u v:A) :=
   exists N:nat, forall n:nat, n>N -> Z.le (u n) (v n).

Definition ltA (u v:A) :=
   exists N:nat, forall n:nat, n>N -> Z.lt (u n) (v n).

Notation "x <=A y" := (leA x y) (at level 50).
Notation "x <A y" := (ltA x y) (at level 50).

Definition std (u:A) := exists N:nat, forall n m, n>N -> m>N -> (u n)=(u m).

Definition non_std (u:A) := ~std u.

Definition lim (a:A) := exists p, std p /\ leA a0 p /\ ltA (absA a) p.

(** Tactics **)

Ltac gen_eq n0 :=  (match goal with |[ H : forall n:nat, n > ?X -> _ |- _ ] =>
   let myH:=fresh "Hyp" in assert (myH:(n0 > X)) by (unfold sum_plus1 in *;omega); generalize (H n0 myH); clear H; intro end).

Ltac gen_props :=
match goal with
  [|- forall n:nat, _ ] => let id:= fresh "p" in let Hid := fresh "Hp" in (intros id Hid; repeat (gen_eq id))
| [|- False] => let l:= collect_nats in repeat (gen_eq (sum_plus1 l))
end .

Ltac unfold_intros := unfold lim, std, leA, ltA, equalA, absA, minusA, multA, plusA, divA, modA, oppA, A, a0, a1; intros.

Ltac solve_ls_w_l x :=
unfold_intros;
destruct_exists;
let l:= collect_nats in exists (sum_plus1 l); simpl;
gen_props;
(apply x|| eapply x); solve [eassumption | omega].

Ltac autorew_aux :=
match goal with [H:(_=_)%Z |- _ ] => rewrite <- H end.

Ltac autorew := repeat autorew_aux.

Ltac solve_ls :=
(unfold_intros;
solve [ intros; solve [omega | ring] |
destruct_exists; try gen_props; intros; omega |
destruct_exists; let l:= collect_nats in exists (sum_plus1 l); intros; ring |
destruct_exists; let l:= collect_nats in exists (sum_plus1 l); simpl; gen_props; autorew; solve [assumption | omega | ring]]).

(*** Equality **)

Lemma equalA_refl : forall x, x =A x.
Proof.
solve_ls.
Qed.

Lemma equalA_sym : forall x y, x =A y -> y =A x.
Proof.
solve_ls.
Qed.

Lemma equalA_trans : forall x y z, x =A y -> y =A z -> x=A z.
Proof.
solve_ls.
Qed.

Instance equalA_equiv : Equivalence equalA.
Proof.
split; red; [apply equalA_refl | apply equalA_sym | apply equalA_trans ].
Qed.

(** Morphisms **)

Instance plusA_morphism : Proper (equalA ==> equalA ==> equalA) plusA.
Proof.
repeat red; solve_ls.
Qed.

Instance oppA_morphism : Proper (equalA ==> equalA) oppA.
Proof.
repeat red; solve_ls.
Qed.

Instance multA_morphism : Proper (equalA ==> equalA ==> equalA) multA.
Proof.
repeat red; solve_ls.
Qed.

Instance absA_morphism : Proper (equalA ==> equalA) absA.
Proof.
repeat red; solve_ls.
Qed.

Instance leA_morphism : Proper (equalA ==> equalA ==> Logic.iff)  leA.
Proof.
repeat red; unfold_intros; split; solve_ls.
Qed.

Instance ltA_morphism : Proper (equalA ==> equalA ==> Logic.iff) ltA.
Proof.
repeat red; unfold_intros; split; solve_ls.
Qed.

Instance divA_morphism : Proper (equalA ==> equalA ==> equalA) divA.
Proof.
repeat red; solve_ls.
Qed.

Instance modA_morphism : Proper (equalA ==> equalA ==> equalA) modA.
Proof.
repeat red; unfold_intros; solve_ls.
Qed.

(** Implementation of axioms of Numbers.v and Numbers_facts.v **)

(** Ring properties **)

Lemma plus_neutral : forall x:A,0 + x =A x.
Proof.
solve_ls.
Qed.

Lemma plus_comm : forall x y,  x + y =A  y + x.
Proof.
solve_ls.
Qed.

Lemma plus_assoc : forall x y z,  x + (y + z) =A (x + y) + z.
Proof.
solve_ls.
Qed.

Lemma plus_opp : forall x:A, x + (- x) =A a0.
Proof.
solve_ls.
Qed.

Lemma mult_neutral : forall x, a1 * x =A x.
Proof.
solve_ls.
Qed.

Lemma mult_comm : forall x y, x * y =A y * x.
Proof.
solve_ls.
Qed.

Lemma mult_assoc : forall x y z, x * (y * z) =A (x * y) * z.
Proof.
solve_ls.
Qed.

Lemma mult_absorb : forall x, x * a0 =A a0.
Proof.
solve_ls.
Qed.

Lemma mult_distr_l : forall x y z, (x+y)*z =A x*z + y*z.
Proof.
solve_ls.
Qed.

Definition Radd_0_l := plus_neutral.
Definition Radd_comm := plus_comm.
Definition Radd_assoc :=plus_assoc.
Definition Rmul_1_l :=mult_neutral.
Definition Rmul_comm :=mult_comm.
Definition Rmul_assoc := mult_assoc.
Definition Rdistr_l := mult_distr_l.

Lemma Rsub_def : forall x y : A, (minusA x y) =A (plusA x (oppA y)).
Proof.
intros; unfold minusA; apply equalA_refl.
Qed.

Definition Ropp_def := plus_opp.

Lemma stdlib_ring_theory : ring_theory a0 a1 plusA multA minusA oppA equalA.
Proof.
constructor.
exact Radd_0_l.
exact Radd_comm.
exact Radd_assoc.
exact Rmul_1_l.
exact Rmul_comm.
exact Rmul_assoc.
exact Rdistr_l.
exact Rsub_def.
exact Ropp_def.
Qed.

Add Ring A_ring : stdlib_ring_theory (abstract).

Lemma mult_distr_r : forall x y z, x*(y+z) =A x*y + x*z.
Proof.
intros; ring.
Qed.

(** absA **)

Lemma abs_pos : forall x, a0 <=A |x|.
Proof.
unfold_intros.
exists 0%nat.
intros; simpl.
assert ((x n)<>0\/x n=0)%Z by omega.
destruct H0.
assert (0 < Z.abs (x n))%Z by (apply Z.abs_pos; assumption).
omega.
rewrite H0; simpl; omega.
Qed.

Lemma abs_pos_val : forall x, a0<=A x -> |x|=A x.
Proof.
solve_ls_w_l Z.abs_eq.
Qed.

Lemma abs_neg_val : forall x, x<=A a0 -> |x|=A -x.
Proof.
solve_ls_w_l Z.abs_neq.
Qed.

Lemma abs_new : forall x a, x<=A a -> -x <=A a -> |x|<=A a.
Proof.
unfold_intros; destruct_exists.
let l := collect_nats in exists (sum_plus1 l).
gen_props.
assert (Hom:(x p<0)%Z\/(x p>=0)%Z)by omega.
elim Hom; clear Hom; intros Hom'.
rewrite Z.abs_neq.
assumption.
omega.
rewrite Z.abs_eq.
assumption.
omega.
Qed.

Lemma abs_new2 : forall x a, |x|<=A a -> -a <=A x .
Proof.
unfold_intros; destruct_exists.
let l := collect_nats in exists (sum_plus1 l).
gen_props.
assert (Hom:(x p<0)%Z\/(x p>=0)%Z)by omega.
elim Hom; clear Hom; intros Hom'.
rewrite Z.abs_neq in *.
omega.
omega.
rewrite Z.abs_eq in *.
omega.
omega.
Qed.

Lemma abs_triang : forall x y, |x+y| <=A |x| + | y |.
Proof.
solve_ls_w_l Z.abs_triangle.
Qed.

Lemma abs_prod : forall x y, |x * y| =A |x| * |y|.
Proof.
solve_ls_w_l Z.abs_mul.
Qed.

Lemma div_mod : forall a b, 0<A a\/a<A 0 -> b =A a*(b / a) + (b mod% a).
Proof.
intros; destruct H.
revert a b H.
solve_ls_w_l Z_div_mod_eq_full.
revert a b H.
solve_ls_w_l Z_div_mod_eq_full.
Qed.

Lemma div_mod2 : forall a b, 0<A a\/a<A 0 -> a*(b/a) =A b + - (b mod% a).
Proof.
intros a b H; generalize (div_mod a b H).
revert a b H.
solve_ls.
Qed.

Lemma div_mod3a : forall a b, 0 <A a -> (b mod% a) <A a.
Proof.
solve_ls_w_l Z_mod_lt.
Qed.

Lemma div_mod3b : forall a b, 0 <A a -> 0 <=A (b mod% a).
Proof.
solve_ls_w_l Z_mod_lt.
Qed.

Lemma div_mod3 : forall a b, 0<A a -> |(b mod% a)| <A a.
Proof.
intros.
rewrite abs_pos_val.
apply div_mod3a.
assumption.
apply div_mod3b.
assumption.
Qed.

Lemma lt_le : forall x y, (x <A y) -> (x <=A y).
Proof.
solve_ls.
Qed.

Lemma div_mod3_abs: forall a b:A, 0<A b \/ b<A 0 -> | a mod% b | <=A |b|.
Proof.
intros; destruct H.
rewrite (abs_pos_val b).
apply lt_le; apply div_mod3.
assumption.
apply lt_le; assumption.
revert a b H.
unfold_intros.
destruct H; destruct_exists.
exists (x+1)%nat.
gen_props.
rewrite (Z.abs_neq (b p)).
generalize (Z_mod_neg (a p) (b p) H); intros H'; destruct H'.
rewrite Z.abs_neq.
omega.
assumption.
omega.
Qed.

Lemma div_le : forall a b c, 0 <A c -> a <=A b -> a / c <=A b / c.
Proof.
solve_ls_w_l Z_div_le.
Qed.

Lemma div_pos : forall a b, 0 <=A a -> 0 <A b -> 0 <=A a/b.
Proof.
solve_ls_w_l Z_div_pos.
Qed.

Lemma bingo : forall x y:Z, (x<y -> x<>y)%Z.
Proof.
unfold_intros.
omega.
Qed.

Lemma bingo2 : forall x y:Z, (x>y -> x<>y)%Z.
Proof.
unfold_intros.
omega.
Qed.

Lemma div_idg : forall x y, a0 <A y -> (x * y) / y =A x.
Proof.
unfold_intros.
destruct_exists.
let l:=collect_nats in exists (sum_plus1 l).
gen_props.
apply Z_div_mult_full.
apply bingo2.
omega.
Qed.

Lemma mult_le : forall a b c d,
   a0 <=A a -> a <=A b -> a0 <=A c -> c <=A d -> a*c <=A b * d.
Proof.
solve_ls_w_l Zmult_le_compat.
Qed.

Lemma le_refl : forall x, x <=A x.
Proof.
solve_ls.
Qed.

Lemma le_trans : forall x y z, x <=A y -> y <=A z -> x <=A z .
Proof.
solve_ls.
Qed.

Lemma lt_plus : forall x y z t, x <A y -> z <A t -> (x + z) <A (y + t).
Proof.
solve_ls.
Qed.

Lemma mult_pos : forall x y : A, 0<A x -> 0<A y -> 0<A x*y.
Proof.
solve_ls_w_l Z.mul_pos_pos.
Qed.

Lemma lt_plus_inv : forall x y z, (x + z) <A (y + z) -> x <A y .
Proof.
solve_ls.
Qed.

Lemma le_plus : forall x y z t, x <=A y -> z <=A t -> (x + z) <=A (y + t).
Proof.
solve_ls.
Qed.

Lemma le_lt_plus : forall x y z t, x <=A y -> z <A t -> (x + z) <A (y + t).
Proof.
solve_ls.
Qed.

Lemma le_plus_inv : forall x y z, (x + z) <=A (y + z) -> x <=A y .
Proof.
solve_ls.
Qed.

Lemma le_mult_simpl : forall x y z , (a0 <=A z) -> (x <=A y)-> (x * z) <=A (y *z).
Proof.
solve_ls_w_l Zmult_le_compat_r.
Qed.

Lemma le_mult : forall x y z, a0 <=A x -> y <=A z -> x*y <=A x*z.
Proof.
solve_ls_w_l Zmult_le_compat_l.
Qed.

Lemma lt_mult_inv : forall x y z, a0 <A x -> (x * y) <A (x * z) -> y <A z .
Proof.
solve_ls_w_l Zmult_lt_reg_l.
Qed.

Lemma Zlt_mult_inv2 : forall x y z:Z, (x < 0 -> (x * y) < (x * z) -> z < y)%Z .
Proof.
intros.
apply Zmult_lt_reg_l with (- x)%Z.
omega.
apply Zplus_lt_reg_l with (x* z + x*y)%Z.
ring_simplify.
assumption.
Qed.

Lemma lt_mult_inv2 : forall x y z, x <A 0 -> (x * y) <A (x * z) -> z <A y .
Proof.
solve_ls_w_l Zlt_mult_inv2.
Qed.

Lemma Zle_mult_inv2 : forall x y z:Z, (x < 0 -> (x * y) <= (x * z) -> z <= y)%Z.
Proof.
intros.
apply Zmult_le_reg_r with (-x)%Z.
omega.
ring_simplify.
eapply Zplus_le_reg_l with (x*y + z*x)%Z.
ring_simplify.
apply H0.
Qed.

Lemma le_mult_inv2 : forall x y z, x <A 0 -> (x * y) <=A (x * z) -> z <=A y .
Proof.
solve_ls_w_l Zle_mult_inv2.
Qed.

Lemma lt_mult : forall x y z, 0 <A x -> y <A z -> x*y <A x*z.
Proof.
solve_ls_w_l Zmult_lt_compat_l.
Qed.

Lemma Zle_mult_inv : forall x y z:Z, (0 < x)%Z -> (x * y <= x * z)%Z -> (y <= z)%Z.
Proof.
intros.
eapply Zmult_lt_0_le_reg_r.
eassumption.
rewrite (Zmult_comm y x).
rewrite (Zmult_comm z x).
eassumption.
Qed.

Lemma le_mult_inv : forall x y z, a0 <A x -> (x * y) <=A (x * z) -> y <=A z .
Proof.
solve_ls_w_l Zle_mult_inv.
Qed.

Lemma le_mult_general :
  forall x y z t, 0 <=A x -> x <=A y -> 0 <=A z -> z  <=A t -> x*z <=A y*t.
Proof.
solve_ls_w_l Zmult_le_compat.
Qed.

Lemma le_mult_neg : forall x y z, x <A 0 -> y <=A z -> x*z <=A x*y.
Proof.
solve_ls_w_l Z.mul_le_mono_neg_l.
Qed.

Lemma lt_0_1 : (a0 <A a1).
Proof.
solve_ls.
Qed.

Lemma lt_m1_0 : (-a1 <A 0).
Proof.
solve_ls.
Qed.

Lemma lt_trans : forall x y z, x <A y -> y <A z -> x <A z .
Proof.
solve_ls.
Qed.

Lemma le_lt_trans : forall x y z, x <=A y -> y <A z -> x <A z .
Proof.
solve_ls.
Qed.

Lemma lt_le_trans : forall x y z, x <A y -> y <=A z -> x <A z .
Proof.
solve_ls.
Qed.

Lemma lt_le_2 : forall x y, (x <A y) -> (x+1 <=A y).
Proof.
solve_ls.
Qed.

Lemma Znot_le_lt : forall x y:Z, ~(x <= y)%Z -> (y < x)%Z.
Proof.
intros; omega.
Qed.

Lemma abs_minus : forall x, | - x| =A |x|.
Proof.
solve_ls_w_l Z.abs_opp.
Qed.

Lemma abs_max : forall x, x <=A |x|.
Proof.
unfold_intros.
destruct_exists.
exists 0%nat.
intros.
rewrite Z.abs_max.
assert (H':((x n)<= -(x n) \/ (x n) >= - (x n))%Z) by omega.
destruct H'.
rewrite Zmax_right.
omega.
omega.
rewrite Zmax_left.
omega.
omega.
Qed.

Lemma le_id : forall x y, x <=A y -> y <=A x -> x =A y.
Proof.
solve_ls.
Qed.

Lemma not_lt_0_0 : ~a0 <A a0.
Proof.
unfold_intros.
intro H; destruct H.
assert (0<0)%Z.
apply (H (x+1)%nat).
omega.
omega.
Qed.

Lemma contradict_lt_le : forall s x, s <A x -> x <=A s -> False.
Proof.
solve_ls.
Qed.

Lemma le_lt_False : forall x y, x <=A y -> y <A x -> False.
Proof.
solve_ls.
Qed.

Lemma div_le2 : forall a b, 0 <A a -> 0<=A b -> a*(b/a) <=A b.
Proof.
intros.
rewrite div_mod2.
setoid_replace b with (b+0) at 3 by ring.
apply le_plus.
apply le_refl.
apply le_plus_inv with (b mod%a).
ring_simplify.
apply div_mod3b.
assumption.
left.
assumption.
Qed.

(** properties of lim **)

Lemma  ANS1 : lim a1.
Proof.
unfold lim.
exists (fun (n:nat) => 2%Z).
split.
unfold std.
exists 0%nat.
intros; trivial.
split.
unfold leA, ltA, a0; simpl.
exists 0%nat.
intros; solve [auto with zarith].
rewrite abs_pos_val.
unfold ltA, a1; intros.
exists 0%nat.
intros; simpl; omega.
unfold leA; intros.
exists 0%nat.
unfold a0, a1.
intros; simpl; omega.
Qed.

Lemma ANS2a : forall x y, lim x -> lim y -> lim (x + y).
Proof.
intros x y Hx Hy.
elim Hx.
intros pp (Hstdpp, (Hle0pp,Habspp)).
elim Hy.
intros qq (Hstdqq, (Hle0qq,Habsqq)).
unfold lim.

unfold absA,ltA,a0 in *.
elim Habspp.
intros a Ha.
elim Habsqq.
intros b Hb.

elim Hle0pp.
intros r Hr.
elim Hle0qq.
intros s Hs.

elim Hstdpp.
intros ep Hep.
elim Hstdqq.
intros eq Heq.

exists (fun (n:nat) => (Zplus (pp (a+r+ep+1)%nat) (qq (b+s+eq+1)%nat))).
split.
unfold std.
exists (0)%nat.
intros; trivial.
split.
unfold leA, a0.
exists (plus a (plus b (plus r s)))%nat.
intros.
assert (Z.le 0 (pp (a+r+ep+1)%nat)).
apply Hr.
omega.
assert (Z.le 0 (qq (b+s+eq+1)%nat)).
apply Hs.
omega.
omega.
unfold plusA.
exists (plus ep (plus eq (plus a b)))%nat.
intros.

apply Z.le_lt_trans with (m:=Zplus (Z.abs (x n)) (Z.abs (y n))).
apply Z.abs_triangle.
assert (forall a b c d:Z, Z.lt a b -> Z.lt c d -> Z.lt (Zplus a c) (Zplus b d)).
intros; omega.
apply H0.
replace (pp (a + r + ep + 1)%nat) with (pp n).
apply Ha.
omega.
apply Hep.
omega.
omega.
replace (qq (b + s + eq + 1)%nat) with (qq n).
apply Hb.
omega.
apply Heq.
omega.
omega.
Qed.

Lemma ANS2b : forall x y, lim x -> lim y -> lim (x * y).
Proof.
intros x y Hx Hy.
elim Hx.
intros pp (Hstdpp, (Hle0pp,Habspp)).
elim Hy.
intros qq (Hstdqq, (Hle0qq,Habsqq)).
unfold lim.

unfold absA,ltA,a0 in *.
elim Habspp.
intros a Ha.
elim Habsqq.
intros b Hb.

elim Hle0pp.
intros r Hr.
elim Hle0qq.
intros s Hs.

elim Hstdpp.
intros ep Hep.
elim Hstdqq.
intros eq Heq.

exists (fun (n:nat) => (Zmult (Z.abs (pp (a+r+ep+1)%nat)+1%Z) (Z.abs (qq (b+s+eq+1)%nat)+1%Z))).
split.
unfold std.
exists (0)%nat.
intros; trivial.
split.
unfold leA, a0.
exists (plus a (plus b (plus r s)))%nat.
intros.
solve [auto with zarith].

unfold multA.
exists (plus ep (plus eq (plus a b)))%nat.
intros.
rewrite Zabs_Zmult.
apply Zmult_lt_compat.
split.
solve [auto with zarith].
rewrite (Z.abs_eq (pp (a + r + ep + 1)%nat)).
apply Z.lt_le_trans with (m:= pp (a + r + ep + 1)%nat ).
replace (pp (a + r + ep + 1)%nat) with (pp n).
apply Ha.
omega.
apply Hep.
omega.
omega.
omega.
apply Hr.
omega.
split.
solve [auto with zarith].
rewrite (Z.abs_eq (qq (b + s + eq + 1)%nat)).
apply Z.lt_le_trans with (m:= qq (b + s + eq + 1)%nat ).
replace (qq (b + s + eq + 1)%nat) with (qq n).
apply Hb.
omega.
apply Heq.
omega.
omega.
omega.
apply Hs.
omega.
Qed.

Lemma ANS2a' : forall x y : A, std x -> std y -> std (x + y).
Proof.
Admitted. (* easy : ANS2' *)

Lemma ANS1' : std 1.
Proof.
Admitted. (* easy : ANS1' *)

Lemma std0 : std 0.
Proof.
Admitted. (* easy : std 0 *)

Lemma ANS2a_minus : forall x, std x -> std (-x ).
Proof.
Admitted. (* easy : ANS2a_minus *)

Lemma ANS4 :  forall x, (exists y, lim y/\ | x | <=A | y |)-> lim x.
Proof.
intros.
elim H; clear H.
intros y (Hlimy,Hy).
unfold lim in *.
elim Hlimy.
intros n (Hstdn, (Hle0n,Hyn)).
exists n.
split.
solve [auto].
split.
solve [auto].
apply le_lt_trans with (y:=(|y|)); assumption.
Qed.

Definition std_alt (u:A) :=exists N:nat, exists a, forall n:nat, n > N -> u n = a.

Lemma std_std_alt : forall u:A, std u <-> std_alt u.
Proof.
intros u; split.
intros H ; unfold std, std_alt in *.
destruct H as [N HN].
exists N.
exists (u (plus N 1)).
intros.
apply HN.
easy.
omega.
intros H; unfold std, std_alt in *.
destruct H as [N HN].
exists N.
intros.
destruct HN as [a Ha].
apply eq_trans with a.
now apply Ha.
now (symmetry; apply Ha).
Qed.

Lemma std_A0_dec : forall x, std x -> {x <A 0}+{x =A 0}+{0 <A x}.
(* to be fixed with Set-exists *)
Proof.
intros x H.
assert (H':std_alt x) by now apply std_std_alt.
clear H.
unfold std_alt in H'.
assert (H'':{N:nat & {a:Z | forall n, n>N -> x n = a}}).
admit. (* only requires std to be defined using Set-exists *)
destruct H'' as [N [a Ha]].
assert (Hdec:({a<0%Z}+{a=0%Z}+{a>0%Z})%Z).
destruct a.
left;right; reflexivity.
right; apply Zgt_pos_0.
left; left; apply Zlt_neg_0.
destruct Hdec as [[HH | HH] | HH].
left; left.
exists N.
intros; unfold a0.
now rewrite  Ha.
left;right.
exists N.
now subst.
right.
exists N.
intros; unfold a0.
rewrite Ha.
omega.
easy.
Admitted.

Lemma std_lim : forall x, std x -> lim x.
(* lim x -> std x is false, e.g. (-1)^n *)
Proof.
intros x Hstdx.
unfold lim, std in *.
elim Hstdx.
intros N HN.
exists (fun (n:nat) => (Z.abs (x (N+1)%nat)+1)%Z).
split.
exists 0%nat; intros; trivial.
split.
unfold leA.
exists 0%nat; intros; simpl.
unfold a0.
solve [auto with zarith].
unfold ltA.
exists N.
intros.
unfold absA.
rewrite (HN (N+1)%nat n).
solve [auto with zarith].
solve [auto with zarith].
assumption.
Qed.

Instance lim_morphism : Proper (equalA ==> Logic.iff) lim.
repeat red.
unfold_intros.
split.

unfold_intros; destruct_exists.
destruct H1 as [H1' [H2' H3']].
exists H0.
split.
assumption.
split.
assumption.
elim H3'.
intros x0 Hx0.
exists (H+x0+1)%nat.
intros.
rewrite <- H2.
apply Hx0.
omega.
omega.

unfold_intros; destruct_exists.
destruct H1 as [H1' [H2' H3']].
exists H0.
split.
assumption.
split.
assumption.
elim H3'.
intros x0 Hx0.
exists (H+x0+1)%nat.
intros.
rewrite H2.
apply Hx0.
omega.
omega.
Qed.

Instance std_morphism : Proper (equalA ==> Logic.iff) std.
repeat red.
unfold_intros.
split.

unfold_intros; destruct_exists.
let l:= collect_nats in exists (sum_plus1 l); simpl in *.
intros.
transitivity (x n).
symmetry; apply H2; omega.
transitivity (x m).
apply H1; omega.
apply H2; omega.

unfold_intros; destruct_exists.
let l:= collect_nats in exists (sum_plus1 l); simpl in *.
intros.
transitivity (y n).
apply H2; omega.
transitivity (y m).
apply H1; omega.
symmetry; apply H2; omega.
Qed.

(** beta may be w or some non-standard Laugwitz-Schmieden number which is <= w *)
Definition beta : A := fun (n:nat) => (Z_of_nat n).

Lemma  Abeta : 0 <A beta.
Proof.
unfold ltA,a0,beta.
exists 1%nat.
intros.
omega.
Qed.

Lemma beta_std : ~std beta.
Proof.
intro H; unfold std in *.
elim H; clear H; intros N HN.
unfold beta in *.
assert (H1:(S N>N)%nat).
omega.
assert (H2:(S (S N)>N)%nat).
omega.
generalize (HN (S N)%nat (S(S N))%nat H1 H2); intro Heq.
assert (S N=S (S N)).
apply inj_eq_rev; assumption.
injection H; intros Hinj.
assert (Hth:(forall n:nat, ~n=(S n))).
intros n; elim n.
simpl; discriminate.
intros n0 Hn0 H'.
apply Hn0.
injection H'.
solve [auto].
generalize (Hth N); intros HthN.
solve [auto].
Qed.

Lemma beta_lim : ~ lim beta.
Proof.
intro H; unfold lim in *.
elim H; clear H; intros p (Hstdp,(Hle0p,Hwp)).
unfold ltA,a0 in *.
elim Hstdp.
intros b Hb.
elim Hwp.
intros a Ha.
elim Hle0p.
intros c Hc.
(* w (p (a+b+c+1) + a + b + c + 1) = p (a+b+c+1) + a+b+c+1 *)
(* p (p (a+b+c+1) + a + b + c + 1) = p (a + b + c + 1) because p(a+b+c+1)>=0 et Hb: p is std *)
pose (px:=p (a+b+c+1)%nat).
assert (0<= px)%Z.
apply Hc.
omega.
pose (x:=((Z.abs_nat px)+a+b+c+1)%nat).
assert ((|beta |) (x) < p (x))%Z.
apply Ha.
unfold px,x in *.
omega.

assert  ((|beta |) (x) >= p (x))%Z.
unfold absA in *.
unfold beta.
unfold x.
replace (p (Z.abs_nat px + a + b + c + 1)%nat)%Z with
(p (a+b+c+1)%nat)%Z.
rewrite Z.abs_eq.
replace (Z.abs_nat px + a + b + c + 1)%nat with (Z.abs_nat (px + (Z_of_nat (a + b + c + 1))))%nat.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq.
unfold px.
omega.
omega.
rewrite Zabs_nat_Zplus.
rewrite Zabs_nat_Z_of_nat.
ring.
unfold px; apply Hc.
omega.
solve [auto with zarith].
solve [auto with zarith].
apply Hb.
omega.
omega.
omega.
Qed.

Lemma nat_Z : forall a:Z, (0 <= a)%Z -> exists qnat, Z.of_nat qnat = a.
Proof.
intros.
exists (Z.to_nat a).
apply Z2Nat.id; assumption.
Qed.

Lemma std_alt_lt_beta : forall a, std_alt a /\ 0<=A a -> a <A beta.
Proof.
intros.
destruct H as [Hn Hp].
destruct Hn as [n Hn].
destruct Hn as [q Hq].
destruct Hp as [p Hp].
unfold beta, ltA.
assert (Hq0: (0<=q)%Z).
generalize (Hq (n+p+1)%nat); intros.
generalize (Hp (n+p+1)%nat); intros.
rewrite <- H.
apply H0.
omega.
omega.
elim (nat_Z q Hq0).
intros qnat Hqnat.
exists (n+qnat+p)%nat.
intros;rewrite Hq by omega.
rewrite <- Hqnat.
omega.
Qed.

Lemma lim_lt_beta : forall a, lim a/\ 0<=A a -> a <A beta.
Proof.
unfold lim;intros.
destruct H as [[c H] H1].
destruct H as [Hex [Hex2 Hex3]].
assert (std_alt c) by (apply std_std_alt; assumption).
rewrite abs_pos_val in Hex3 by assumption.
apply lt_trans with c.
assumption.
apply std_alt_lt_beta; split; assumption.
Qed.

(** induction *)

Parameter nat_like_induction :
  forall P : A -> Type,
    P a0 ->
    (forall n:A, (std n /\ 0 <=A n) -> P n -> P (plusA n a1)) ->
    forall n:A, (std n /\ 0<=A n) -> P n.

(*

Definition nat2A : nat -> {n:A | std n /\ 0<=A n}.
Proof.
fix 1.
intros n; case n.
exists a0.
clear nat2A n; abstract (split; [apply std0 | apply le_refl]).
intros p.
case (nat2A p).
intros xp Hxp.
exists (xp+a1).
clear nat2A n p;
abstract (split; [apply ANS2a'; [intuition | apply ANS1']| setoid_replace 0 with (0+0) by ring; apply le_plus; [intuition| apply lt_le;apply lt_0_1]]).
Defined.

Lemma A_is_nat :
forall a:A, std a /\ 0<=A a -> exists n:nat, a=proj1_sig (nat2A n).
Proof.
intros.
apply (nat_like_induction (fun (a:A) => exists n : nat, a = proj1_sig (nat2A n))).
exists 0%nat.
simpl; reflexivity.
intros n Hn Hex.
destruct Hex as [p Hp].
exists (S p)%nat.
simpl.
destruct (nat2A p) as [x Hx].
simpl in *.
now apply f_equal2.
assumption.
Qed.

*)

Parameter nat_like_induction_r1 :
forall H:std 0 /\ 0<=A0, forall P : A -> Type,
    forall (h0: P a0),
    forall hr : (forall n:A, (std n /\ 0 <=A n) -> P n -> P (plusA n a1)),
    nat_like_induction P h0 hr a0 H = h0.

Parameter nat_like_induction_r2 :
forall P : A -> Type,
    forall n:A, forall H:std n/\0<=A n,
    forall Hn':std (n+1)/\0<=A(n+1),
forall (h0: P a0),
    forall hr : (forall n:A, (std n /\ 0 <=A n) -> P n -> P (plusA n a1)),
    nat_like_induction P h0 hr (n + 1) Hn' =
    hr n H (nat_like_induction P h0 hr n H).

End LS.


(** Standard definitions of a simple typed lambda calculus
    with booleans **)

Require Import Utils Context.

(** syntax definition **)

Inductive stlc_ty : Type :=
  | stlc_bool : stlc_ty
  | stlc_arrow : stlc_ty -> stlc_ty -> stlc_ty.

Inductive stlc_term : Type :=
  | stlc_true : stlc_term
  | stlc_false : stlc_term
  | stlc_var : id -> stlc_term
  | stlc_app : stlc_term -> stlc_term -> stlc_term
  | stlc_abs : id -> stlc_ty -> stlc_term -> stlc_term.

(** Semantics **)

Fixpoint subst (x : id) (t : stlc_term) (t' : stlc_term) {struct t'} : stlc_term :=
  match t' with
    | stlc_var i      => if beq_id x i then t else t'
    | stlc_app l r    => stlc_app (subst x t l) (subst x t r)
    | stlc_abs i T t1 => stlc_abs i T (if beq_id x i then t1 else (subst x t t1))
    | stlc_true       => stlc_true
    | stlc_false      => stlc_false
  end.

Inductive stlc_bvalue : stlc_term -> Prop :=
  | sv_true : stlc_bvalue stlc_true
  | sv_false : stlc_bvalue stlc_false.

Inductive stlc_absvalue : stlc_term -> Prop :=
  | sv_abs : forall x T t12, stlc_absvalue (stlc_abs x T t12).

Definition stlc_value (t : stlc_term) : Prop := stlc_bvalue t \/ stlc_absvalue t.

Hint Constructors stlc_bvalue stlc_absvalue.
Hint Unfold stlc_value.

Reserved Notation "t '==>s' t'" (at level 40).

Inductive stlc_step : stlc_term -> stlc_term -> Prop :=
  | se_appabs : forall x T t12 v2, stlc_value v2 -> (stlc_app (stlc_abs x T t12) v2) ==>s subst x v2 t12
  | se_app1   : forall t1 t1' t2, t1 ==>s t1' -> stlc_app t1 t2 ==>s stlc_app t1' t2
  | se_app2   : forall v1 t2 t2', stlc_value v1 -> t2 ==>s t2' -> stlc_app v1 t2 ==>s stlc_app v1 t2'
  where "t '==>s' t'" := (stlc_step t t').

Hint Constructors stlc_step.

Definition stlc_multi_step := refl_step_closure stlc_step.

Notation "t '==>s*' t'" := (stlc_multi_step t t') (at level 40).

(** typing **)

Definition stlc_context := finite_map stlc_ty.

Inductive stlc_has_type : stlc_context -> stlc_term -> stlc_ty -> Prop :=
  | ST_Var : forall Gamma x T,
      lookup x Gamma = Some T ->
      stlc_has_type Gamma (stlc_var x) T
  | ST_Abs : forall Gamma x T11 T12 t12,
      stlc_has_type (extend x T11 Gamma) t12 T12 ->
      stlc_has_type Gamma (stlc_abs x T11 t12) (stlc_arrow T11 T12)
  | ST_App : forall T11 T12 Gamma t1 t2,
      stlc_has_type Gamma t1 (stlc_arrow T11 T12) ->
      stlc_has_type Gamma t2 T11 ->
      stlc_has_type Gamma (stlc_app t1 t2) T12
  | ST_True : forall Gamma,
       stlc_has_type Gamma stlc_true stlc_bool
  | ST_False : forall Gamma,
       stlc_has_type Gamma stlc_false stlc_bool.

Hint Constructors stlc_has_type.