(* https://coq.github.io/doc/master/stdlib/Coq.Unicode.Utf8_core.html *)
Require Import Unicode.Utf8_core.

Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Inductive month: Type :=
  | Jan : month.

Definition next_weekday (d: day): day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute next_weekday monday.
Eval simpl in (next_weekday friday).
Eval simpl in (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof.
  simpl. reflexivity.
Qed.

Inductive bool: Type :=
  | true  : bool
  | false : bool.

Definition negb (b:bool): bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1 b2 : bool) : bool :=
  match b1 with
  | true  => b2
  | false => false
  end.

Definition orb (b1 b2 : bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.

Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb4: (orb true false) = true.
Proof. simpl. reflexivity. Qed.

Definition admit {T: Type} : T. Admitted.
Check admit.

Definition nandb (b1 b2: bool) : bool :=
  admit.

Example test_nandb1: (nandb true false) = true.
Admitted.
Example test_nandb2: (nandb false false) = true.
Admitted.
Example test_nandb3: (nandb false true) = true.
Admitted.
Example test_nandb4: (nandb true true) = false.
Admitted.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
   admit.

Example test_andb31: (andb3 true true true) = true.
Admitted.
Example test_andb32: (andb3 false true true) = false.
Admitted.
Example test_andb33: (andb3 true false true) = false.
Admitted.
Example test_andb34: (andb3 true true false) = false.
Admitted.

(* Checkで型を確認 *)

Check (negb true).
Check negb.
Check admit.

Module Playground1.

Inductive nat: Type :=
  | O : nat
  | S : nat -> nat.

End Playground1.

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

Check S (S (S (S O))).
Eval simpl in (minustwo 4).

Check S.
Check pred.
Check minustwo.

Fixpoint evenb (n: nat): bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

(* Definition oddb (n: nat): nat := negb (evenb n). *)
(* 型推論すげー *)
Definition oddb n := negb (evenb n).

Example test_oddb1: (oddb (S O)) = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: (oddb (S (S (S (S O))))) = false.
Proof. simpl. reflexivity. Qed.

Module Playground2.
Fixpoint plus n m : nat :=
  match n with
  | O => m
  | S n' => S (plus n' m)
  end.
Eval simpl in (plus (S (S (S O))) (S (S O))).

Check plus.

Fixpoint mult n m : nat :=
  match n with
  | O => O
  | S n' => plus m (mult n' m)
  end.

Fixpoint minus n m : nat :=
  match n, m with
  | O, _ => O
  | S _, O => n
  | S n', S m' => minus n' m'
  end.

End Playground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
  | O => S O
  | S p => mult base (exp base p)
  end.

Example test_mult1: mult 3 3 = 9.
Proof. simpl. reflexivity. Qed.

Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => S O
  | S n' => mult n (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. auto. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. auto. Qed.

Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope.
Notation "x - y" := (minus x y) (at level 50, left associativity) : nat_scope.
Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope.

Check ((0 + 1) + 1).
Check Type.
Check nat.
Check Set.

Compute (nat*nat)%type.

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Example test_ble_nat1: (ble_nat 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat2: (ble_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat3: (ble_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

Fixpoint blt_nat (n m : nat) : bool :=
  match n with
  | O =>
    match m with
    | O => false
    | _ => true
    end
  | S n' =>
    match m with
    | O => false
    | S m' => blt_nat n' m'
    end
  end.

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. auto. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. auto. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. auto. Qed.

Theorem plus_O_n' : forall n:nat, 0 + n = n.
Proof.
  reflexivity. Qed.

Eval simpl in (forall n:nat, n + 0 = n).
Eval simpl in (forall n:nat, 0 + n = n).

Theorem plus_O_n'' : forall n:nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n.
  Info 3 reflexivity. Qed.

Theorem mult_0_l : forall n:nat, 0 * n = 0.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_id_example: forall n m : nat,
  n = m -> n + n = m + m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

(* 練習問題 x *)
Theorem plus_id_exercise : ∀ n m o : nat,
  n = m → m = o → n + m = m + o.
Proof.
  intros.
  rewrite H.
  rewrite H0.
  reflexivity.
Qed.

Theorem mult_0_plus : ∀ n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity. Qed.

(* 練習問題 xx *)
Theorem mult_1_plus : ∀ n m : nat,
  (1 + n) * m = m + (n * m).
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Theorem plus_1_neq_0 : ∀ n : nat,
  beq_nat (n + 1) 0 = false.
Proof.
  intros n. simpl.
(*   destruct n as [| n']. *) (* as いらなさそうだよね *)
  destruct n.
  simpl. reflexivity.
  simpl.
(*
なぜ beq_nat (plus n (S 0)) 0 だと簡約化できなくて，
beq_nat (plus (S n) (S 0)) 0 だと簡約化できたのか．
S だとわかっているから，
S (plus S n (S 0)) へと simplify されます
beq_nat の match にひっかかります，ってかんじか
*)
reflexivity.
Qed.

Theorem negb_involutive : ∀ b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b.
    reflexivity.
    reflexivity. Qed.

Theorem zero_nbeq_plus_1 : ∀ n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros.
  simpl.
  destruct n.
  reflexivity.
  reflexivity.
Qed.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : ∀ b c : bool,
  andb b c = true → b = true.
Proof.
  intros b c H.
  destruct b.
  - (* b = fales *)
    reflexivity.
  - (* b = false *)
    rewrite <- H.
    simpl. reflexivity. Qed.

(* TODO : う， Case なんか使えない *)

Theorem andb_true_elim2 : ∀ b c : bool,
  andb b c = true → c = true.
Proof.
  intros.
  destruct c.
  - (* c = true *)
  reflexivity.
  - (* c = false *)
  rewrite <- H.
  destruct b.
  -- (* b = true *)
  simpl. reflexivity.
  -- (* b = false *)
  simpl. reflexivity.
Qed.

Theorem plus_0_r: ∀ n:nat,
  n + 0 = n.
Proof.
  intros n. induction n as [| n'].
  -
  simpl. reflexivity.
  -
  simpl. rewrite IHn'. reflexivity.
Qed.

Theorem minus_diag : ∀ n,
  minus n n = 0.
Proof.
  intros n. induction n as [| n'].
  -
    simpl. reflexivity.
  -
    simpl. rewrite -> IHn'. reflexivity. Qed.

(* 練習問題 xx -- *)
Theorem mult_0_r : ∀ n:nat,
  n * 0 = 0.
Proof.
  intros. induction n.
  -
  reflexivity.
  -
  Print Nat.mul.
  simpl. trivial.
Qed.

Theorem plus_n_Sm : ∀ n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros.
  induction n.
  - auto.
  - auto.
Qed.

Theorem plus_comm : ∀ n m : nat,
  n + m = m + n.
Proof.
  intros.
  induction n.
  -
    auto.
  -
    simpl. rewrite IHn.
    induction m.
    --
      auto.
    --
      auto.
Qed.
(* -- *)

Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

(* 練習問題 xx *)
Lemma double_plus : ∀ n, double n = n + n .
Proof.
  intros.
  induction n.
  -
    trivial.
  -
    simpl. rewrite IHn.
    Print plus_comm.
    specialize (plus_comm n (S n)).
    intro. rewrite H. simpl.
    reflexivity.
Qed.

(*
練習問題: ★ (destruct_induction)
destructとinductionの違いを短く説明しなさい。
*)

(*

場合分けと帰納法 ?

destruct x.
は， x : A だとしたら，
Inductive A :=
  | なんとか1 : A
  | なんとか2 : A.

みたいに定義されているものについて，どの定義の形をしているか，を分ける．

induction x.
は， x : A だとしたら，

Inductive A :=
  | O : A
  | S O : A -> A.

みたいに定義されているとしたら，
もとのゴールが forall x:A, P x.
だとしたら，
P 0 /\ (forall n:A, P n -> P (S n)) を導出して，もとのゴールを示す．

*)

(* CoqIDE おちてデータ少し飛んだ，いいや *)

Theorem plus_assoc : forall n m p : nat,
  (n + m) + p = n + (m + p).
Proof.
  intros.
  induction n.
  trivial.
  simpl.
  rewrite IHn.
  reflexivity.
Qed.

Theorem plus_swap' : ∀ n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  rewrite <- plus_assoc.
  rewrite <- plus_assoc.
  Admitted.


(*|
##########################################
Compute ``if`` in a decideable prop in Coq
##########################################

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

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

I want to write a function that calculate count of ``true`` values of
``p 0 .. p t`` in a ``nat -> prop`` function.
|*)

Section count_sc.

  Variable p : nat -> Prop.
  Hypothesis p_dec : forall x : nat, {p x} + {~ p x}.

  Fixpoint count (x : nat) :=
    match x with
    | 0 => if p_dec 0 then 1 else 0
    | S y => if p_dec x then 1 + count y else count y
    end.

End count_sc.

Definition fret (x : nat) := False.

Axiom fret_dec : forall x : nat, { fret x } + { ~ fret x }.

Theorem hello_decide : forall x : nat, count fret fret_dec x = 0.
Proof.
  intros. induction x. unfold count.
  - Fail replace (fret_dec 0) with false. (* .fails *)

(*|
Before the ``replace`` tactic I should proof some goal like this:

.. code-block:: coq

    (if fret_dec 0 then 1 else 0) = 0

Coq does not automatically compute the value of the ``if`` statement.
and if I try to replace the ``fret_dec`` with it's value, I will get
this error:
|*)

    Fail replace (fret_dec 0) with false. (* .fails .unfold .messages *)
Abort. (* .none *)

(*|
How I can write ``count`` function that I can unfold and use it in
theorems?
|*)

(*|
Answer
******

You have declared ``fret_dec`` as an axiom. But that means it does not
have a definition, or implementation in other words. Thus, Coq cannot
compute with it.

You can still prove your theorem like so, using the ``destruct``
tactic:
|*)

Theorem hello_decide : forall x : nat, count fret fret_dec x = 0.
Proof.
  induction x as [| x IH].
  - unfold count. destruct (fret_dec 0) as [contra | _].
    + contradiction.
    + reflexivity.
  - simpl. rewrite IH. destruct (fret_dec (S x)) as [contra | _].
    + contradiction.
    + reflexivity.
Qed.

(*|
But, in this case it is really easy to provide such a decision
procedure instead of postulating it. And this simplifies the proof a
lot:
|*)

Definition fret_dec' (x : nat) : { fret x } + { ~ fret x }.
Proof. now right. Defined.

Theorem hello_decide' : forall x : nat, count fret fret_dec' x = 0.
Proof.
  induction x as [|x IH]; simpl.
  - reflexivity.
  - exact IH.
Qed.


Require Import Reals.
Require Import Raxioms.
Require Import RIneq.
Require Import List.
Require Import ListSet.
Require Import Logic.

Open Scope R_scope.

Require Import Probabilities.

(** * Rational Expressions *)

Parameter Var : Type.
Hypothesis Var_eq_dec : forall x y:Var, {x = y} + {x <> y}.

Inductive RatExpr : Type :=
  | Const:  R -> RatExpr
  | OneVar: Var -> RatExpr
  | Sum:    RatExpr -> RatExpr -> RatExpr
  | Sub:    RatExpr -> RatExpr -> RatExpr
  | Mul:    RatExpr -> RatExpr -> RatExpr
  | Div:    RatExpr -> RatExpr -> RatExpr
  | Minus:  RatExpr -> RatExpr.

Hypothesis eq_dec : forall x y: RatExpr, {x = y} + {x <> y}.

Definition const (e: RatExpr): Prop :=
match e with
  | Const p => True
  | _ => False
end.

Definition expr_sum (e1 e2: RatExpr): RatExpr :=
match e1, e2 with
  | Const r1, Const r2 => Const (r1 + r2)
  | _, _ => Sum e1 e2
end.

Fixpoint vars (e: RatExpr) : set Var :=
match e with
  | Const _  => empty_set Var
  | OneVar v => set_add Var_eq_dec v (empty_set Var)
  | Minus a  => vars a
  | Sum a b  => set_union Var_eq_dec (vars a) (vars b)
  | Sub a b  => set_union Var_eq_dec (vars a) (vars b)
  | Mul a b  => set_union Var_eq_dec (vars a) (vars b)
  | Div a b  => set_union Var_eq_dec (vars a) (vars b)
end.

(** Evaluation of variables **)
Definition Evaluation: Type := Var -> R.

Fixpoint eval_expr (e: RatExpr) (u: Evaluation) : R :=
match e with
  | Const r  => r
  | OneVar v => u v
  | Minus a  => - (eval_expr a u)
  | Sum a b  => (eval_expr a u) + (eval_expr b u)
  | Sub a b  => (eval_expr a u) - (eval_expr b u)
  | Mul a b  => (eval_expr a u) * (eval_expr b u)
  | Div a b  => (eval_expr a u) / (eval_expr b u)
end.

(** Extensional equality of expressions. **)
Inductive eq: RatExpr -> RatExpr -> Prop :=
  | eq_refl: forall a: RatExpr, eq a a
  | eq_var: forall a b: RatExpr,
              ( (forall u: Evaluation, (eval_expr a u = eval_expr b u))
                -> eq a b ).

Axiom custom_eq: forall a b: RatExpr, eq a b <-> a = b.

(** ** Expression arithmetics *)
Theorem expr_0_identity: forall a: RatExpr, Sum a (Const 0) =  a.
Proof.
    intros. rewrite <- custom_eq with (a:=Sum a (Const 0)).
    apply eq_var. intros. simpl. apply Rplus_0_r.
Qed.

Theorem expr_0_nonnegative: Const 0 = Minus (Const 0).
Proof.
    intros. rewrite <- custom_eq.
    apply eq_var. intros. simpl.
    rewrite Ropp_0. reflexivity.
Qed.

Theorem expr_sum_commutative: forall a b: RatExpr, Sum a b = Sum b a.
Proof.
    intros. rewrite <- custom_eq.
    apply eq_var. intros. simpl.
    apply Rplus_comm.
Qed.

Theorem expr_sum_commutative':
    forall a b: RatExpr, expr_sum a b = expr_sum b a.
Proof.
    intros.
    destruct a; destruct b;
        simpl;
        try rewrite Rplus_comm;
        try apply expr_sum_commutative;
        try trivial.
Qed.

Theorem expr_sum_associative: forall a b c: RatExpr, Sum a (Sum b c) = Sum (Sum a b) c.
Proof.
    intros. rewrite <- custom_eq.
    apply eq_var. intros. simpl.
    rewrite Rplus_assoc. reflexivity.
Qed.

Theorem expr_sum_associative': forall a b c: RatExpr, expr_sum a (expr_sum b c) = expr_sum (expr_sum a b) c.
Proof.
    intros.
    destruct a; destruct b; destruct c;
        simpl;
        try apply expr_sum_associative;
        try rewrite Rplus_assoc;
        try reflexivity;
        try rewrite <- custom_eq;
        try apply eq_var;
        try intros;
        try simpl;
        try rewrite ?Rplus_assoc; (* rewrite as many times as possible *)
        try reflexivity.
Qed.

Theorem expr_sum_cancelation: forall a: RatExpr, Sum a (Minus a) = Const 0.
Proof.
    intros. rewrite <- custom_eq.
    apply eq_var. intros. simpl.
    apply Rplus_opp_r.
Qed.

Theorem expr_sub_minus: forall a b: RatExpr, Sub a b = Sum a (Minus b).
Proof.
    intros. rewrite <- custom_eq.
    apply eq_var. intros. simpl.
    reflexivity.
Qed.

Lemma distributive_eval_sum:
    forall (a b: RatExpr) (u: Evaluation),
        eval_expr (expr_sum a b) u = eval_expr a u + eval_expr b u.
Proof.
    intros.
    destruct a; destruct b; simpl; reflexivity.
Qed.

(** ** Expressions and probabilities **)

Definition expr_is_valid_prob (r: RatExpr): Prop :=
match r with
  | Const p => is_valid_prob p
  | _ => False
end.

Lemma valid_prob_preservation:
    forall (e: RatExpr) (u: Evaluation),
        expr_is_valid_prob e -> is_valid_prob (eval_expr e u).
Proof.
    intros. induction e.
    - apply H.
    - inversion H.
    - inversion H.
    - inversion H.
    - inversion H.
    - inversion H.
    - inversion H.
Qed.

Definition stochastic_evaluation (u: Evaluation) (X: set Var): Prop :=
    forall x: Var, In x X -> is_valid_prob (u x).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Naturals -- TODO: use typeclasses                                       *
**************************************************************************)

Set Implicit Arguments.
Require Export Arith Div2 Omega.
Require Import LibTactics LibReflect LibBool LibOperation LibRelation LibOrder.
Require Export LibOrder.
Global Close Scope positive_scope.

(* ********************************************************************** *)
(** * Inhabited and comparable *)

Instance nat_inhab : Inhab nat.
Proof using. intros. apply (prove_Inhab 0). Qed.

Fixpoint nat_compare (x y : nat) :=
  match x, y with
  | O, O => true
  | S x', S y' => nat_compare x' y'
  | _, _ => false
  end.

Instance nat_comparable : Comparable nat.
Proof using.
  applys (comparable_beq nat_compare).
  induction x; destruct y; simpl.
  autos*.
  auto_false.
  auto_false.
  asserts_rewrite ((S x = S y) = (x = y)).
    extens. iff; omega.
  autos*.
Qed.

(* ********************************************************************** *)
(** * Order on natural numbers *)

Instance le_nat_inst : Le nat := Build_Le Peano.le.

(* ---------------------------------------------------------------------- *)
(** ** Relation to Peano, for tactic [omega] *)

Lemma le_peano : le = Peano.le.
Proof using. extens*. Qed.

Global Opaque le_nat_inst.

Lemma lt_peano : lt = Peano.lt.
Proof using.
  extens. rew_to_le. rewrite le_peano.
  unfold strict. intros. omega.
Qed.

Lemma ge_peano : ge = Peano.ge.
Proof using.
  extens. rew_to_le. rewrite le_peano.
  unfold flip. intros. omega.
Qed.

Lemma gt_peano : gt = Peano.gt.
Proof using.
  extens. rew_to_le. rewrite le_peano.
  unfold strict, flip. intros. omega.
Qed.

Hint Rewrite le_peano lt_peano ge_peano gt_peano : rew_nat_comp.
Ltac nat_comp_to_peano :=
  autorewrite with rew_nat_comp in *.

(** [nat_math] calls [omega] after basic pre-processing
    ([intros] and [split]) and after replacing comparison
    operators with the ones defined in [Peano] library. *)

Ltac nat_math_setup :=
  intros;
  try match goal with |- _ /\ _ => split end;
  try match goal with |- _ = _ :> Prop => apply prop_ext; iff end;
  nat_comp_to_peano.

Ltac nat_math :=
  nat_math_setup; omega.

(* ********************************************************************** *)
(** * Operations *)

Definition div (n q : nat) :=
  match q with
  | 0 => 0
  | S predq =>
  let aux := fix aux (m r : nat) {struct m} :=
    match m,r with
    | 0, _ => 0
    | S m',0 => (1 + aux m' predq)%nat
    | S m', S r' => aux m' r'
    end in
  aux n predq
  end.

Fixpoint factorial (n:nat) : nat :=
  match n with
  | 0 => 1
  | S n' => n * (factorial n')
  end.

(* ********************************************************************** *)
(** * Induction *)

Lemma peano_induction :
  forall (P:nat->Prop),
    (forall n, (forall m, m < n -> P m) -> P n) ->
    (forall n, P n).
Proof using.
  introv H. cuts* K: (forall n m, m < n -> P m).
  nat_comp_to_peano.
  induction n; introv Le. inversion Le. apply H.
  intros. apply IHn. nat_math.
Qed.

Lemma measure_induction :
  forall (A:Type) (mu:A->nat) (P:A->Prop),
    (forall x, (forall y, mu y < mu x -> P y) -> P x) ->
    (forall x, P x).
Proof using.
  introv IH. intros x. gen_eq n: (mu x). gen x.
  induction n using peano_induction. introv Eq. subst*.
Qed.

(* ********************************************************************** *)
(** * Simplification lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Addition and substraction *)

Lemma plus_zero_r : forall n,
  n + 0 = n.
Proof using. nat_math. Qed.
Lemma plus_zero_l : forall n,
  0 + n = n.
Proof using. nat_math. Qed.
Lemma minus_zero : forall n,
  n - 0 = n.
Proof using. nat_math. Qed.

Hint Rewrite plus_zero_r plus_zero_l minus_zero : rew_nat.

(* ---------------------------------------------------------------------- *)
(** ** Comparison *)

Section CompProp.
Implicit Types a b c n m : nat.

Lemma le_SS : forall n m, (S n <= S m) = (n <= m).
Proof using. nat_math. Qed.
Lemma ge_SS : forall n m, (S n >= S m) = (n >= m).
Proof using. nat_math. Qed.
Lemma lt_SS : forall n m, (S n < S m) = (n < m).
Proof using. nat_math. Qed.
Lemma gt_SS : forall n m, (S n > S m) = (n > m).
Proof using. nat_math. Qed.

Lemma plus_le_l : forall a b c,
  (a + b <= a + c) = (b <= c).
Proof using. nat_math. Qed.
Lemma plus_ge_l : forall a b c,
  (a + b >= a + c) = (b >= c).
Proof using. nat_math. Qed.
Lemma plus_lt_l : forall a b c,
  (a + b < a + c) = (b < c).
Proof using. nat_math. Qed.
Lemma plus_gt_l : forall a b c,
  (a + b > a + c) = (b > c).
Proof using. nat_math. Qed.

Lemma plus_le_r : forall a b c,
  (b + a <= c + a) = (b <= c).
Proof using. nat_math. Qed.
Lemma plus_ge_r : forall a b c,
  (b + a >= c + a) = (b >= c).
Proof using. nat_math. Qed.
Lemma plus_lt_r : forall a b c,
  (b + a < c + a) = (b < c).
Proof using. nat_math. Qed.
Lemma plus_gt_r : forall a b c,
  (b + a > c + a) = (b > c).
Proof using. nat_math. Qed.

End CompProp.

(* todo: negation *)

(* ---------------------------------------------------------------------- *)
(** ** Simplification tactic *)

(** [rew_nat] performs some basic simplification on
    expressions involving natural numbers *)

Hint Rewrite le_SS ge_SS lt_SS gt_SS : rew_nat.
Hint Rewrite plus_le_l plus_ge_l plus_lt_l plus_gt_l : rew_nat.
Hint Rewrite plus_le_r plus_ge_r plus_lt_r plus_gt_r : rew_nat.

Tactic Notation "rew_nat" :=
  autorewrite with rew_nat.
Tactic Notation "rew_nat" "~" :=
  rew_nat; auto_tilde.
Tactic Notation "rew_nat" "*" :=
  rew_nat; auto_star.
Tactic Notation "rew_nat" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_nat).
  (* autorewrite with rew_nat in *. *)

Tactic Notation "rew_nat" "~" "in" "*" :=
  rew_nat in *; auto_tilde.
Tactic Notation "rew_nat" "*" "in" "*" :=
  rew_nat in *; auto_star.
Tactic Notation "rew_nat" "in" hyp(H) :=
  autorewrite with rew_nat in H.
Tactic Notation "rew_nat" "~" "in" hyp(H) :=
  rew_nat in H; auto_tilde.
Tactic Notation "rew_nat" "*" "in" hyp(H) :=
  rew_nat in H; auto_star.

(* ********************************************************************** *)
(** * Other lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Div2 *)

Lemma div2_lt : forall n m, m <= n -> n > 0 -> div2 m < n.
Proof using. (* using stdlib *)
  nat_comp_to_peano. introv Le Gt.
  forwards: Nat.div2_decr m (n-1). omega. omega.
Qed.

Lemma div2_grows : forall n m, m <= n -> div2 m <= div2 n.
Proof using.
  nat_comp_to_peano.
  induction n using peano_induction. introv Le.
  destruct~ m. simpl. omega.
  destruct~ n. simpl. omega.
  destruct~ m. simpl. omega.
  destruct~ n. simpl. omega.
  simpl. rew_nat. apply~ H. nat_math. nat_math.
Qed.


(precise)admin@localhost:~$ coqtop
Welcome to Coq 8.3pl4 (April 2012)

Coq < Section Examples.

Coq < Require Import Classical.

Coq < Variables P Q R S : Prop.
P is assumed
Q is assumed
R is assumed
S is assumed

Coq < Goal ((P -> (Q /\ R)) /\ (R -> S)) -> (P -> S).
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  S : Prop
  ============================
   (P -> Q /\ R) /\ (R -> S) -> P -> S

Unnamed_thm < intros.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  S : Prop
  H : (P -> Q /\ R) /\ (R -> S)
  H0 : P
  ============================
   S

Unnamed_thm < elim H.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  S : Prop
  H : (P -> Q /\ R) /\ (R -> S)
  H0 : P
  ============================
   (P -> Q /\ R) -> (R -> S) -> S

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  S : Prop
  H : (P -> Q /\ R) /\ (R -> S)
  H0 : P
  H1 : P -> Q /\ R
  ============================
   (R -> S) -> S

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  S : Prop
  H : (P -> Q /\ R) /\ (R -> S)
  H0 : P
  H1 : P -> Q /\ R
  H2 : R -> S
  ============================
   S

Unnamed_thm < auto.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  S : Prop
  H : (P -> Q /\ R) /\ (R -> S)
  H0 : P
  H1 : P -> Q /\ R
  H2 : R -> S
  ============================
   S

Unnamed_thm < tauto.
Proof completed.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
auto.
tauto.

Unnamed_thm is defined

Coq <


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.
Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. lfind.  reflexivity.  }
Admitted.

Theorem append_rev_cons:
   forall (l1 l2: lst) (x: natural),
   rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
   induction l1; induction l2; try (simpl; reflexivity).
   { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
   f_equal. }
   { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
   induction l1.
   { induction l2.
   { simpl. rewrite append_rev_cons.
      rewrite <- 2 append_assoc.
      f_equal. }
   { simpl. rewrite append_nil. reflexivity. }
   }
   { intro. simpl. rewrite append_nil. reflexivity. }
Qed.

Theorem rev_involutive : forall (x : lst), eq (rev (rev x)) x.
Proof.
   induction x.
   { simpl. rewrite rev_append. simpl. f_equal.
   assumption. }
   { simpl. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   rewrite <- append_assoc.
   f_equal. }
   { rewrite IHx.
   rewrite append_nil.
   reflexivity. }
Qed.

Theorem rev_qreva_nil : forall (x : lst), eq (rev x) (qreva x Nil).
Proof.
   intros.
   rewrite qreva_append.
   rewrite append_nil.
   reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (rev (qreva x Nil)) x.
Proof.
   intro.
   rewrite <- rev_qreva_nil.
   apply rev_involutive.
Qed.


Require Export ZArith.
Open Scope Z_scope.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import FilterNary.
Require Import UltimatelyGreater.
Require Import Generic.
Require Import Limit.

(* Proving n-ary versions of [limit] lemmas *)

Lemma limit_eta A B f :
  limit A B f <-> limit A B (fun x => f x).
Proof. tauto. Qed.

Hint Rewrite limit_eta : nary_prepare.

(******************************************************************************)
(* FUTURE WORK: all this could be automatically generated from the lemmas in
   [Limit.v], maybe using coq-elpi. *)

(* nary limit lemmas *)

Lemma limit_mul_nary domain M f g :
  limit (nFilterType domain M) Z_filterType (Uncurry f) ->
  limit (nFilterType domain M) Z_filterType (Uncurry g) ->
  limit (nFilterType domain M) Z_filterType (Fun' (fun p => (App f p) * (App g p))).
Proof. prove_nary limit_mul. Qed.

Lemma limit_sum_nary domain M f g :
  limit (nFilterType domain M) Z_filterType (Uncurry f) ->
  limit (nFilterType domain M) Z_filterType (Uncurry g) ->
  limit (nFilterType domain M) Z_filterType (Fun' (fun p => (App f p) + (App g p))).
Proof. prove_nary limit_sum. Qed.

Lemma limit_sum_ultimately_ge_l_nary lo domain M f1 f2 :
  ultimately (nFilterType domain M) (Fun' (fun p => lo <= App f1 p)) ->
  limit (nFilterType domain M) Z_filterType (Uncurry f2) ->
  limit (nFilterType domain M) Z_filterType (Fun' (fun p => (App f1 p) + (App f2 p))).
Proof. prove_nary limit_sum_ultimately_ge_l. Qed.

Lemma limit_sum_ultimately_ge_r_nary lo domain M f1 f2 :
  ultimately (nFilterType domain M) (Fun' (fun p => lo <= App f2 p)) ->
  limit (nFilterType domain M) Z_filterType (Uncurry f1) ->
  limit (nFilterType domain M) Z_filterType (Fun' (fun p => (App f1 p) + (App f2 p))).
Proof. prove_nary limit_sum_ultimately_ge_r. Qed.

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

(* Applying n-ary limit lemmas *)

Ltac limit_domain G :=
  match G with
  | limit ?F _ _ =>
    let L := domain_of_filter F in
    exact (Mk_domain_of_goal L)
  end.

Hint Extern 0 Domain_of_goal =>
  (mk_domain_getter limit_domain) : domain_of_goal.

Goal
  limit (product_filterType Z_filterType Z_filterType) Z_filterType
    (fun '(x, y) => x * y).
Proof.
  apply_nary limit_mul_nary.
  admit. admit.
Admitted.

(******************************************************************************)
(* FIXME: generalize to other arities. The lemmas themselves work with any
   arity, but not the hint patterns. *)

Hint Extern 2 (limit _ _ (fun '(_, _) => Z.mul _ _)) =>
  apply_nary limit_mul_nary : limit.
Hint Extern 2 (limit _ _ (fun '(_, _) => Z.add _ _)) =>
  apply_nary limit_sum_nary : limit.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    Igroup

    Build the group of the inversible elements for the operation

    Definition: ZpGroup
  **********************************************************************)
Require Import ZArith.
Require Import Tactic.
Require Import Wf_nat.
Require Import UList.
Require Import ListAux.
Require Import FGroup.

Open Scope Z_scope.

Section IG.

Variable A: Set.
Variable op: A -> A -> A.
Variable support: list A.
Variable e: A.

Hypothesis A_dec: forall a b: A, {a = b} + {a <> b}.
Hypothesis support_ulist: ulist support.
Hypothesis e_in_support: In e support.
Hypothesis op_internal: forall a b, In a support -> In b support -> In (op a b) support.
Hypothesis op_assoc: forall a b c, In a support -> In b support -> In c support -> op a (op b c) = op (op a b) c.
Hypothesis e_is_zero_l:  forall a, In a support ->  op e a = a.
Hypothesis e_is_zero_r:  forall a, In a support ->  op a e = a.

(**************************************
  is_inv_aux tests if there is an inverse of a for op in l
 **************************************)

Fixpoint is_inv_aux (l: list A) (a: A) {struct l}: bool :=
  match l with nil => false | cons b l1 =>
   if (A_dec (op a b) e) then if (A_dec (op b a) e) then true else is_inv_aux l1 a else is_inv_aux l1 a
  end.

Theorem is_inv_aux_false: forall b l, (forall a, (In a l) -> op b a <> e \/  op a b <> e) -> is_inv_aux l b = false.
intros b l; elim l; simpl; auto.
intros a l1 Rec H; case (A_dec (op a b) e); case (A_dec (op b a) e); auto.
intros H1 H2; case (H a); auto; intros H3; case H3; auto.
Qed.

(**************************************
  is_inv tests if there is an inverse in support
 **************************************)
Definition is_inv := is_inv_aux support.

(**************************************
  isupport_aux returns the sublist of inversible element of support
 **************************************)

Fixpoint isupport_aux (l: list A) : list  A :=
  match l with nil => nil | cons a  l1 => if is_inv a then a::isupport_aux l1 else isupport_aux l1 end.

(**************************************
  Some properties of isupport_aux
 **************************************)

Theorem isupport_aux_is_inv_true: forall l a, In a (isupport_aux l) -> is_inv a = true.
intros l a; elim l; simpl; auto.
intros b l1 H; case_eq (is_inv b); intros H1; simpl; auto.
intros [H2 | H2]; subst; auto.
Qed.

Theorem isupport_aux_is_in: forall l a,  is_inv a = true -> In a l -> In a (isupport_aux l).
intros l a; elim l; simpl; auto.
intros b l1 Rec H [H1 | H1]; subst.
rewrite H; auto with datatypes.
case (is_inv b); auto with datatypes.
Qed.

Theorem isupport_aux_not_in:
  forall b l, (forall a, (In a support) -> op b a <> e \/  op a b <> e) -> ~ In b (isupport_aux l).
intros b l; elim l; simpl; simpl; auto.
intros a l1 H; case_eq (is_inv a); intros H1; simpl; auto.
intros H2 [H3 | H3]; subst.
contradict H1.
unfold is_inv; rewrite is_inv_aux_false; auto.
case H; auto; apply isupport_aux_is_in; auto.
Qed.

Theorem isupport_aux_incl: forall l, incl (isupport_aux l) l.
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1; case (is_inv a); auto with datatypes.
Qed.

Theorem isupport_aux_ulist: forall l, ulist l -> ulist (isupport_aux l).
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1 H2; case_eq (is_inv a); intros H3; auto with datatypes.
apply ulist_cons; auto with datatypes.
intros H4; apply (ulist_app_inv _ (a::nil) l1 a); auto with datatypes.
apply (isupport_aux_incl l1 a); auto.
apply H1; apply ulist_app_inv_r with (a:: nil); auto.
apply H1; apply ulist_app_inv_r with (a:: nil); auto.
Qed.

(**************************************
  isupport is the sublist of inversible element of support
 **************************************)

Definition isupport := isupport_aux support.

(**************************************
  Some properties of isupport
 **************************************)

Theorem isupport_is_inv_true: forall a, In a isupport -> is_inv a = true.
unfold isupport; intros a H; apply isupport_aux_is_inv_true with (1 := H).
Qed.

Theorem isupport_is_in: forall a,  is_inv a = true -> In a support -> In a isupport.
intros a H H1; unfold isupport; apply isupport_aux_is_in; auto.
Qed.

Theorem isupport_incl: incl isupport support.
unfold isupport; apply isupport_aux_incl.
Qed.

Theorem isupport_ulist: ulist isupport.
unfold isupport; apply isupport_aux_ulist.
apply support_ulist.
Qed.

Theorem isupport_length: (length isupport <= length support)%nat.
apply ulist_incl_length.
apply isupport_ulist.
apply isupport_incl.
Qed.

Theorem isupport_length_strict:
  forall b, (In b support) -> (forall a, (In a support) -> op b a <> e \/  op a b <> e) ->
           (length isupport < length support)%nat.
intros b H H1; apply ulist_incl_length_strict.
apply isupport_ulist.
apply isupport_incl.
intros H2; case (isupport_aux_not_in b support); auto.
Qed.

Fixpoint inv_aux (l: list A) (a: A) {struct l}: A :=
  match l with nil => e | cons b l1 =>
   if  A_dec (op a b) e then  if (A_dec (op b a) e) then b else inv_aux l1 a else inv_aux l1 a
  end.

Theorem inv_aux_prop_r: forall l a, is_inv_aux l a = true -> op a (inv_aux l a) = e.
intros l a; elim l; simpl.
intros; discriminate.
intros b l1 H1; case (A_dec (op a b) e); case (A_dec (op b a) e); intros H3 H4; subst; auto.
Qed.

Theorem inv_aux_prop_l: forall l a, is_inv_aux l a = true -> op (inv_aux l a) a = e.
intros l a; elim l; simpl.
intros; discriminate.
intros b l1 H1; case (A_dec (op a b) e); case (A_dec (op b a) e); intros H3 H4; subst; auto.
Qed.

Theorem inv_aux_inv: forall l a b, op a b = e -> op b a = e ->  (In a l) -> is_inv_aux l b = true.
intros l a b; elim l; simpl.
intros  _ _ H; case H.
intros c l1 Rec H H0 H1; case H1; clear H1; intros H1; subst;  rewrite H.
case (A_dec (op b a) e); case (A_dec e e); auto.
intros H1 H2; contradict H2; rewrite H0; auto.
case (A_dec (op b c) e); case (A_dec (op c b) e); auto.
Qed.

Theorem inv_aux_in: forall l a,  In (inv_aux l a) l \/ inv_aux l a = e.
intros l a; elim l; simpl; auto.
intros b l1; case (A_dec (op a b) e); case (A_dec (op b a) e); intros _ _ [H1 | H1]; auto.
Qed.

(**************************************
  The inverse function
 **************************************)

Definition inv := inv_aux support.

(**************************************
  Some properties of inv
 **************************************)

Theorem inv_prop_r: forall a, In a isupport -> op a (inv a) = e.
intros a H; unfold inv; apply inv_aux_prop_r with (l := support).
change (is_inv a = true).
apply isupport_is_inv_true; auto.
Qed.

Theorem inv_prop_l: forall a, In a isupport -> op (inv a) a = e.
intros a H; unfold inv; apply inv_aux_prop_l with (l := support).
change (is_inv a = true).
apply isupport_is_inv_true; auto.
Qed.

Theorem is_inv_true: forall a b, op b a = e ->  op a b = e -> (In a support) -> is_inv b = true.
intros a b H H1 H2; unfold is_inv; apply inv_aux_inv with a; auto.
Qed.

Theorem is_inv_false: forall b, (forall a, (In a support) -> op b a <> e \/  op a b <> e) -> is_inv b = false.
intros b H; unfold is_inv; apply is_inv_aux_false; auto.
Qed.

Theorem inv_internal: forall a, In a isupport -> In (inv a) isupport.
intros a H; apply isupport_is_in.
apply is_inv_true with a; auto.
apply inv_prop_l; auto.
apply inv_prop_r; auto.
apply (isupport_incl a); auto.
case (inv_aux_in support a); unfold inv; auto.
intros H1; rewrite H1; apply e_in_support; auto with zarith.
Qed.

(**************************************
   We are now ready to build our group
 **************************************)

Definition IGroup : (FGroup op).
generalize (fun x=> (isupport_incl x)); intros Hx.
apply mkGroup with (s := isupport) (e := e) (i := inv); auto.
apply isupport_ulist.
intros a b H H1.
assert (Haii: In (inv a) isupport); try apply  inv_internal; auto.
assert (Hbii: In (inv b) isupport); try apply  inv_internal; auto.
apply isupport_is_in; auto.
apply is_inv_true with (op (inv b) (inv a)); auto.
rewrite op_assoc; auto.
rewrite <- (op_assoc a); auto.
rewrite inv_prop_r; auto.
rewrite e_is_zero_r; auto.
apply inv_prop_r; auto.
rewrite <- (op_assoc (inv b)); auto.
rewrite  (op_assoc (inv a)); auto.
rewrite inv_prop_l; auto.
rewrite e_is_zero_l; auto.
apply inv_prop_l; auto.
apply isupport_is_in; auto.
apply is_inv_true with e; auto.
intros a H; apply inv_internal; auto.
intros; apply inv_prop_l; auto.
intros; apply inv_prop_r; auto.
Defined.

End IG.


Require Import List.
Import ListNotations.

Require Import Bool.

Parameter V : Type.
Parameter dec : V -> V -> bool.
Parameter dec_spec :
  forall x y : V, reflect (x = y) (dec x y).

Require Import Arith.

Notation "x =? y" := (dec x y) (at level 70).

Inductive Term (Var : Type) : Type :=
    | Var : Var -> Term Var
    | Lam : (Var -> Term Var) -> Term Var
    | App : Term Var -> Term Var -> Term Var.

Definition Term' : Type := forall Var : Type, Term Var.

Arguments Var {Var} _.
Arguments Lam {Var} _.
Arguments App {Var} _ _.

Fixpoint numOfVars (t : Term unit) : nat :=
match t with
    | Var _ => 1
    | Lam t' => numOfVars (t' tt)
    | App t1 t2 => numOfVars t1 + numOfVars t2
end.

Fixpoint subst' {A : Type} (M : Term (Term A)) : Term A :=
match M with
    | Var v => v
    | Lam M' => Lam (fun x : A => subst' (M' (Var x)))
    | App P Q => App (subst' P) (subst' Q)
end.

Definition subst
  (M : forall A : Type, A -> Term A) (N : Term') : Term' :=
    fun A : Type => subst' (M (Term A) (N A)).

(*
Compute
  subst (fun A x => App (Var x) (Var x)) (fun A => Lam (fun x : A => Var x)).
*)

(*
Inductive Beta {A : Type} : Term A -> Term A -> Prop :=
    | BetaContraction :
        forall (M : A -> Term A) (N : Term A),
          Beta (App (Lam M) N)
    | BetaAppL :
        forall P P' Q : Term',
          Beta P P' ->
            Beta (fun A => App (P A) (Q A)) (fun A => App (P' A) (Q A))
    | BetaAppR :
        forall P Q Q' : Term',
          Beta Q Q' ->
            Beta (fun A => App (P A) (Q A)) (fun A => App (P A) (Q' A))
    | BetaLam :
        forall M M' : forall A : Type, A -> Term A,
          Beta M M' ->
          Beta (fun A => Lam (M A)) (fun A => Lam (M' A)).
*)

(*
Inductive Beta : Term' -> Term' -> Prop :=
    | BetaContraction :
        forall (M : forall A : Type, A -> Term A) (N : Term'),
          Beta (fun A => App (Lam (M A)) (N A)) (fun A => subst M N A)
    | BetaAppL :
        forall P P' Q : Term',
          Beta P P' ->
            Beta (fun A => App (P A) (Q A)) (fun A => App (P' A) (Q A))
    | BetaAppR :
        forall P Q Q' : Term',
          Beta Q Q' ->
            Beta (fun A => App (P A) (Q A)) (fun A => App (P A) (Q' A))
    | BetaLam :
        forall M M' : forall A : Type, A -> Term A,
          (forall x : (forall A : Type, Term A),
            Beta (fun A => M (Term A) (x A)) (fun A => M' (Term A) (x A))) ->
          Beta (fun A => Lam (M A)) (fun A => Lam (M' A)).
*)


Definition nandb (b1:bool) (b2:bool) : bool :=
    match b1 with
    | false => true
    | true => match b2 with
              | false => true
              | true => false
              end
    end.

(* Found a non-nested method of patten matching! *)
Definition nandb' (b1:bool) (b2:bool) : bool :=
    match b1, b2 with
    | true, true => false
    | _, _ => true
    end.

(* Truth table for testing *)
Compute (nandb true false).
Compute (nandb false false).
Compute (nandb false true).
Compute (nandb true true).

(* Truth table for testing *)
Compute (nandb' true false).
Compute (nandb' false false).
Compute (nandb' false true).
Compute (nandb' true true).

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Example test_nandb1': (nandb' true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb2': (nandb' false false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb3': (nandb' false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb4': (nandb' true true) = false.
Proof. simpl. reflexivity. Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)

Require Export Bool Sumbool.
Require Vector.
Export Vector.VectorNotations.
Require Import Minus.

Local Open Scope nat_scope.

(**
We build bit vectors in the spirit of List.v.
The size of the vector is a parameter which is too important
to be accessible only via function "length".
The first idea is to build a record with both the list and the length.
Unfortunately, this a posteriori verification leads to
numerous lemmas for handling lengths.
The second idea is to use a dependent type in which the length
is a building parameter. This leads to structural induction that
are slightly more complex and in some cases we will use a proof-term
as definition, since the type inference mechanism for pattern-matching
is sometimes weaker that the one implemented for elimination tactiques.
*)

Section BOOLEAN_VECTORS.

(**
A bit vector is a vector over booleans.
Notice that the LEAST significant bit comes first (little-endian representation).
We extract the least significant bit (head) and the rest of the vector (tail).
We compute bitwise operation on vector: negation, and, or, xor.
We compute size-preserving shifts: to the left (towards most significant bits,
we hence use Vshiftout) and to the right (towards least significant bits,
we use Vshiftin) by inserting a 'carry' bit (logical shift) or by repeating
the most significant bit (arithmetical shift).
NOTA BENE: all shift operations expect predecessor of size as parameter
(they only work on non-empty vectors).
*)

Definition Bvector := Vector.t bool.

Definition Bnil := @Vector.nil bool.

Definition Bcons := @Vector.cons bool.

Definition Bvect_true := Vector.const true.

Definition Bvect_false := Vector.const false.

Definition Blow := @Vector.hd bool.

Definition Bhigh := @Vector.tl bool.

Definition Bsign := @Vector.last bool.

Definition Bneg := @Vector.map _ _ negb.

Definition BVand := @Vector.map2 _ _ _ andb.

Definition BVor := @Vector.map2 _ _ _ orb.

Definition BVxor := @Vector.map2 _ _ _ xorb.

Definition BshiftL (n:nat) (bv:Bvector (S n)) (carry:bool) :=
  Bcons carry n (Vector.shiftout bv).

Definition BshiftRl (n:nat) (bv:Bvector (S n)) (carry:bool) :=
  Bhigh (S n) (Vector.shiftin carry bv).

Definition BshiftRa (n:nat) (bv:Bvector (S n)) :=
  Bhigh (S n) (Vector.shiftrepeat bv).

Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
  match p with
    | O => bv
    | S p' => BshiftL n (BshiftL_iter n bv p') false
  end.

Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
  match p with
    | O => bv
    | S p' => BshiftRl n (BshiftRl_iter n bv p') false
  end.

Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
  match p with
    | O => bv
    | S p' => BshiftRa n (BshiftRa_iter n bv p')
  end.

End BOOLEAN_VECTORS.


Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

Variable X : Type.

Notation "[ ]" := nil.
Notation "h :: t" := (cons h t) (at level 60, right associativity).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "xs ++ ys" := (app xs ys).

Theorem app_nil_r : forall l : list X, l ++ [] = l.
Proof.
  intros.
  induction l.
    simpl. reflexivity.
    simpl. rewrite IHl. reflexivity.
Qed.

Theorem app_assoc : forall l m n : list X, l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros.
  induction l. destruct m. destruct n.
    simpl. reflexivity.
    simpl. reflexivity.
    simpl. reflexivity.
    simpl. rewrite IHl. reflexivity.
Qed.

Theorem app_length : forall l l' : list X, length l + length l' = length (l ++ l').
Proof.
  intros.
  induction l. destruct l'.
    simpl. reflexivity.
    simpl. reflexivity.
    simpl. rewrite IHl. reflexivity.
Qed.

Fixpoint rev (l : list X) : list X :=
  match l with
  | []   => []
  | h::t => rev t ++ [h]
  end.

Theorem rev_app_distr : forall l l' : list X, rev (l ++ l') = rev l' ++ rev l.
Proof.
  intros.
  induction l. destruct l'.
    simpl. reflexivity.
    simpl. rewrite app_nil_r. reflexivity.
    simpl. rewrite IHl. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_app : forall x l, rev l ++ [x] = rev (x::l).
Proof.
  intros.
  simpl. reflexivity.
Qed.

Theorem rev_rev_app : forall x l, rev (rev (x::l)) = x :: rev (rev l).
Admitted.

Theorem rev_involutive : forall l : list X, rev (rev l) = l.
Proof.
  intros.
  induction l.
    simpl. reflexivity.
    rewrite rev_rev_app. rewrite IHl. reflexivity.
Qed.


Require Import MSets.

(** Defines finite sets of natural. *)

Module NatSet := MSetWeakList.Make (Nat_as_OT).
Include NatSet.

Module NatSetFacts := Facts NatSet.
Module NatSetProps := Properties NatSet.

Declare Scope natset_scope.

Infix "U" := union (at level 60, right associativity).
Infix "U+" := add (at level 60, right associativity).
Notation "{[ ]}" := empty (format "{[ ]}") : natset_scope.
Notation "{[ x , y , .. , z ]}" := (add x (add y .. (add z empty) ..)) : natset_scope.
Notation "{[ x ]}" := (add x empty) (at level 0) : natset_scope.

(** ** Extra Facts on [NatSet] *)

Open Scope natset_scope.

Lemma nIn_nIn_Union :
  forall {x s s'}, ~NatSet.In x s -> ~NatSet.In x s' -> ~NatSet.In x (s U s').
Proof.
  intros *; intros nIn_s nIn_s' In_u.
  destruct (NatSetFacts.union_1 In_u); [apply nIn_s; assumption | apply nIn_s'; assumption ].
Qed.

Lemma union_empty :
  forall {s s' : NatSet.t},
    Equal (s U s') empty -> Empty s /\ Empty s'.
Proof.
  split;
    [ intros a In_empty;
      eapply NatSetFacts.union_2 in In_empty;
      erewrite H in In_empty;
      erewrite <- NatSetFacts.empty_iff; eauto
    | intros a In_empty;
      eapply NatSetFacts.union_3 in In_empty;
      erewrite H in In_empty;
      erewrite <- NatSetFacts.empty_iff; eauto ].
Qed.

Lemma union_empty_l :
  forall {s s' : NatSet.t},
    Equal (s U s') empty -> Equal s empty.
Proof.
  intros.
  eapply NatSetProps.empty_is_empty_1.
  eapply (union_empty H).
Qed.

Lemma union_empty_r :
  forall {s s' : NatSet.t},
    Equal (s U s') empty -> Equal s' empty.
Proof.
  intros.
  eapply NatSetProps.empty_is_empty_1.
  eapply (union_empty H).
Qed.

Lemma not_in_union_2 :
  forall [s s' : t] [x : elt], ~ In x (s U s') -> ~ In x s /\ ~ In x s'.
Proof.
  intros; split; intro.
  apply H; eapply NatSetFacts.union_2; eauto.
  apply H; eapply NatSetFacts.union_3; eauto.
Qed.

Lemma inter_empty_1 :
  forall {s s' e},
    Equal (inter s s') {[]} ->
    In e s ->
    ~In e s'.
Proof.
  intros; intro.
  assert (In e (inter s s')) by (eapply NatSetFacts.inter_3; eauto).
  match goal with
  | [ H: Equal ?I _, H': NatSet.In _ ?I |- _ ] =>
    rewrite H in H'; inversion H'
  end.
Qed.

Lemma inter_empty_2 :
  forall {s s' e},
    Equal (inter s s') {[]} ->
    In e s' ->
    ~In e s.
Proof.
  intros; intro.
  assert (In e (inter s s')) by (eapply NatSetFacts.inter_3; eauto).
  match goal with
  | [ H: Equal ?I _, H': NatSet.In _ ?I |- _ ] =>
    rewrite H in H'; inversion H'
  end.
Qed.

Lemma add_empty_false :
  forall x s, NatSet.Equal (x U+ s) {[]} -> False.
Proof. unfold Equal.
       intros x s In_iff.
       rewrite <- (NatSetFacts.empty_iff x).
       rewrite <- In_iff; auto with set.
Qed.

(** ** Tactics for NatSet *)

Ltac contrad_add_empty :=
  match goal with
  | [ H: NatSet.Equal (_ U+ _) {[]} |- _ ] =>
    exfalso; eapply add_empty_false; eauto
  end.

Ltac contrad_not_in_add :=
  match goal with
  | [ H: ~NatSet.In ?x (?x U+ _) |- _ ] =>
    exfalso; apply H; auto with set
  end.

Export NatSet NatSetFacts NatSetProps.


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rlt_asym.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rlt_irrefl : forall r, ~ r < r.
Proof.
  intro r.
  unfold "~".
  intro h.
  assert (asym:=Rlt_asym).
  unfold "~" in asym.
  specialize (asym r r).
  apply asym.
  exact h.
  exact h.
Qed.


Require Import ZArith.
Require Import List Bool Znumtheory Decidable.
Require Import Rbase Reals QArith micromega.Lia micromega.Lqa micromega.Lra Qreals.

From BY Require Import AppendixE AppendixF AppendixFdefs Divstep Zpower_nat Zlemmas Impl PadicVal Matrix Rlemmas IZR Log Floor Q Spectral.
From BY.Hierarchy Require Import Definitions BigOp.

Local Open Scope Z_scope.

Local Coercion Z.of_nat : nat >-> Z.

(******************************************************************)
(** This files relates the gcd algorithm with iterating divsteps. *)
(** Note that it contains one admitted computational lemma.       *)
(******************************************************************)

Section __.
  Context {f g : Z}
          {f_odd : Z.odd f = true}
          {g_even : Z.even g = true}
          {g_non0 : g <> 0}.

  Notation e := (ord2 g).

  Local Fixpoint z i :=
    match i with
    | 0%nat => (split2 g - f) / 2
    | S i => (z i + (z i mod 2) * split2 g) / 2
    end.
  Lemma z_S i : z (S i) = (z i + (z i mod 2) * split2 g) / 2. reflexivity. Qed.

  Local Definition sum j := (1 + big_sum (fun i => 2 * 2 ^+ i * (z i mod 2)) 0%nat j).

  Lemma z_eq j :
    z j = (sum j * split2 g - f) / 2 ^+ (S j).
  Proof.
    induction j; intros.
    - unfold sum.
      rewrite big_op_nil by lia; simpl.
      apply f_equal2. lia. lia.
    - rewrite z_S.
      replace ((z j + z j mod 2 * split2 g) / 2) with
          ((((sum j * split2 g - f) / 2 ^+ S j) + z j mod 2 * split2 g) / 2) by (now rewrite IHj). (* fixme: rewrite IHj at 1. runs to the weeds *)
      unfold sum.
      rewrite big_op_S_r.
      cbn -[big_sum].
      rewrite (Z.mul_comm 2 (_ * _)). rewrite <- (Zdiv_Zdiv _ (_ * _)).
      apply f_equal2.
      replace ((1 + (_ + _)) * split2 g - f)
        with (((1 + big_op op1 0 (fun i => 2 * 2 ^+ i * (z i mod 2)) 0%nat j%nat) * split2 g - f) + ((z j mod 2) * split2 g) * (2 * 2 ^+ j)) by (cbn; ring).

      rewrite Z.div_add.
      reflexivity.
      rewrite Zpower_nat_mul_l. apply Zpower_nat_nonzero. lia. reflexivity.
      rewrite Zpower_nat_mul_l. apply Zpower_nat_nonneg. lia.
      lia. lia. Qed.

  Lemma divstep_lemma1 i j (i_bound : (1 <= i)%nat) (sum_bound : (1 <= j + i < S e)%nat) :
    Nat.iter j divstep (Z.of_nat i, f, (g / 2 ^+ i)) = (j + i, f, g / 2 ^+ (j + i)).
  Proof.
    induction j; intros.
    - simpl. reflexivity.
    - simpl.
      rewrite IHj. unfold divstep.
      assert (0 <? j + i = true). apply Z.ltb_lt. lia.
      assert (Z.odd (g / 2 ^+ (j + i)) = false). apply negb_true_iff. rewrite Z.negb_odd.

      apply even_divide. transitivity (2 ^+ (ord2 g - (j + i))). apply Zpower_nat_base_divide. lia.
      apply divide_lemma. apply Zpower_nat_pos_nonneg. lia.
      transitivity (2 ^+ (ord2 g)). apply Zpower_nat_divide. lia. apply pval_spec. apply g_non0. lia.
      rewrite <- Zpower_nat_is_exp. replace ((j + i) + (ord2 g - (j + i)))%nat with (ord2 g) by lia.
      apply pval_spec. apply g_non0. lia.

      rewrite H, H0. simpl. apply f_equal2; [apply f_equal2|]. lia. lia.

      rewrite Zdiv_Zdiv. apply f_equal. ring.
      apply Zpower_nat_nonneg; lia. lia. lia.
  Qed.

  Lemma divstep_lemma2 i j (j_bound : (0 <= j + i < S e)%nat) :
    Nat.iter j divstep (1 - e + i, split2 g, z i) = (j + 1 - e + i, split2 g, z (j + i)).
  Proof.
    induction j.
    - reflexivity.
    - simpl; rewrite IHj by lia; unfold divstep.
      assert (0 <? j + 1 - e + i = false). apply Z.ltb_ge. lia.
      rewrite H, Zmod_odd.
      destruct (Z.odd (z (j + i))) eqn:E;
        apply f_equal2; apply f_equal2; rewrite ?Z.mul_1_l; try lia.
  Qed.

  Lemma divstep_lemma3 :
    divstep (Z.of_nat e, f, (split2 g)) = (1 - e, split2 g, z 0).
  Proof.
    unfold divstep.
    assert (0 <? e = true) by
        (rewrite <- Nat2Z.inj_0; apply Z.ltb_lt; apply inj_lt; apply ord2_even; apply g_even).
    rewrite H, odd_split2; auto.
  Qed.

  Lemma z_div j :
    2 ^+ (S j) * z j  = sum j * split2 g - f.
  Proof.
    induction j; intros.
    - unfold sum. rewrite big_op_nil by lia; simpl.
      rewrite Z.mul_1_r, <- Z_div_exact_2. ring. lia.
      rewrite Zmod_even, Z.even_sub, <- !Z.negb_odd.
      rewrite odd_split2, f_odd; auto.
    - simpl.
      replace (2 * (2 * 2 ^+ j) * ((z j + z j mod 2 * split2 g) / 2)) with
          (((2 ^+ S j) * z j) + (2 * 2 ^+ j) * (z j mod 2 * split2 g)).
      rewrite IHj.
      unfold sum. rewrite big_op_S_r. cbn. lia. lia.

      rewrite (Z.mul_comm 2 (2 * _)).
      rewrite <- (Z.mul_assoc _ 2).
      rewrite <- Z_div_exact_2. simpl. ring. lia.
      destruct (mod2_dec (z j)).
      + rewrite e, Z.mul_0_l, Z.add_0_r; auto.
      + rewrite <- Zplus_mod_idemp_l. rewrite e. rewrite Z.mul_1_l.
        apply Z.mod_divide. lia. apply even_divide. rewrite Z.even_add.
        rewrite <- (Z.negb_odd (split2 _)). rewrite odd_split2; auto.
  Qed.

  Lemma sum_odd j :
    Z.odd (sum j) = true.
  Proof.
    unfold sum.
    induction j.
    - reflexivity.
    - rewrite big_op_S_r, Z.add_assoc, Z.odd_add, IHj, !Z.odd_mul; try reflexivity; lia.
  Qed.

  Lemma sum_bound j :
    1 <= sum j < 2 ^+ (S j).
  Proof.
    unfold sum.
    induction j.
    - rewrite big_op_nil; simpl; lia.
    - rewrite big_op_S_r. pose proof Z.mod_pos_bound (z j) 2 ltac:(lia).
      rewrite <- Zpower_nat_mul_l. rewrite Z.add_assoc.
      assert (2 * 2 ^+ j = 2 ^+ (S j)) by reflexivity. nia. lia.
  Qed.

  Notation q' := (1 + big_sum (fun i => 2 * 2 ^+ i * (z i mod 2)) 0%nat e).

  Lemma q'_div :
    (2 ^+ (S e) | q' * split2 g - f).
  Proof. eexists. symmetry. rewrite Z.mul_comm. apply z_div. Qed.

  Lemma q'_odd :
    Z.odd q' = true.
  Proof. apply sum_odd. Qed.

  Lemma q'_bound :
    1 <= q' < 2 ^+ (S e).
  Proof. apply sum_bound. Qed.

  Lemma q'q : q' = q f g.
  Proof.
    apply q_unique. apply f_odd. apply g_non0.
    split; [|split]. apply q'_odd. apply q'_bound. apply q'_div.
  Qed.

  Theorem G1 :
    Nat.iter (2 * e) divstep (Z.of_nat 1%nat, f, (g / 2)) = (1 , split2 g , (- (f mod2 g)) / 2 ^+ S e).
  Proof.
    unfold mod_2.
    assert (0 < e)%nat. apply ord2_even. apply g_even.
    replace (- (f - q f g * split2 g)) with (q f g * split2 g - f) by ring.
    replace (g / 2) with (g / 2 ^+ 1) by reflexivity.
    replace (2 * e)%nat with ((S e) + (e - 1))%nat by lia.
    rewrite Nat.iter_add.
    rewrite divstep_lemma1.
    replace ((e - 1)%nat + 1%nat) with (Z.of_nat e) by lia.
    replace ((e - 1) + 1)%nat with e by lia.
    rewrite Nat.iter_succ_r.
    fold (split2 g).
    rewrite divstep_lemma3.
    replace (1 - e) with (1 - e + Z.of_nat 0) by lia.
    rewrite divstep_lemma2.
    apply f_equal2; [apply f_equal2|]. lia. reflexivity.
    rewrite Nat.add_0_r.
    rewrite z_eq. unfold sum. rewrite q'q. reflexivity. lia. lia. lia.
  Qed.
End __.

Section __.
  Context (R0 R1 : Z)
          (R0_odd : Z.odd R0 = true)
          (R1_even : Z.even R1 = true)
          (R1_non0 : R1 <> 0).

  Local Notation R_ i := (R_ R0 R1 i).
  Local Notation e i := (ord2 (R_ i)).
  Local Notation w j := (big_sum (fun i => e (S i)) 0 j).

  Theorem G2 j (H : R_ j <> 0) :
    Nat.iter (2 * (w j))%nat divstep (1, R0, R1 / 2) =
    (1, split2 (R_ j), (R_ (S j)) / 2).
  Proof.
    induction j.
    - simpl. rewrite split2_odd by apply R0_odd. reflexivity.
    - rewrite R_S_S.
      replace (R_ (S j) =? 0) with false by (symmetry; apply Z.eqb_neq; lia).
      rewrite big_op_S_r.
      replace (2 * (w j + e (S j))%RI)%nat with (2 * e (S j) + 2 * (w j))%nat by (cbn; lia).
      rewrite Nat.iter_add.
      rewrite IHj.
      rewrite Zdiv_Zdiv, Zpower_nat_mul_r.
      eapply G1.
      apply Zpower_nat_nonneg. lia. lia. apply R_nonzero_S. apply odd_nonzero. apply R0_odd.
      assumption. lia.
      Unshelve. apply odd_split2.
      apply R_nonzero_S. apply odd_nonzero. apply R0_odd.
      assumption. apply R_even. apply odd_nonzero. apply R0_odd.
      apply R1_even. assumption.
  Qed.

  Theorem G3 :
    (exists t G, Nat.iter (2 * (big_sum (fun i => e (S i)) 0 t)) divstep (1, R0, (R1 / 2)) = (1, G, 0) /\ Z.abs G = Z.gcd R0 R1) /\
    forall d f n, Nat.iter n divstep (1, R0, (R1 / 2)) = (d, f, 0) -> Z.abs f = Z.gcd R0 R1.
  Proof.
    apply and_lemma.
    destruct (@F26_cor2 R0 R1 R0_odd R1_even) as [t [Rt_non0 RSt_0]]. exists t, (split2 (R_ t)); split.
    rewrite G2. rewrite RSt_0. rewrite Z.div_0_l. reflexivity. lia. assumption. apply E3. assumption. assumption.
    apply RSt_0. apply Rt_non0.
    intros.
    destruct H as [t [G [H1 H2]]].
    set (w := big_sum (fun i : nat => e (S i)) 0 t) in *.
    assert ((d + (2 * w)%nat, f, 0) = (1 + n, G, 0)).
    rewrite <- (divstep_iter_0 1 R0 (R1 / 2) 1 G (2 * w)) by assumption.
    rewrite <- (divstep_iter_0 1 R0 (R1 / 2) d f n) by assumption.
    rewrite Nat.add_comm. reflexivity. inversion H. assumption.
  Qed.

  Local Open Scope R.
  Local Notation b := (log 2 (vec_norm (IZR R0, IZR R1))).

  Lemma b_spec : Rpower 2 b = vec_norm (IZR R0, IZR R1).
  Proof.
    apply Rpower_log; try lra.
    epose proof (vec_norm_nonneg (IZR R0, IZR R1)).
    epose proof (proj1 (vnonzero (IZR R0) (IZR R1))) _.
    epose proof (proj1 (vnonzero_norm _)) H0.  lra.
    Unshelve. left. cbn. replace RbaseSymbolsImpl.R0 with (IZR Z0) by reflexivity. apply IZR_neq. apply odd_nonzero. apply R0_odd.
  Qed.

  (****************************************************************************)
  (** The following lemma is computational. It can almost be done inside coq. *)
  (** We have extracted OCaml code which can run in managable time.           *)
  (****************************************************************************)

  Theorem G4 : b <= 21 -> exists x y, Nat.iter (Z.to_nat (floor (19 * b / 17))) divstep (1%Z, R0, (R1 / 2)%Z) = (x, y, 0%Z).
  Proof. Admitted.

  Notation it := (Z.to_nat
                    (if Rle_dec b 21
                     then floor (19 * b / 17)
                     else if Rle_dec b 46
                          then floor ((49 * b + 23) / 17)
                          else floor (49 * b / 17))).

  Lemma IZR_lt_le (a b : Z) : a < b -> a + 1 <= b.
  Proof. intros. apply lt_IZR in H. autorewrite with pull_izr. apply IZR_le. lia. Qed.

  Lemma inv_div_1 a : / a = 1 / a.
  Proof. lra. Qed.

  Local Open Scope R.

  Theorem G6 (G4 : b > 21) : exists x y, Nat.iter it divstep (1%Z, R0, (R1 / 2)%Z) = (x, y, 0%Z).
  Proof.
    destruct (Rle_dec b 21) eqn:E; [(* apply G4; assumption *) lra|].

    assert (log 2 633 < 456 / 49).
    { apply log_upper_bound. lra. lra.

      rewrite <- Rabs_pos_eq.
      apply (lt_pow 49). replace 0 with (INR 0). lia. reflexivity.

      rewrite <- (Rpower_pow 49 (Rpower _ _)).
      rewrite Rpower_mult. replace (456 / 49 * (INR 49)) with 456.
      replace 456 with (INR 456%nat).
      rewrite Rpower_pow. lra. lra. apply INR_IZR_INZ.
      replace (INR 49%nat) with 49. lra. symmetry; apply INR_IZR_INZ.
      apply Rpower_pos_nonneg.
      apply Rlt_le. apply Rpower_pos_nonneg. }

    assert (ineq1 : (59 < floor ((49 * b) / 17))%Z).
    { apply lt_IZR. apply floor_lower_bound. nra. }
    assert (ineq2 : (floor ((49 * b) / 17) <= it)%Z).
    { rewrite E.
      destruct (Rle_dec b 46); rewrite Z2Nat.id by (apply floor_pos; lra).
      - apply floor_inc. lra.
      - reflexivity. }
    assert (ineq3 : (60 <= it)%Z). lia.

    destruct (@F26_cor2 R0 R1 R0_odd R1_even) as [t [H1 H2]].
    pose proof E3 R0 R1 t R0_odd R1_even H2 H1.
    pose proof G2 t H1.

    enough (2 * w t <= it)%nat.
    { eapply divstep_iter_0'.
      rewrite E in H4. apply H4. rewrite G2. rewrite H2. reflexivity. assumption. }

    destruct (le_dec (2 * w t) it); [assumption|].

    rewrite E in *.

    epose proof F6 (split2 (R_ t)) (R_ (S t)) _. Unshelve.
    pose proof (@F25 R0 R1 R0_odd R1_even t H1).
    pose proof Rle_trans _ _ _ H4 H5.

    assert (31 <= w t)%Z. lia.

    epose proof log_inc 2 _ _ _ (conj _ H6).
    rewrite log_1 in H8. rewrite log_mult in H8.

    assert (log 2 (1 / (alpha (w t))) <= b).
    { rewrite log_div, log_1. lra. lra. apply alpha_pos_nonneg. }

    assert (it + 1 <= 2 * (w t)). rewrite E.
    rewrite <- mult_IZR.
    apply IZR_lt_le. apply IZR_lt. lia.

    assert (34 / 49 < log 2 (1024 / 633)).

    {  rewrite log_div.

       replace 1024 with (2 ^ 10) by lra.
       rewrite log_pow_id.

       replace (INR 10%nat) with 10. lra. symmetry; apply INR_IZR_INZ. lra. lra. lra. lra. }

    destruct (le_dec 67 (w t)).
    - rewrite alpha67 in H9 by assumption.

      assert (w t * log 2 ( 1024 / 633 ) <= b).
      replace (IZR (Z.of_nat (w t))) with (INR (w t)).
      rewrite <- log_pow. replace ((1024 / 633) ^ w t) with (1 / (633 / 1024) ^ w t). assumption.
      rewrite !pow_div. field. split. apply Rfunctions.pow_nonzero. lra. apply Rfunctions.pow_nonzero. lra. lra. lra.
      apply div_pos_nonneg. lra. lra.

      apply INR_IZR_INZ.
      assert (67 <= w t)%Z. lia.
      assert (34 * (w t) / 49 < b). nra.

      assert (2 * (w t) < 49 * b / 17).
      nra. assert (it + 1 < 49 * b / 17). lra.

      assert ((floor (49 * b / 17)) <= floor ((49 * b + 23) / 17))%Z.
      apply floor_inc. nra.

      assert (it <= floor ((49 * b + 23) / 17)).
      rewrite E. destruct (Rle_dec b 46). apply IZR_le. lia.
      apply IZR_le. lia.

      assert (floor (49 * b / 17) + 1 < 49 * b / 17). rewrite E in *. apply IZR_le in ineq2.
      lra.
      pose proof floor_spec (49 * b / 17). lra.

    - pose proof alpha31 (w t) ltac:(lia).

      assert ((alpha (w t) < Rpower 2 (- (34 * (w t) - 23) / 49))).
      rewrite <- Rabs_pos_eq. apply (lt_pow 49). lia.

      Ltac zlra :=
        match goal with
        | _ => progress autorewrite with pull_izr
        | [ |- _ <= _ ] => apply IZR_le
        | [ |- _ < _ ] => apply IZR_lt
        end; lia.

      rewrite <- !Rpower_pow.
      rewrite Rpower_mult. replace (- (34 * w t - 23) / 49 * INR 49) with (- (34 * w t - 23)).

      rewrite !INR_IZR_INZ.
      rewrite Rpower_Ropp.

      rewrite inv_div_1.

      replace (34 * w t - 23) with (INR (34 * w t - 23)).
      rewrite Rpower_pow.
      replace (IZR 49%nat) with (INR 49).
      rewrite Rpower_pow. assumption. apply alpha_pos_nonneg. apply INR_IZR_INZ. lra.
      autorewrite with pull_izr.
      rewrite !INR_IZR_INZ.
      apply IZR_eq. lia.

      rewrite !INR_IZR_INZ. field. apply Rpower_pos_nonneg.
      apply alpha_pos_nonneg.

      apply Rlt_le. apply Rpower_pos_nonneg.

      assert ((34 * w t - 23) / 49 <= b).
      etransitivity. shelve. apply H9.
      assert (2 * (w t) <= (49 * b + 23) / 17). lra.
      assert (it + 1 <= (49 * b + 23) / 17). lra.

      destruct (Rle_dec b 46) eqn:E2.
      rewrite E in *.
      rewrite Z2Nat.id in H10.
      pose proof (floor_spec ((49 * b + 23) / 17)) as [spec1 spec2]. lra.
      apply floor_pos. apply div_pos_pos. lra. lra.
      rewrite E in *.
      assert (floor (49 * 46 / 17) <= it).
      rewrite E, E2. rewrite Z2Nat.id. apply IZR_le. apply floor_inc. lra.
      apply floor_pos. lra. assert (2 * (w t) <= 132). rewrite <- mult_IZR. zlra.

      assert (132 = floor (49 * 46 / 17)). apply IZR_eq.
      apply floor_eq. lra. lra.

      rewrite E, E2 in *. lra.
    - apply alpha_pos_nonneg.
    - epose proof proj1 (vnonzero_norm (IZR R0, IZR R1)) _.
      pose proof vec_norm_nonneg (IZR R0, IZR R1). lra.
    - apply vnonzero. left.
      change 0%RI with (IZR Z0).
      apply IZR_neq. apply psplit_non0. lia. assumption.
      Unshelve. lra. lra. apply log_le_lower_bound. lra.
      rewrite <- (Ropp_involutive (_ / _)). rewrite Rpower_Ropp. apply Rle_div_r.
      apply alpha_pos_nonneg.
      apply Rle_div_l. apply Rpower_pos_nonneg. replace (- ((34 * w t - 23) / 49)) with (- (34 * w t - 23) / 49).
      lra.
      lra.
      apply vnonzero. left.
      change 0%RI with (IZR Z0).
      apply IZR_neq. apply odd_nonzero. apply R0_odd.
  Qed.
End __.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint even (even_arg0 : natural) : bool
           := match even_arg0 with
              | Zero => true
              | Succ n => negb (even n)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem: forall l1 l2 n, even (len (append l1 l2)) = negb (even (len (append l1 (Cons n l2)))).
Proof.
induction l1.
  - intros. simpl. rewrite (IHl1 l2 n0). reflexivity.
  - intros. simpl. unfold negb. destruct (even (len l2)). reflexivity. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (even (len (append x x))) true.
Proof.
induction x.
  - simpl. rewrite <- lem. assumption.
  - reflexivity.
Qed.


From Coq Require Import ZArith Lia.

Open Scope Z.

Theorem int_induction : forall (P : Z -> Prop) (m : Z),
  (forall n, n <= m -> P n) ->
  (forall n, m <= n -> P n -> P (Z.succ n)) ->
  forall n, P n.
Proof.
  intros.
  destruct n, m.
  destruct (Z.le_gt_cases n m).
  specialize (H _ H1).
  exact H.
  assert ( m <= Z.pred n) by lia.
  specialize (H0 _ H2).
  replace (Z.succ (Z.pred n)) with n in H0 by lia.
  apply H0.

Close Scope Z.


Require Import HSpace.Core HSpace.Coherent HSpace.Pointwise
  Pointed Homotopy.EvaluationFibration Tactics.EvalIn.

Local Open Scope pointed_scope.
Local Open Scope mc_mult_scope.

(** * The moduli type of H-space structures *)

(** When [A] is a left-invertible H-space, we construct an equivalence between the ("moduli") type of H-space structures on [A] and the type [A ->* (A ->** A)]. By the smash-hom adjunction for pointed types, due to Floris van Doorn in HoTT, the latter is also equivalent to the type [Smash A A ->* A].

This equivalence generalizes a formula of Arkowitz--Curjel and Copeland for spaces, and appears as Theorem 2.27 in https://arxiv.org/abs/2301.02636v1 *)

(** ** Paths between H-space structures *)

(** Paths between H-space structures correspond to homotopies between the underlying binary operations which respect the identities. This is the type of the latter. *)
Definition path_ishspace_type {X : pType} (mu nu : IsHSpace X) : Type.
Proof.
  destruct mu as [mu mu_lid mu_rid], nu as [nu nu_lid nu_rid].
  refine { h : forall x0 x1, mu x0 x1 = nu x0 x1 & prod (forall x:X, _) (forall x:X, _) }.
  - exact (mu_lid x = h pt x @ nu_lid x).
  - exact (mu_rid x = h x pt @ nu_rid x).
Defined.

(** Transport of left and right identities of binary operations along paths between the underlying functions. *)
Local Definition transport_binop_lr_id `{Funext} {X : Type} {x : X}
  {mu nu : X -> X -> X} `{mu_lid : forall y, mu x y = y}
  `{mu_rid : forall y, mu y x = y} (p : mu = nu)
  : transport (fun m : X -> X -> X =>
                 (forall y, m x y = y) * (forall y, m y x = y))
      p (mu_lid, mu_rid)
    = (fun y => (ap100 p _ _)^ @ mu_lid y,
         fun y => (ap100 p _ _)^ @ mu_rid y).
Proof.
  induction p; cbn.
  apply path_prod'; funext y.
  all: exact (concat_1p _)^.
Defined.

(** Characterization of paths between H-space structures. *)
Definition equiv_path_ishspace `{Funext} {X : pType} (mu nu : IsHSpace X)
  : path_ishspace_type mu nu <~> (mu = nu).
Proof.
  destruct mu as [mu mu_lid mu_rid], nu as [nu nu_lid nu_rid];
    unfold path_ishspace_type.
  nrefine (equiv_ap_inv' issig_ishspace _ _ oE _).
  nrefine (equiv_path_sigma _ _ _ oE _); cbn.
  snrapply (equiv_functor_sigma' (equiv_path_arrow2 _ _)); intro h; cbn.
  nrefine (equiv_concat_l _ _ oE _).
  1: apply transport_binop_lr_id.
  nrefine (equiv_path_prod _ _ oE _); cbn.
  snrapply equiv_functor_prod';
    nrefine (equiv_path_forall _ _ oE _);
    apply equiv_functor_forall_id; intro x.
  all: nrefine (equiv_moveR_Vp _ _ _ oE _);
    apply equiv_concat_r;
    apply whiskerR; symmetry;
    apply ap100_path_arrow2.
Defined.

(** ** Sections of evaluation fibrations *)

(** We first show that coherent H-space structures on a pointed type correspond to pointed sections of the evaluation fibration [ev A]. *)
Definition equiv_iscohhspace_psect `{Funext} (A : pType)
  : IsCohHSpace A <~> pSect (ev A).
Proof.
  refine (issig_psect (ev A) oE _ oE (issig_iscohhspace A)^-1%equiv).
  unfold SgOp, LeftIdentity, RightIdentity.
  nrapply equiv_functor_sigma_id; intro mu.
  snrapply (equiv_functor_sigma' (equiv_path_forall _ _)); intro H1; cbn.
  snrapply equiv_functor_sigma_id; intro H2; cbn.
  refine (_ oE (equiv_path_inverse _ _)).
  nrapply equiv_concat_r.
  refine (_ @ (concat_p1 _)^).
  (* This does not do a rewrite, but [change]s the goal based on the type of the lemma: *)
  rewrite_refl (ap_apply_lD (path_forall (mu pt) idmap H1) pt).
  exact (apD10_path_forall _ _ H1 pt)^.
Defined.

(** Our next goal is to see that when [A] is a left-invertible H-space, then the fibration [ev A] is trivial. *)

(** This lemma says that the family [fun a => A ->* [A,a]] is trivial. *)
Lemma equiv_pmap_hspace `{Funext} {A : pType}
  (a : A) `{IsHSpace A} `{!IsEquiv (hspace_op a)}
  : (A ->* A) <~> (A ->* [A,a]).
Proof.
  nrapply equiv_pequiv_postcompose.
  rapply pequiv_hspace_left_op.
Defined.

(** The lemma gives us an equivalence on the total spaces (domains) of [ev A] and [psnd] (the projection out of the displayed product). *)
Proposition equiv_map_pmap_hspace `{Funext} {A : pType}
  `{IsHSpace A} `{forall a:A, IsEquiv (a *.)}
  : (A ->* A) * A <~> (A -> A).
Proof.
  transitivity {a : A  & {f : A -> A & f pt = a}}.
  2: exact (equiv_sigma_contr _ oE (equiv_sigma_symm _)^-1%equiv).
  refine (_ oE (equiv_sigma_prod0 _ _)^-1%equiv oE equiv_prod_symm _ _).
  apply equiv_functor_sigma_id; intro a.
  exact ((issig_pmap A [A,a])^-1%equiv oE equiv_pmap_hspace a).
Defined.

(** The above is a pointed equivalence. *)
Proposition pequiv_map_pmap_hspace `{Funext} {A : pType}
  `{IsHSpace A} `{forall a:A, IsEquiv (a *.)}
  : [(A ->* A) * A, (pmap_idmap, pt)] <~>* selfmaps A.
Proof.
  snrapply Build_pEquiv'.
  1: exact equiv_map_pmap_hspace.
  cbn.
  apply path_forall, hspace_left_identity.
Defined.

(** When [A] is coherent, the pointed equivalence [pequiv_map_pmap_hspace] is a pointed equivalence over [A], i.e., a trivialization of [ev A]. *)
Proposition hspace_ev_trivialization `{Funext} {A : pType}
  `{IsCoherent A} `{forall a:A, IsEquiv (a *.)}
  : ev A o* pequiv_map_pmap_hspace ==* psnd (A:=[A ->* A, pmap_idmap]).
Proof.
  snrapply Build_pHomotopy.
  { intros [f x]; cbn.
    exact (ap _ (dpoint_eq f) @ hspace_right_identity _). }
  cbn.
  refine (concat_1p _ @ _^).
  refine (concat_p1 _ @ concat_p1 _ @ _).
  refine (ap10_path_forall _ _ _ _ @ _).
  apply iscoherent.
Defined.

(** ** The equivalence [IsCohHSpace A <~> (A ->* (A ->** A))] *)

Theorem equiv_cohhspace_ppmap `{Funext} {A : pType}
  `{IsCoherent A} `{forall a:A, IsEquiv (hspace_op a)}
  : IsCohHSpace A <~> (A ->* (A ->** A)).
Proof.
  refine (_ oE equiv_iscohhspace_psect A).
  refine (_ oE (equiv_pequiv_pslice_psect _ _ _ hspace_ev_trivialization^*)^-1%equiv).
  refine (_ oE equiv_psect_psnd (A:=[A ->* A, pmap_idmap])).
  refine (equiv_pequiv_postcompose _); symmetry.
  rapply pequiv_hspace_left_op.
Defined.


From Undecidability.L Require Import Prelim.MoreBase Util.L_facts AbstractMachines.LargestVar.
Require Import Lia.
Require Export Undecidability.L.AbstractMachines.FlatPro.ProgramsDef.

(* * Abstract L machines *)

(* *** Program size *)

Definition sizeT t :=
  match t with
    varT n => 1 + n
  |  _ => 1
  end.

Definition sizeP (P:Pro) := sumn (map sizeT P) + 1.
#[export] Hint Unfold sizeP : core.

Lemma size_geq_1 s: 1<= size s.
Proof.
  induction s;cbn. all:try lia.
Qed.

Lemma sizeP_size' s :size s <= sumn (map sizeT (compile s)).
Proof.
  induction s;cbn.
  all:autorewrite with list. all:cbn. all:try lia.
Qed.

Lemma sizeP_size s: sumn (map sizeT (compile s)) + 1<= 2*size s.
Proof.
  induction s;cbn.
  all:autorewrite with list. all:cbn. all:try lia.
Qed.

Lemma le_length_sizeP P :
  length P <= sizeP P.
Proof.
  unfold sizeP. induction P as [|[]];cbn in *;try Lia.lia.
Qed.

Lemma length_compile_leq s : |compile s| <= 2*size s.
Proof.
  induction s;cbn. all:autorewrite with list;cbn. all:nia.
Qed.

(* *** Programm Decomposition *)

Fixpoint jumpTarget (l:nat) (res:Pro) (P:Pro) : option (Pro*Pro) :=
  match P with
  | retT :: P => match l with
                | 0 => Some (res,P)
                | S l => jumpTarget l (res++[retT]) P
                end
  | lamT :: P => jumpTarget (S l) (res++[lamT])P
  | t :: P    => jumpTarget l (res++[t]) P
  | []        => None
  end.

Lemma jumpTarget_correct s c:
  jumpTarget 0 [] (compile s ++ retT::c) = Some (compile s,c).
Proof.
  change (Some (compile s,c)) with (jumpTarget 0 ([]++compile s) (retT::c)).
  generalize 0.
  generalize (retT::c) as c'. clear c.
  generalize (@nil Tok) as c.
  induction s;intros c' c l.
  -reflexivity.
  -cbn. autorewrite with list. rewrite IHs1,IHs2. cbn. now autorewrite with list.
  -cbn. autorewrite with list. rewrite IHs. cbn. now autorewrite with list.
Qed.

(* *** Program Substitution *)

Fixpoint substP (P:Pro) k Q : Pro :=
  match P with
    [] => []
  | lamT::P => lamT::substP P (S k) Q
  | retT::P => retT::match k with
                      S k => substP P k Q
                    | 0 => [(* doesnt matter *)]
                    end
  | varT k'::P => (if k' =? k then Q else [varT k'])++substP P k Q
  | appT::P => appT::substP P k Q
  end.

Lemma substP_correct' s k c' t:
  substP (compile s++c') k (compile t)
  = compile (subst s k t)++substP c' k (compile t).
Proof.
  induction s in k,c'|-*;cbn.
  -destruct (Nat.eqb_spec n k);cbn. all:now autorewrite with list.
  -autorewrite with list. rewrite IHs1,IHs2. reflexivity.
  -autorewrite with list. rewrite IHs. reflexivity.
Qed.

Lemma substP_correct s k t:
  substP (compile s) k (compile t) = compile (subst s k t).
Proof.
  replace (compile s) with (compile s++[]) by now autorewrite with list.
  rewrite substP_correct'. now autorewrite with list.
Qed.

(* *** Injectivity of Programm Encoding *)

(* returning the internal state as inr allows for stronger results w.r.t. decompiling initial segments*)
Fixpoint decompile l P A {struct P}: (list term) + (nat * Pro * list term) :=
  match P with
    retT::P => match l with
                0 => inr (l,retT::P,A)
              | S l => match A with
                        s::A => decompile l P (lam s::A)
                      | [] => inr (S l, retT::P, A)
                      end
              end
  | varT n::P => decompile l P (var n::A)
  | lamT::P =>  decompile (S l) P A
  | appT::P => match A with
               t::s::A => decompile l P (app s t::A)
             | _ => inr (l, appT::P, A)
              end
  | [] => inl A
  end.

Lemma decompile_correct' l s P A:
  decompile l (compile s++P) A = decompile l P (s::A).
Proof.
  induction s in l,P,A|-*. all:cbn.
  -congruence.
  -autorewrite with list. rewrite IHs1. cbn. rewrite IHs2. reflexivity.
  -autorewrite with list. rewrite IHs. reflexivity.
Qed.

Lemma decompile_correct l s:
  decompile l (compile s) [] = inl [s].
Proof.
  specialize (decompile_correct' l s [] []) as H. autorewrite with list in H. rewrite H. easy.
Qed.

(* We can not show a lemma that if decompile produces a term, the inout was a compilation as decompile itself sometimes decompiles incorrect programs if the lamTs are at wrong positions*)
Lemma decompile_resSize l P A B:
  decompile l P A = inl B -> sumn (map size B) <= sumn (map size A) + sumn (map sizeT P).
Proof.
  induction P as [ |[] P] in l,A|-*.
  -cbn. intros [= ->]. nia.
  -cbn. intros ->%IHP. cbn. nia.
  -destruct A as [ | ? []]. 1,2:easy.
   intros ->%IHP. cbn. nia.
  -cbn.  intros ->%IHP. nia.
  -destruct l. easy.
   destruct A as []. 1:easy.
   intros ->%IHP. cbn. nia.
   all:cbn.
Qed.

Lemma compile_inj s s' :
  compile s = compile s' -> s = s'.
Proof.
  intros eq.
  specialize (@decompile_correct' 0 s [] []) as H1.
  specialize (@decompile_correct' 0 s' [] []) as H2.
  rewrite eq in H1. rewrite H1 in H2. now inv H2.
Qed.

Lemma compile_neq_nil s:
  compile s <> [].
Proof.
  edestruct (compile s) eqn:eq. 2:easy.
  specialize decompile_correct' with (l:=0) (s:=s) (P:=[]) (A:=[]).
  rewrite eq.
  cbn. easy.
Qed.

Lemma compile_inj_retT s s' P P':
  compile s ++ retT::P = compile s' ++ retT::P' -> s = s' /\ P = P'.
Proof.
  intros eq.
  specialize (@decompile_correct' 0 s (retT::P) []) as H1.
  specialize (@decompile_correct' 0 s' (retT::P') []) as H2.
  rewrite eq in H1. rewrite H1 in H2.
  now inv H2.
Qed.

Definition Tok_eqb (t t' : Tok) :=
  match t,t' with
    varT n, varT n' => Nat.eqb n n'
  | retT,retT => true
  | lamT, lamT => true
  | appT, appT => true
  | _,_ => false
  end.

Lemma Tok_eqb_spec t t' : reflect (t = t') (Tok_eqb t t').
Proof.
  destruct t,t'. all:cbn. destruct (Nat.eqb_spec n n0);[subst|].
  all:try left;eauto.
  all:right;congruence.
Qed.

Definition largestVarT t :=
  match t with
    varT n => n
  | _ => 0
  end.

Definition largestVarP P := maxl (map largestVarT P).

Lemma largestVar_compile s :
  largestVarP (compile s) = largestVar s.
Proof.
  unfold largestVarP in *.
  induction s;cbn.
  -Lia.lia.
  -autorewrite with list. rewrite ! maxl_app.
   rewrite IHs1,IHs2. cbn. Lia.lia.
  -autorewrite with list. rewrite ! maxl_app.
   rewrite IHs. cbn. Lia.lia.
Qed.


Require Export D.

Theorem snoc_append : forall (l:natlist) (n:nat),
  snoc l n = l ++ [n].
Proof.
 intros. induction l. reflexivity.
 simpl. rewrite -> IHl. reflexivity.
Qed.