From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import Arith.
From VSA Require Import Basics.
From VSA Require Import Lattice.
From VSA Require Import LatticeProperties.
From VSA Require Import Functions.
From VSA Require Import Fixpoints.

Import SetNotations.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AId (s : string)
  | AMinus (a1 a2 : aexp).

Inductive bexp : Type :=
  | BLe (a1 a2: aexp)
  | BAnd (b1 b2: bexp)
  | BOr (b1 b2: bexp)
  | BNot (b: bexp).

Definition label : Type := nat.
Definition value : Type := nat.
Definition variable : Type := string.
Definition env : Type := variable -> value.

Fixpoint aeval (a: aexp) (ρ: env) : value :=
  match a with
  | ANum n => n
  | AId v => ρ v
  | AMinus a1 a2 => (aeval a1 ρ) - (aeval a2 ρ)
  end.

Fixpoint beval (b: bexp) (ρ: env) : bool :=
  match b with
  | BLe a1 a2 => Nat.leb (aeval a1 ρ) (aeval a2 ρ)
  | BAnd b1 b2 => (beval b1 ρ) && (beval b2 ρ)
  | BOr b1 b2 => (beval b1 ρ) || (beval b2 ρ)
  | BNot b => negb (beval b ρ)
  end.

Notation "'A⟦' A '⟧' ρ" := (aeval A ρ) (at level 40).
Notation "'B⟦' B '⟧' ρ" := (beval B ρ) (at level 40).

Inductive stmt: Type :=
  | SAssign (l: label) (v : variable) (a : aexp)
  | SSkip (l: label)
  | SIf (l: label) (b : bexp) (s1 : stmt)
  | SIfElse (l: label) (b : bexp) (s1 : stmt) (s2 : stmt)
  | SWhile (l: label) (b : bexp) (s : stmt)
  | SBreak (l: label)
  | SCompound (list : stmt_list)
with stmt_list: Type :=
  | stmt_list_singleton (s: stmt)
  | stmt_list_cons (s: stmt) (list: stmt_list).

Fixpoint at_stmt (s: stmt): label :=
  match s with
  | SAssign l _ _ => l
  | SSkip l => l
  | SIf l _ _ => l
  | SIfElse l _ _ _ => l
  | SWhile l _ _ => l
  | SBreak l => l
  | SCompound list => at_stmt_list list
  end
with at_stmt_list (list: stmt_list): label :=
  match list with
  | stmt_list_singleton s => at_stmt s
  | stmt_list_cons s _ => at_stmt s
  end.

Variant trace_action : Type :=
  | TAssign (v : variable) (a : aexp) (v : value)
  | TBValid (b : bexp)
  | TBInvalid (b : bexp)
  | TBreak
  | TSkip.

Inductive finite_trace: Type :=
  | finite_trace_nil (l: label)
  | finite_trace_cons (l: label) (a : trace_action) (t : finite_trace).

CoInductive infinite_trace: Type :=
  | infinite_trace_cons (l: label) (a : trace_action) (t : infinite_trace).

(* implicitely a bi-inductive type *)
Variant trace: Type :=
  | finite: finite_trace -> trace
  | infinite : infinite_trace -> trace.

Coercion finite_trace_nil : label >-> finite_trace.

Fixpoint at_finite_trace (t : finite_trace) : label :=
  match t with
  | finite_trace_nil l => l
  | finite_trace_cons _ _ t' => at_finite_trace t'
  end.

Definition at_infinite_trace (t : infinite_trace) : label :=
  match t with
  | infinite_trace_cons l _ _ => l
  end.

Definition at_trace (t : trace) : label :=
  match t with
  | finite t' => at_finite_trace t'
  | infinite t' => at_infinite_trace t'
  end.

Definition after_finite_trace (t : finite_trace) : label :=
  match t with
  | finite_trace_nil l => l
  | finite_trace_cons l _ _ => l
  end.

Notation "'at⟦' S ⟧" := (at_stmt S).
Notation "'at⟦' π '⟧t'" := (at_finite_trace π).
Notation "'after⟦' π '⟧t'" := (after_finite_trace π).

#[program]
Fixpoint concat_finite (t1 t2: finite_trace) {_: after⟦t1⟧t ≡ at⟦t2⟧t}: finite_trace :=
  match t2 with
  | finite_trace_nil _ => t1
  | finite_trace_cons l a t2' => finite_trace_cons l a (@concat_finite t1 t2' _)
  end.

Notation "t1 ⁀ t2" := (concat_finite t1 t2) (at level 40).
Notation "π ⟶( a ) l" := (finite_trace_cons l a π) (at level 50).

#[program]
Fixpoint concat_infinite (t1: finite_trace) (t2: infinite_trace) {_: after⟦t1⟧t ≡ at_infinite_trace t2}: infinite_trace :=
  match t1 with
  | finite_trace_nil _ => t2
  | finite_trace_cons _ a t1' =>
      @concat_infinite t1' (infinite_trace_cons after⟦t1'⟧t a t2) _
  end.

#[program]
Definition concat (t1 t2: trace) : option trace :=
  match t1, t2 with
  | finite t1', finite t2' =>
      if Nat.eq_dec after⟦t1'⟧t at⟦t2'⟧t then Some (finite (@concat_finite t1' t2' _))
      else None
  | finite t1', infinite t2' =>
      if Nat.eq_dec after⟦t1'⟧t (at_infinite_trace t2') then Some (infinite (@concat_infinite t1' t2' _))
      else None
  | infinite _, _ => Some t1
  end.

Fixpoint value_of (t: finite_trace) (v: variable) : value :=
  match t with
  | finite_trace_nil _ => 0
  | finite_trace_cons _ (TAssign s' _ val) t' =>
      if String.eqb v s' then val else value_of t' v
  | finite_trace_cons _ _ t' => value_of t' v
  end.

Notation "'ϱ(' π ')'" := (value_of π).

(* l' is the label after the statement, and it is not necessarily the label at the end of the traces *)
Inductive deductive_prefix_trace_semantics (l': label): stmt -> finite_trace -> ℘ finite_trace :=
  | dpts_stmt :
    forall S π1, at⟦S⟧ ≡ after⟦π1⟧t -> deductive_prefix_trace_semantics l' S π1 after⟦π1⟧t
  | dpts_assign :
    forall x a π1, deductive_prefix_trace_semantics l' (SAssign after⟦π1⟧t x a) π1 (after⟦π1⟧t ⟶(TAssign x a (A⟦a⟧ϱ(π1))) l')
  | dpts_while_false :
    forall b S π1 π2 (H: after⟦π1⟧t ≡ at⟦π2⟧t), after⟦π1⟧t ≡ after⟦π2⟧t -> B⟦b⟧ϱ(@concat_finite π1 π2 H) ≡ false ->
      deductive_prefix_trace_semantics l' (SWhile after⟦π1⟧t b S) π1 (π2 ⟶(TBInvalid b) l')
  | dpts_while_true :
    forall b S π1 π2 π3 (H1: after⟦π1⟧t ≡ at⟦π2⟧t) (H2: at⟦S⟧ ≡ at⟦π3⟧t), after⟦π1⟧t ≡ after⟦π2⟧t ->
      B⟦b⟧ϱ(@concat_finite π1 π2 H1) ≡ true ->
      deductive_prefix_trace_semantics after⟦π1⟧t S ((@concat_finite π1 π2 H1) ⟶(TBValid b) at⟦S⟧) π3 ->
      deductive_prefix_trace_semantics l' (SWhile after⟦π1⟧t b S) π1 (@concat_finite (π2 ⟶(TBValid b) at⟦S⟧) π3 H2).

(* TODO: find a way to express a set based on a condition *)
Axiom F_while : label -> bexp -> stmt -> (finite_trace -> ℘ finite_trace) -> (finite_trace -> ℘ finite_trace).
Instance finite_trace_Equiv: Equiv finite_trace := eq.
#[local]
Instance finite_trace_wp_finite_trace_CompleteLattice : CompleteLattice (finite_trace -> ℘ finite_trace).
Proof.
  apply PointwiseCompleteLattice.
  apply PowersetCompleteLattice.
Defined.
#[local]
Instance F_while_Increasing l b S: Increasing (F_while l b S).
Admitted.

Definition fixpoint_prefix_trace_semantics (l': label) (S: stmt) (π1: finite_trace): ℘ finite_trace :=
  let l := after⟦π1⟧t in
  if (Nat.eqb at⟦S⟧ l) then
    match S with
    | SAssign _ x a => {{ finite_trace_nil l }} ∪ {{ l ⟶(TAssign x a (A⟦a⟧ϱ(π1))) l' }}
    | SWhile _ b s => lfp_tarski (F_while l b s) π1
    | _ => {{ l }}
    end
  else
    ∅.


(******************************************************************************)
(*   Copyright (c) 2019--2022 - Paulo Torrens <paulotorrens AT gnu DOT org>   *)
(******************************************************************************)

Require Import Lia.
Require Import Arith.
Require Export Setoid.
Require Export Relations.
Require Import Equality.
Require Import Local.Prelude.
Require Import Local.Syntax.
Require Import Local.Metatheory.

Definition LEFT (R: relation pseudoterm): Prop :=
  forall b1 b2 ts c,
  R b1 b2 -> R (bind b1 ts c) (bind b2 ts c).

Global Hint Unfold LEFT: cps.

Definition RIGHT (R: relation pseudoterm): Prop :=
  forall b ts c1 c2,
  R c1 c2 -> R (bind b ts c1) (bind b ts c2).

Global Hint Unfold RIGHT: cps.

Class Congruence (R: relation pseudoterm) := {
  (* A congruence is an equivalence relation. *)
  Congruence_Equivalence :> Equivalence R;
  (* It also is preserved by any contexts. *)
  Congruence_Left: LEFT R;
  Congruence_Right: RIGHT R
}.

(** ** One-hole contexts. *)

Inductive context: Set :=
  | context_hole
  | context_left (b: context) (ts: list pseudoterm) (c: pseudoterm)
  | context_right (b: pseudoterm) (ts: list pseudoterm) (c: context).

Global Hint Constructors context: cps.

Lemma context_eq_dec:
  forall h r: context,
  { h = r } + { h <> r }.
Proof.
  decide equality.
  - apply pseudoterm_eq_dec.
  - apply list_eq_dec.
    apply pseudoterm_eq_dec.
  - apply list_eq_dec.
    apply pseudoterm_eq_dec.
  - apply pseudoterm_eq_dec.
Qed.

Reserved Notation "# h" (at level 0, right associativity, format "# h").

Fixpoint context_bvars (h: context): nat :=
  match h with
  | context_hole => 0
  | context_left b ts c => S #b
  | context_right b ts c => #c + length ts
  end

where "# h" := (context_bvars h).

Fixpoint context_depth (h: context): nat :=
  match h with
  | context_hole => 0
  | context_left b ts c => 1 + context_depth b
  | context_right b ts c => 1 + context_depth c
  end.

Fixpoint apply_context (h: context) (e: pseudoterm): pseudoterm :=
  match h with
  | context_hole => e
  | context_left b ts c => bind (apply_context b e) ts c
  | context_right b ts c => bind b ts (apply_context c e)
  end.

Coercion apply_context: context >-> Funclass.

Fixpoint compose_context (h: context) (r: context): context :=
  match h with
  | context_hole => r
  | context_left b ts c => context_left (compose_context b r) ts c
  | context_right b ts c => context_right b ts (compose_context c r)
  end.

Lemma compose_context_is_sound:
  forall h r e,
  compose_context h r e = h (r e).
Proof.
  induction h; intros; simpl.
  - reflexivity.
  - rewrite IHh.
    reflexivity.
  - rewrite IHh.
    reflexivity.
Qed.

Lemma compose_context_bvars:
  forall h r,
  #(compose_context h r) = #h + #r.
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - rewrite IHh; auto.
  - rewrite IHh; lia.
Qed.

Lemma compose_context_depth:
  forall h r,
  context_depth (compose_context h r) = context_depth h + context_depth r.
Proof.
  induction h; simpl; auto.
Qed.

Inductive static: context -> Prop :=
  | static_hole:
    static context_hole
  | static_left:
    forall h ts c,
    static h -> static (context_left h ts c).

Global Hint Constructors static: cps.

Lemma static_compose_context:
  forall h r,
  static h -> static r -> static (compose_context h r).
Proof.
  induction 1; simpl; intros.
  - assumption.
  - auto with cps.
Qed.

Definition nonstatic h: Prop :=
  ~static h.

Lemma context_static_nonstatic_dec:
  forall h,
  { static h } + { nonstatic h }.
Proof.
  induction h.
  (* Case: context_hole. *)
  - left; constructor.
  (* Case: context_left. *)
  - destruct IHh; simpl.
    + left; constructor.
      assumption.
    + right; intro.
      inversion_clear H.
      apply n; assumption.
  (* Case: context_right. *)
  - right; intro.
    inversion H.
Qed.

Lemma nonstatic_ind:
  forall P: context -> Prop,
  (* Recursion stops when a right context is found; we never reach a hole. *)
  forall f1: (forall b ts h, P (context_right b ts h)),
  forall f2: (forall h ts c, P h -> P (context_left h ts c)),
  forall h, nonstatic h -> P h.
Proof.
  induction h; intro.
  (* Case: context_hole. *)
  - exfalso; apply H.
    constructor.
  (* Case: context_left. *)
  - apply f2; apply IHh.
    intro; apply H.
    constructor.
    assumption.
  (* Case: context_right. *)
  - apply f1.
Qed.

Lemma context_is_injective:
  forall h r: context,
  h = r ->
  forall a b,
  h a = r b -> a = b.
Proof.
  induction h; destruct r; intros; try discriminate.
  - assumption.
  - dependent destruction H0.
    eauto.
  - dependent destruction H0.
    eauto.
Qed.

Inductive same_path: relation context :=
  | same_path_hole:
    same_path context_hole context_hole
  | same_path_left:
    forall h r ts1 ts2 c1 c2,
    same_path h r ->
    length ts1 = length ts2 ->
    same_path (context_left h ts1 c1) (context_left r ts2 c2)
  | same_path_right:
    forall b1 b2 ts1 ts2 h r,
    same_path h r ->
    length ts1 = length ts2 ->
    same_path (context_right b1 ts1 h) (context_right b2 ts2 r).

Global Hint Constructors same_path: cps.

Lemma same_path_refl:
  forall h,
  same_path h h.
Proof.
  induction h.
  - constructor.
  - constructor; auto.
  - constructor; auto.
Qed.

Global Hint Resolve same_path_refl: cps.

Lemma same_path_sym:
  forall h r,
  same_path h r -> same_path r h.
Proof.
  induction h; destruct r; inversion 1.
  - constructor.
  - constructor; auto.
  - constructor; auto.
Qed.

Global Hint Resolve same_path_sym: cps.

Lemma same_path_trans:
  forall h r s,
  same_path h r -> same_path r s -> same_path h s.
Proof.
  intros.
  generalize dependent s.
  induction H; intros.
  - assumption.
  - inversion_clear H1.
    constructor; auto.
    congruence.
  - inversion_clear H1.
    constructor; auto.
    congruence.
Qed.

Global Hint Resolve same_path_trans: cps.

Global Instance same_path_is_an_equivalence: Equivalence same_path.
Proof.
  split.
  - exact same_path_refl.
  - exact same_path_sym.
  - exact same_path_trans.
Defined.

Lemma same_path_implies_same_bvars:
  forall h r,
  same_path h r -> #h = #r.
Proof.
  induction 1.
  - reflexivity.
  - simpl; lia.
  - simpl; lia.
Qed.

Global Hint Resolve same_path_implies_same_bvars: cps.
Global Hint Rewrite same_path_implies_same_bvars: cps.

Lemma same_path_implies_same_depth:
  forall h r,
  same_path h r -> context_depth h = context_depth r.
Proof.
  induction 1; simpl; auto.
Qed.

Global Hint Resolve same_path_implies_same_depth: cps.
Global Hint Rewrite same_path_implies_same_depth: cps.

Lemma same_path_same_hole_implies_same_context:
  forall h r,
  same_path h r ->
  forall e,
  h e = r e -> h = r.
Proof.
  induction 1; simpl; intros.
  - reflexivity.
  - dependent destruction H1.
    f_equal; eauto.
  - dependent destruction H1.
    f_equal; eauto.
Qed.

(*
  The intuition behind the following technical lemma is as follow:

  We have two contexts H and R there are different, but we do have jumps n<xs>
  and m<ys> such that H[n<xs>] = R[m<ys>]. This implies that m<ys> is a subterm
  of H, and n<xs> is a subterm of R, i.e., H and R "mark" two different jumps in
  the same term. We want to, given a term x, rebuild the context H, but we will
  exchange the m<ys> in it by the term x, thus making S[n<xs>] equal to R[x],
  and do the respective thing for R.

  This is useful for proving that redexes are non-overlapping.
*)

Lemma context_difference:
  forall h r: context,
  h <> r ->
  forall n m xs ys,
  h (jump n xs) = r (jump m ys) ->
  forall x,
  exists s: context,
       r x = s (jump n xs)
    /\ same_path h s
    /\ forall y,
       exists u: context,
            h y = u (jump m ys)
         /\ same_path r u
         /\ s y = u x.
Proof.
  induction h; destruct r; simpl; intros.
  (* Case: (context_hole, context_hole). *)
  - exfalso; auto.
  (* Case: (context_hole, context_left). *)
  - discriminate.
  (* Case: (context_hole, context_right). *)
  - discriminate.
  (* Case: (context_left, context_hole). *)
  - discriminate.
  (* Case: (context_left, context_left). *)
  - dependent destruction H0.
    edestruct IHh with (r := r) as (s, ?).
    + congruence.
    + eassumption.
    + exists (context_left s ts0 c0); simpl.
      intuition.
      * f_equal; eassumption.
      * edestruct H3 as (u, ?).
        exists (context_left u ts0 c0); simpl.
        intuition; f_equal; eauto.
  (* Case: (context_left, context_right). *)
  - clear IHh.
    dependent destruction H0.
    eexists (context_left h ts0 (r x)).
    intuition.
    eexists (context_right (h y) ts0 r); intuition.
  (* Case: (context_right, context_hole). *)
  - discriminate.
  (* Case: (context_right, context_left). *)
  - clear IHh.
    dependent destruction H0.
    eexists (context_right (r x) ts0 h).
    intuition.
    eexists (context_left r ts0 (h y)); intuition.
  (* Case: (context_right, context_right). *)
  - dependent destruction H0.
    edestruct IHh with (r := r) as (s, ?).
    + congruence.
    + eassumption.
    + exists (context_right b0 ts0 s); simpl.
      intuition.
      * f_equal; eassumption.
      * edestruct H3 as (u, ?).
        exists (context_right b0 ts0 u); simpl.
        intuition; f_equal; eauto.
Qed.

Fixpoint context_lift i k h: context :=
  match h with
  | context_hole =>
    context_hole
  | context_left b ts c =>
    context_left (context_lift i (S k) b)
      (traverse_list (lift i) k ts) (lift i (k + length ts) c)
  | context_right b ts c =>
    context_right (lift i (S k) b)
      (traverse_list (lift i) k ts) (context_lift i (k + length ts) c)
  end.

Lemma same_path_context_lift:
  forall h i k,
  same_path h (context_lift i k h).
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - constructor.
    + apply IHh.
    + rewrite traverse_list_length.
      reflexivity.
  - constructor.
    + apply IHh.
    + rewrite traverse_list_length.
      reflexivity.
Qed.

Global Hint Resolve same_path_context_lift: cps.

Lemma context_lift_is_sound:
  forall (h: context) i k e,
  lift i k (h e) = context_lift i k h (lift i (#h + k) e).
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - rewrite lift_distributes_over_bind.
    f_equal.
    replace (S (#h + k)) with (#h + S k); try lia.
    apply IHh.
  - rewrite lift_distributes_over_bind.
    f_equal.
    replace (#h + length ts + k) with (#h + (k + length ts)); try lia.
    apply IHh.
Qed.

Lemma context_lift_bvars:
  forall h i k,
  #(context_lift i k h) = #h.
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - rewrite IHh; auto.
  - rewrite traverse_list_length.
    rewrite IHh; auto.
Qed.

Fixpoint context_subst y k h: context :=
  match h with
  | context_hole =>
    context_hole
  | context_left b ts c =>
    context_left (context_subst y (S k) b)
      (traverse_list (subst y) k ts) (subst y (k + length ts) c)
  | context_right b ts c =>
    context_right (subst y (S k) b)
      (traverse_list (subst y) k ts) (context_subst y (k + length ts) c)
  end.

Lemma same_path_context_subst:
  forall h i k,
  same_path h (context_subst i k h).
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - constructor.
    + apply IHh.
    + rewrite traverse_list_length.
      reflexivity.
  - constructor.
    + apply IHh.
    + rewrite traverse_list_length.
      reflexivity.
Qed.

Global Hint Resolve same_path_context_subst: cps.

Lemma context_subst_is_sound:
  forall (h: context) y k e,
  subst y k (h e) = context_subst y k h (subst y (#h + k) e).
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - rewrite subst_distributes_over_bind.
    f_equal.
    replace (S (#h + k)) with (#h + S k); try lia.
    apply IHh.
  - rewrite subst_distributes_over_bind.
    f_equal.
    replace (#h + length ts + k) with (#h + (k + length ts)); try lia.
    apply IHh.
Qed.

Lemma context_subst_bvars:
  forall h y k,
  #(context_subst y k h) = #h.
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - rewrite IHh; auto.
  - rewrite traverse_list_length.
    rewrite IHh; auto.
Qed.

Fixpoint context_right_cycle n k h: context :=
  match h with
  | context_hole =>
    context_hole
  | context_left b ts c =>
    context_left (context_right_cycle n (S k) b)
      (traverse_list (right_cycle n) k ts) (right_cycle n (k + length ts) c)
  | context_right b ts c =>
    context_right (right_cycle n (S k) b)
      (traverse_list (right_cycle n) k ts)
        (context_right_cycle n (k + length ts) c)
  end.

Lemma context_right_cycle_is_sound:
  forall (h: context) n k e,
  right_cycle n k (h e) =
    context_right_cycle n k h (right_cycle n (#h + k) e).
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - rewrite right_cycle_distributes_over_bind.
    f_equal.
    replace (S (#h + k)) with (#h + S k); try lia.
    apply IHh.
  - rewrite right_cycle_distributes_over_bind.
    f_equal.
    replace (#h + length ts + k) with (#h + (k + length ts)); try lia.
    apply IHh.
Qed.

Lemma context_right_cycle_bvars:
  forall h i k,
  #(context_right_cycle i k h) = #h.
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - f_equal.
    apply IHh.
  - rewrite traverse_list_length; f_equal.
    apply IHh.
Qed.

Lemma context_right_cycle_depth:
  forall h i k,
  context_depth (context_right_cycle i k h) = context_depth h.
Proof.
  induction h; simpl; auto.
Qed.

Fixpoint context_switch_bindings k h: context :=
  match h with
  | context_hole =>
    context_hole
  | context_left b ts c =>
    context_left (context_switch_bindings (S k) b)
      (traverse_list switch_bindings k ts) (switch_bindings (k + length ts) c)
  | context_right b ts c =>
    context_right (switch_bindings (S k) b)
      (traverse_list switch_bindings k ts) (context_switch_bindings (k + length ts) c)
  end.

Lemma context_switch_bindings_is_sound:
  forall (h: context) k e,
  switch_bindings k (h e) =
    context_switch_bindings k h (switch_bindings (#h + k) e).
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - rewrite switch_bindings_distributes_over_bind.
    f_equal.
    replace (S (#h + k)) with (#h + S k); try lia.
    apply IHh.
  - rewrite switch_bindings_distributes_over_bind.
    f_equal.
    replace (#h + length ts + k) with (#h + (k + length ts)); try lia.
    apply IHh.
Qed.

Lemma context_switch_bindings_bvars:
  forall h k,
  #(context_switch_bindings k h) = #h.
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - f_equal.
    apply IHh.
  - rewrite traverse_list_length; f_equal.
    apply IHh.
Qed.

Global Hint Resolve context_switch_bindings_bvars: cps.

Lemma context_switch_bindings_depth:
  forall h k,
  context_depth (context_switch_bindings k h) = context_depth h.
Proof.
  induction h; simpl; auto.
Qed.

Global Hint Resolve context_switch_bindings_depth: cps.

Lemma static_context_switch_bindings:
  forall h,
  static h ->
  forall k,
  static (context_switch_bindings k h).
Proof.
  induction 1; simpl; auto with cps.
Qed.

Global Hint Resolve static_context_switch_bindings: cps.

Lemma context_switch_bindings_is_involutive:
  forall h k,
  context_switch_bindings k (context_switch_bindings k h) = h.
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - f_equal.
    + apply IHh.
    + clear IHh.
      induction ts; auto.
      simpl; f_equal; auto.
      do 2 rewrite traverse_list_length.
      apply switch_bindings_is_involutive.
    + rewrite traverse_list_length.
      apply switch_bindings_is_involutive.
  - f_equal.
    + apply switch_bindings_is_involutive.
    + clear IHh.
      induction ts; auto.
      simpl; f_equal; auto.
      do 2 rewrite traverse_list_length.
      apply switch_bindings_is_involutive.
    + rewrite traverse_list_length.
      apply IHh.
Qed.

Inductive context_equals_lift h e1 i k: Prop :=
  | context_equals_lift_mk:
    forall r,
    same_path h r ->
    h = context_lift i k r ->
    forall e3,
    e1 = lift i (#h + k) e3 ->
    context_equals_lift h e1 i k.

Lemma context_equals_lift_inversion:
  forall (h: context) e1 e2 i k,
  h e1 = lift i k e2 ->
  context_equals_lift h e1 i k.
Proof.
  induction h; simpl; intros.
  - econstructor.
    + constructor.
    + reflexivity.
    + simpl; eauto.
  - destruct e2; try discriminate.
    + exfalso.
      destruct (le_gt_dec k n).
      * rewrite lift_bound_ge in H; auto.
        discriminate.
      * rewrite lift_bound_lt in H; auto.
        discriminate.
    + rewrite lift_distributes_over_bind in H.
      dependent destruction H.
      edestruct IHh as (r, ?, ?, e3, ?); eauto.
      eexists (context_left r ts0 _) e3; simpl.
      * constructor; auto.
        rewrite traverse_list_length; auto.
      * f_equal; auto.
      * rewrite H1; f_equal.
        lia.
  - destruct e2; try discriminate.
    + exfalso.
      destruct (le_gt_dec k n).
      * rewrite lift_bound_ge in H; auto.
        discriminate.
      * rewrite lift_bound_lt in H; auto.
        discriminate.
    + rewrite lift_distributes_over_bind in H.
      dependent destruction H.
      edestruct IHh as (r, ?, ?, e3, ?); eauto.
      eexists (context_right _ ts0 r) e3; simpl.
      * constructor; auto.
        rewrite traverse_list_length; auto.
      * f_equal; auto.
      * rewrite H1; f_equal.
        rewrite traverse_list_length; lia.
Qed.


Require Import ExtLib.Core.Type.
Require Import ExtLib.Data.PreFun.
Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Structures.CoFunctor.
Require Import ExtLib.Structures.Monoid.

Set Implicit Arguments.
Set Strict Implicit.

Global Instance proper_id (T : Type) {tT : type T} : proper (fun x => x).
Proof.
  repeat red; intros. apply H.
Qed.

Section functors.
  Variable A : Type.

  Instance FunFunctor A : Functor (Fun A) :=
  { fmap _A _B g f x := g (f x)
  }.

  Local Instance Functor_Fun : Functor (Fun A) :=
  { fmap _A _B g f x := g (f x) }.

  Local Instance CoFunctor_Fun T : CoFunctor (fun x => x -> T) :=
  {| cofmap := fun _ _ g f => fun x => f (g x) |}.

  Local Instance Functor_functor F G (fF : Functor F) (fG : Functor G) : Functor (fun x => F (G x)) :=
  {| fmap := fun _ _ g => @fmap F _ _ _ (@fmap G _ _ _ g) |}.

  Local Instance CoFunctor_functor F G (fF : Functor F) (fG : CoFunctor G) : CoFunctor (fun x => F (G x)) :=
  {| cofmap := fun _ _ g => @fmap F _ _ _ (@cofmap G _ _ _ g) |}.

  Local Instance Functor_cofunctor F G (fF : CoFunctor F) (fG : Functor G) : CoFunctor (fun x => F (G x)) :=
  {| cofmap := fun _ _ g => @cofmap F _ _ _ (@fmap G _ _ _ g) |}.

  Local Instance CoFunctor_cofunctor F G (fF : CoFunctor F) (fG : CoFunctor G) : Functor (fun x => F (G x)) :=
  {| fmap := fun _ _ g => @cofmap F _ _ _ (@cofmap G _ _ _ g) |}.

  Local Instance Applicative_Fun : Applicative (Fun A) :=
  { pure := fun _ x _ => x
  ; ap := fun _ _ f x y => (f y) (x y)
  }.

End functors.

Definition Monoid_compose T : Monoid (T -> T) :=
{| monoid_plus g f x := g (f x)
 ; monoid_unit x := x
|}.

Export PreFun.


Require Import GeoCoq.Axioms.continuity_axioms.
Require Import GeoCoq.Tarski_dev.Ch07_midpoint.

Section Dedekind_archimedes.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma archimedes_aux : (forall A B C, Out A B C -> Reach A B A C) -> archimedes_axiom.
Proof.
  intros Haux A B C D HAB.
  destruct (eq_dec_points C D).
    subst; exists B.
    split; Le.
    apply grad_init.
  destruct (segment_construction_3 A B C D) as [E [HOut HCong]]; auto.
  destruct (Haux A B E HOut) as [B' [HGrad HLe]]; trivial.
  exists B'.
  split; trivial.
  apply le_transitivity with A E; Le.
Qed.

Lemma dedekind__archimedes : (forall A B C D, ~ ~ Reach A B C D -> Reach A B C D) ->
  dedekind_s_axiom -> archimedes_axiom.
Proof.
  intros Hstab dedekind.
  apply archimedes_aux.
  intros A B C HOut.
  apply Hstab.
  intro HNReach.
  assert (HX : exists X, forall P Q, (Out A B P /\ ~ ~ Reach A B A P) ->
                                       (Out A B Q /\ ~ Reach A B A Q) -> Bet P X Q).
  { apply dedekind.
    exists A.
    intros X Y [HXOut HX] [HYOut HY].
    assert (HOut' : Out A X Y) by (apply l6_7 with B; [apply l6_6|]; trivial).
    destruct (HOut') as [_ [_ [|Habs]]]; trivial.
    exfalso.
    apply HX; clear HX.
    intro HX.
    apply HY.
    destruct HX as [B' [HGrad HLe]].
    exists B'; split; trivial.
    apply le_transitivity with A X; Le.
  }
  destruct HX as [X HX].
  assert_diffs.
  assert (HGrad := grad_init A B).
  assert (HBet : Bet B X C).
  { apply HX; split; trivial.
      apply out_trivial; auto.
    intro HAbs; apply HAbs.
    exists B; split; Le.
  }
  assert (Out A B X) by (apply out_bet_out_1 with C; auto).
  destruct HOut as [_ [_ [HBet2|HBet2]]]; [|exfalso; apply HNReach; exists B; split; Le].
  absurd (~ Reach A B A X).

  - intro HAbs.
    destruct (eq_dec_points X B).
      subst; apply HAbs; exists B; split; Le.
    destruct (le_cases X A A B) as [HLe|HLe].
      apply HAbs; exists B; split; Le.
    assert (Bet A B X) by (apply l6_13_1; Le).
    destruct HLe as [X0 [HBet1 HCong]].
    absurd (~ Reach A B A X0).
    { intro HNReach0.
      assert (HXOut : Out X X0 B).
        apply l6_7 with A; [|apply l6_6]; apply bet_out; Between.
        intro; treat_equalities; auto.
      destruct (le_cases X B X X0) as [HLe|HLe].
      - apply HNReach0; exists B; split; trivial.
        exists X0; split; Cong.
        apply between_inner_transitivity with X; Between.
        apply between_symmetry, l6_13_1; trivial.
        apply l6_6; trivial.
      - absurd (X = X0).
          assert_diffs; auto.
        apply between_equality with B.
          apply l6_13_1; trivial.
        apply between_symmetry, HX; split; trivial.
          apply out_trivial; auto.
          intro HN; apply HN; exists B; split; Le.
        apply l6_7 with X; trivial.
        apply l6_6, bet_out; Between.
        intro; subst X0; apply HNReach0.
        exists B; split; Le.
    }
    intro HReach.
    destruct HReach as [B' [HGrad' HLe]].
    destruct (segment_construction A B' A B) as [B1' [HBet' HCong']].
    apply HAbs; exists B1'; split.
      apply grad_stab with B'; Cong.
    apply bet2_le2__le1346 with X0 B'; Le; Between.
    apply cong__le, cong_transitivity with A B; Cong.

  - intro HReach.
    destruct (segment_construction_3 X C A B) as [X1 [HOut' HCong]]; auto.
      intro; subst; contradiction.
    assert (HBet1 : Bet A X X1).
      apply between_symmetry, bet_out__bet with C; eBetween.
    apply (not_bet_and_out X1 X C).
    split; [|apply l6_6; trivial].
    apply HX; split; trivial; [| |apply bet_out; auto].
    { apply l6_7 with X; trivial.
      assert_diffs; apply bet_out; auto.
    }
    destruct HReach as [B' [HGrad' HLe]].
    destruct (segment_construction A B' A B) as [B1' [HBet' HCong']].
    intro HAbs; apply HAbs.
    exists B1'; split.
      apply grad_stab with B'; Cong.
    apply bet2_le2__le1346 with X B'; Le.
    apply cong__le, cong_transitivity with A B; Cong.
Qed.

End Dedekind_archimedes.


Require Export ProjectiveGeometry.Dev.decidability.
Require Export Containers.SetInterface.
Require Export Containers.SetDecide.
Require Export Containers.SetProperties.

(*****************************************************************************)
(** SetOfPoints Structure **)

(*
Section s_SetOfPoints.

Class SetOfPoints  `(Op : ObjectPoint) `(Eq : EqDecidability Point) `(S : FSetSpecs Point).

End s_SetOfPoints.
*)

Section s_matroidRk.

Class MatroidRk `(Op : ObjectPoint) `(S : FSetSpecs Point) := {
rk : set Point -> nat
}.

End s_matroidRk.

Section s_SetOfPointsDef.

Context `(MR : MatroidRk).

Definition couple (x y : Point) : set Point :=
add x (add y (empty)).

Definition triple(x y t : Point) : set Point :=
add x (add y (add t empty)).

Definition quadruple (x y t u : Point) : set Point :=
add x (add y (add t  (add u empty))).

Definition quintuple (x y t u v : Point) : set Point :=
add x (add y (add t  (add u (add v empty)))).

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

Lemma couple_singleton_eq : forall x y, x [==] y ->
Equal (couple x y) (singleton x).
Proof.
intros;unfold couple;fsetdec.
Qed.

Lemma subset_exists : forall A B, Subset A B -> exists C, Equal (union A C) B.
Proof.
intros;exists (diff B A);fsetdec.
Qed.

Lemma couple_1 : forall a b, Equal (couple a b) (couple b a).
Proof.
intros;unfold couple;fsetdec.
Qed.

Lemma triple_1 : forall a b c, Equal (triple a b c) (triple a c b).
Proof.
intros;unfold triple;fsetdec.
Qed.

Lemma triple_2 : forall a b c, Equal (triple a b c) (triple b a c).
Proof.
intros;unfold triple;fsetdec.
Qed.

Lemma triple_3 : forall a b c, Equal (triple a b c) (triple b c a).
Proof.
intros;unfold triple;fsetdec.
Qed.

Lemma triple_4 : forall a b c, Equal (triple a b c) (triple c a b).
Proof.
intros;unfold triple;fsetdec.
Qed.

Lemma triple_5 : forall a b c, Equal (triple a b c) (triple c b a).
Proof.
intros;unfold triple;fsetdec.
Qed.

Lemma triple_couple_1 : forall a b, Equal (triple a b b) (couple a b).
Proof.
intros;unfold couple, triple;fsetdec.
Qed.

Lemma triple_couple_2 : forall a b, Equal (triple a b b) (couple b a).
Proof.
intros;unfold couple, triple;fsetdec.
Qed.

Lemma triple_couple_3 : forall a b, Equal (triple b a b) (couple a b).
Proof.
intros;unfold couple, triple;fsetdec.
Qed.

Lemma triple_couple_4 : forall a b, Equal (triple b a b) (couple b a).
Proof.
intros;unfold couple, triple;fsetdec.
Qed.

Lemma triple_couple_5 : forall a b, Equal (triple b b a) (couple a b).
Proof.
intros;unfold couple, triple;fsetdec.
Qed.

Lemma triple_couple_6 : forall a b, Equal (triple b b a) (couple b a).
Proof.
intros;unfold couple, triple;fsetdec.
Qed.

Lemma inter_test : forall a b, Equal (inter (singleton a) (couple a b)) (singleton a).
Proof.
intros;unfold couple. fsetdec.
Qed.

Lemma inter_fsetdecide_1 : forall A B C D, ~ A [==] B ->
Equal (inter (triple A C D) (triple B C D)) (couple C D).
Proof.
intros;unfold couple, triple;fsetdec.
Qed.

Lemma inter_fsetdecide_2 : forall A B C alpha beta, ~ alpha [==] beta ->
Equal (inter (union (triple A B C) (singleton alpha))
  (union (triple A B C) (singleton beta))) (triple A B C).
Proof.
intros;unfold triple;fsetdec.
Qed.

Lemma inter_fsetdecide_3 : forall A B C alpha beta gamma,
 ~ alpha [==] gamma ->
 ~ beta [==] gamma ->
Equal (inter (union (triple A B C) (couple alpha beta))
  (union (triple A B C) (singleton gamma))) (triple A B C).
Proof.
intros;unfold couple, triple; fsetdec.
Qed.

Lemma inter_fsetdecide_4 : forall ps, forall alpha beta : Point,
 ~ alpha [==] beta ->
Equal (inter (union ps (singleton alpha)) (union ps (singleton beta))) ps.
Proof.
intros;fsetdec.
Qed.

Lemma inter_fsetdecide_5 : forall ps, forall alpha beta gamma : Point,
 ~ alpha [==] gamma ->
 ~ beta [==] gamma ->
Equal (inter (union ps (couple alpha beta)) (union ps (singleton gamma))) ps.
Proof.
intros;unfold couple;fsetdec.
Qed.

Lemma union_fsetdecide : forall A0 B0 A1 B1 A C,
Equal (union (union (quadruple A0 B0 A1 B1) (triple A0 B0 A))
           (triple A1 B1 C)) (union (quadruple A0 B0 A1 B1) (couple A C)).
intuition.
intuition.
Proof.
intros; split; intros.
unfold couple, triple, quadruple in *; fsetdec.
unfold couple, triple, quadruple in *; fsetdec.
Qed.

End s_SetOfPointsDef.

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

Hint Immediate
   triple_1 triple_2 triple_3 triple_4 triple_5
   triple_couple_1 triple_couple_2 triple_couple_3
   triple_couple_4 triple_couple_5  triple_couple_6
   couple_1
 : hset.

Hint Resolve inter_fsetdecide_1 inter_fsetdecide_2
                      inter_fsetdecide_3 inter_fsetdecide_4
                      inter_fsetdecide_5 : hset.

Ltac fsetdecide := (solve [auto with hset]) || (unfold couple, triple, quadruple in *; fsetdec).


From mathcomp Require Import ssreflect ssrnat ssrbool eqtype.
From deriving Require Import deriving.

Require Import type.

Time Definition tree_indDef := [indDef for tree_rect].
Canonical tree_indType := IndType tree tree_indDef.

Module nored.

(* see https://github.com/arthuraa/deriving#simplification-and-performance-issues *)
Definition tree_eqMixin : Equality.mixin_of tree.
Proof. Time exact [derive nored eqMixin for tree]. Time Defined. (* -> does not reduce with QED *)

Canonical tree_eqType := EqType tree tree_eqMixin.

Eval vm_compute in t0 == t1.
Time Eval vm_compute in t0 == t0.
Time Eval vm_compute in t0 == t1.

End nored.

Optimize Heap.

Module red.

Time Definition tree_eqMixin := [derive eqMixin for tree].
Canonical tree_eqType := EqType tree tree_eqMixin.

Eval vm_compute in t0 == t1.
Time Eval vm_compute in t0 == t0.
Time Eval vm_compute in t0 == t1.

End red.


(*common header begin*)
Require Import Utf8.
From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Maximal Implicit Insertion.

Require Import List.
Import ListNotations.
(*common header end*)

Require Export Formula.
Require Export Term.

Require Import Omega.

Require Import ListFacts.
Require Import UserTactics.
Require Import MiscFacts.

Definition environment : Set := list (label * formula').

Definition fresh_in_environment (x : label) (Γ : environment) := Forall (fun (e : label * formula') => let (y, _) := e in x <> y) Γ.

(*first paramater n contains an upper bound on the derivation depth*)
Inductive derivation : nat -> environment -> term -> formula -> Prop :=
  | ax : forall (n : nat) (Γ: environment) (x : label) (phi: formula') (t : formula),
    In (x, phi) Γ -> In t phi -> derivation n Γ (free_var x) t
  | intro_arr : forall (n : nat) (Γ: environment) (M : term) (phi : formula') (t : formula),
    (forall (x : label), derivation n ((x, phi) :: Γ) (instantiate x 0 M) t) -> derivation (S n) Γ (term_abs M) (arr phi t)
  | elim_arr : forall (n : nat) (Γ: environment) (M N : term) (phi : formula') (t : formula),
    derivation n Γ M (arr phi t) -> Forall (derivation n Γ N) phi -> derivation (S n) Γ (term_app M N) t.

(*
Conjecture normalization : forall (m : nat) (Γ: environment) (M :term) (t: formula),
  derivation m Γ M t -> exists (n : nat) (N : term), normal_form N /\ derivation n Γ N t.
*)

(*environments may be extended or permuted*)
Theorem weakening : forall (n : nat) (Γ Γ': environment) (M: term) (t: formula),
  derivation n Γ M t -> (forall (p : label * formula'), In p Γ -> In p Γ') -> derivation n Γ' M t.
Proof.
elim.
(*base case*)
intros *.
inversion.
move /(_ _ ltac:(eassumption)).
eauto using derivation.

move => n IH.
intros *; inversion.
move /(_ _ ltac:(eassumption)).
eauto using derivation.
move => H_in.
apply intro_arr.
move => x; apply : IH. eauto.
move => p.
move /(_ p) : H_in.
list_inclusion.

move => ?.
move /(_ Γ Γ' _ _ _ ltac:(eassumption)) : (IH).
move /(_ Γ Γ' _ _ ltac:(eassumption) ltac:(eassumption)) : IH.
intros.
apply : elim_arr; try eassumption.
gimme Forall; rewrite ? Forall_forall.
auto.
Qed.

Fixpoint term_label_bound (M : term) : nat :=
  match M with
  | (free_var (_, n)) => 1+n
  | (bound_var _) => 0
  | (term_app M N) => (term_label_bound M) + (term_label_bound N)
  | (term_abs M) => term_label_bound M
  end.

Fixpoint environment_label_bound (Γ : environment) : nat :=
  match Γ with
  | [] => 0
  | (((_, n), _) :: Γ) => 1 + n + environment_label_bound Γ
  end.

Lemma exists_fresh : forall (M : term) (Γ : environment), exists (x : label), fresh_in x M /\ fresh_in_environment x Γ.
Proof.
move => M Γ.
exists (0, term_label_bound M + environment_label_bound Γ).
split.
{
move : (environment_label_bound Γ) => m.
clear; elim : M m; cbn.

case; intros; constructor.
case; intros; omega.

intros; constructor.

move => M IHM N IHN m; constructor.
rewrite <- Nat.add_assoc; auto.
have : term_label_bound M + term_label_bound N + m = term_label_bound N + (term_label_bound M + m) by omega.
move => ->; auto.

eauto using fresh_in.
}
{
move : (term_label_bound M) => m.
clear; elim : Γ m; cbn.

intros; constructor.

case; case; intros; constructor.
case; omega.
have : forall a b c, a + S (b + c) = (1+a+b) + c by intros; omega.
move => ->.
gimme where fresh_in_environment; apply.
}
Qed.

Lemma fresh_abstraction : forall (x : label) (n : nat) (Γ : environment) (M : term) (phi : formula') (t : formula),
  fresh_in x M -> fresh_in_environment x Γ ->
  derivation n ((x, phi) :: Γ) (instantiate x 0 M) t ->
  derivation (S n) Γ (term_abs M) (arr phi t).
Proof.
intros.
apply : intro_arr.
move => y.
gimme derivation.
move : (0) => m.
revert dependent x => x.
move : x y Γ M phi t m.
apply (lt_wf_ind n).

move => {n} n IH; intros; gimme derivation; inversion.
{(*case M is var*)
revert dependent M.
case; cbn; try done.
intro; inversion; case.
intro; subst.
gimme In where x; inversion.
gimme @eq; case; done.
gimme In; move /(in_cons (y, phi)).
eauto using derivation.

move => i _.
case : (i =? m).
case; intro; subst.
gimme In where x.
inversion.
gimme @eq; case; intro; subst.
apply : ax; try eassumption.
by constructor.

exfalso; gimme fresh_in_environment; move /Forall_forall.
by move /(_ _ ltac:(eassumption)).

inversion.
}

{(*case M is abs*)
revert dependent M.
case; cbn; try done.

move => i; case : (i =? m); done.

move => M'; inversion.
case; intro; subst.
apply : intro_arr => z'.
match goal with [ |- derivation _ ((z', ?phi') :: _) _ _] => rename phi' into psi end.

have := exists_fresh M' ((x, phi) :: (y, phi) :: Γ) => [[z [?]]].
inversion.
apply : (IH); try eassumption + omega.
clear z'.
gimme Forall; inversion.
apply : fresh_in_instantiate; done.

apply (weakening (Γ := ((y, phi) :: (z, psi) :: Γ))); last list_inclusion.
gimme where psi.
move /(_ z) /(weakening (Γ' := ((x, phi) :: (z, psi) :: Γ))).
nip; first list_inclusion.
rewrite ? (swap_instantiations z); try omega.
apply : IH.

omega.
apply : fresh_in_instantiate; auto.

constructor; auto.
}
{(*case M is app*)
revert dependent M.
case; cbn; try done.

move => i; case : (i =? m); done.

move => M' N'; inversion; case; intros; subst.
gimme derivation; move /IH.
nip; first omega.
move /(_ y ltac:(assumption) ltac:(assumption)) => ?.
apply : elim_arr; try eassumption.
gimme Forall.
rewrite ? Forall_forall => ? ? ?.
apply : IH; try omega + eauto.
}
Qed.

(*only locally closed (well-formed) terms are typable*)
Theorem derivation_lc : forall (n : nat) (M : term) (Γ : environment) (t : formula), derivation n Γ M t -> lc 0 M.
Proof.
move => n.
apply (lt_wf_ind n).
move => {n} n IH.
intros *; inversion.

auto using lc.

constructor.
gimme where instantiate; move /(_ (0,0)).
move /IH.
nip; first omega.
move /Lc.instantiate_iff. apply.

gimme Forall; move /forall_exists_in_formula' => [? [? ?]].
constructor; eauto.
Qed.

(*it suffices to bind a fresh variable wrt. environment*)
Theorem fresh_abstraction_bind : forall (x : label) (n : nat) (Γ : environment) (M : term) (phi : formula') (t : formula),
  fresh_in_environment x Γ ->
  derivation n ((x, phi) :: Γ) M t ->
  derivation (S n) Γ (term_abs (bind x 0 M)) (arr phi t).
Proof.
intros.

apply : fresh_abstraction; try eassumption.
apply : fresh_in_bind.
rewrite Lc.instantiate_bind.
apply : derivation_lc; eassumption.
done.
Qed.

Lemma derivation_relax_depth : forall (n m : nat) (Γ: environment) (M : term) (t : formula),
  derivation n Γ M t -> n <= m -> derivation m Γ M t.
Proof.
move => n.
apply (lt_wf_ind n).
move => {n} n IH; intros.
gimme derivation; inversion.

eauto using derivation.

all: have : m = S (Nat.pred m) by omega.
all: move => ->.

apply : intro_arr.
move => x; gimme where derivation; move /(_ x) => ?.
apply : IH; try eassumption; omega.

apply : elim_arr.
apply: IH; try eassumption; omega.
apply : Forall_impl; last eassumption.
intros; apply : IH; try eassumption; omega.
Qed.


(************************************************************************************)
(**                                                                                *)
(**                             The DatalogCert Library                             *)
(**                                                                                *)
(**             CNRS & Université Paris-Sud, Université Paris-Saclay                *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Original authors: Véronique Benzaken                                    *)
(**                           Évelyne Contejean                                     *)
(**                           Stefania Dumbrava                                     *)
(**                                                                                *)
(************************************************************************************)

(** Third part of the original file "pengine.v" with some modifications *)

Require Import utils.
Require Import syntax.
Require Import subs.
Require Import finseqs.

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun choice fintype.
From mathcomp
Require Import tuple finset bigop finfun.

Require Import bigop_aux.

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

(** * constructive match *)
Section Match.

Implicit Types (s : sub) (t : term) (a : atom) (v : 'I_n)
         (b : 'I_n * syntax.constant) (i : interp).

(** ** match on terms *)
(** matching a term [t] against a constant [d], starting from an initial substitution [s]. *)
Definition match_term d t s : option sub :=
  match t with
  | Val e => if d == e then Some s else None
  | Var v => if s v is Some e then
             (if d == e then Some s else None)
             else Some (add s v d)
  end.

(** Let [s1], [s2] be two substitutions. If [s2] is the result of matching a term [t]
against a constant [d], starting from an initial substitution [s1], then [s2] extends [s1]. *)
Lemma match_term_sub s1 s2 t d : match_term d t s1 = Some s2 -> sub_st s1 s2.
Proof.
case: t => //= [v|e]; last first.
  by case: eqP => _ // [->].
case E: (s1 _) => /= [a|].
  by case: eqP => _ // [->].
by case=> <-; have/eqP/sub_add := E.
Qed.

(** ** Generalization to raw atoms *)
(** matching a raw atom [ra] against a ground raw atom [rga], starting from an initial substitution [s]. *)
Definition match_raw_atom s ra rga : option sub :=
  match ra, rga with
    | RawAtom s1 arg1, RawGAtom s2 arg2 =>
      if (s1 == s2) && (size arg1 == size arg2)
      then foldl (fun acc p => obind (match_term p.1 p.2) acc)
                 (Some s) (zip arg2 arg1)
      else None
  end.

(** matching an [a] against a ground atom [ga], starting from an initial substitution [s]. *)
Definition match_atom s a (ga : gatom) := match_raw_atom s a ga.

(** matching an atom [a] against all the ground atoms of an interpretation [i], starting from an
initial substitution [s] *)
Definition match_atom_all (i : interp) a s :=
  [set x | Some x \in [set opt_sub (match_atom s a ga) | ga in i]].

(** reflection lemma for atom matching *)
Lemma match_atomsP a i r s :
  reflect (exists2 ga, ga \in i & Some r = match_atom s a ga)
          (r \in match_atom_all i a s).
Proof. by rewrite inE; exact: (iffP imsetP). Qed.

(** join for the set monad *)
Definition bindS {A B : finType} (i : {set A}) (f : A -> {set B}) : {set B} :=
  cover [set f x | x in i].

(** reflection lemma for binding *)
Lemma bindP (A B : finType) (i : {set A}) (f : A -> {set B}) (r : B) :
  reflect (exists2 s, s \in i & r \in f s) (r \in bindS i f).
Proof.
by rewrite /bindS cover_imset; exact: (iffP bigcupP); case=> s xin rin; exists s.
Qed.

(** monadic fold for the set monad: iteratively composing the result of applying a function [f],
seeded with an initial value [s0], to all elements of a list [l] *)
Fixpoint foldS {A : Type} {B : finType}
         (f : A -> B -> {set B}) (s0 : {set B}) (l : seq A) :=
  if l is [:: x & l] then bindS s0 (fun y => foldS f (f x y) l)
  else s0.

(** If functions [f] and [g] are extensionally equal, then we get the same output when binding
a set [s] with them. *)
Lemma eq_bindS (A B : finType) (f g : A -> {set B}) (s : {set A}) :
  f =1 g -> bindS s f = bindS s g.
Proof.
move=> h_f; apply/setP=> x; rewrite /bindS !cover_imset.
by apply/bigcupP/bigcupP; case=> y y_in x_in; exists y; rewrite // ?h_f // -h_f.
Qed.

(** The result of binding the union of two sets [s1] and [s2] with a function [f]
equals the result of taking the union between the binding of [s1] with [f] and
the binding of [s2] with [f] *)
Lemma bindSU (A B : finType) (f : A -> {set B}) (s1 s2 : {set A}) :
  bindS (s1 :|: s2) f = bindS s1 f :|: bindS s2 f.
Proof. by rewrite /bindS !cover_imset bigcup_setU. Qed.

(** Let [s] be a set and [f], [g] two functions. The result of taking the union
between the binding of [s] with [f] and the binding of [s] with [g] equals the
binding of [s] with the function that returns the point-wise union of [f] and [g] application *)
Lemma bindUS (A B : finType) (f g : A -> {set B}) (s : {set A}) :
  bindS s f :|: bindS s g = bindS s (fun x => f x :|: g x ).
Proof.
rewrite /bindS !cover_imset; apply/setP=> x; rewrite !inE; apply/orP/bigcupP.
  by case=> /bigcupP[y hy hfy]; exists y; rewrite // inE hfy ?orbT.
by case=> [y hy]; rewrite inE; case/orP=> hf; [left | right]; apply/bigcupP; exists y.
Qed.

(** If [f] and [g] are extensionally equal, then the results of taking their fold over a list [l],
seeded with an initial set [s], are equal *)
Lemma eq_foldS (A : eqType) (T : finType) f g (s : {set T}) (l : seq A) :
  {in l, f =2 g} -> foldS f s l = foldS g s l.
Proof.
move=> h_f; elim: l s h_f => //= x l ihl s h_f.
have heq: (fun y : T => foldS f (f x y) l) =1
          (fun y : T => foldS g (g x y) l).
  move=> y; rewrite h_f ?inE ?eqxx ?ihl //.
  by move=> u hu k; rewrite h_f // inE hu orbT.
by rewrite (eq_bindS _ heq).
Qed.

(** The result of folding a function [f] over a list [l], starting from the union
of sets [s1] and [s2] equals the union of folding [f] over [l] starting from [s1]
and of folding [f] over [l] starting from [s2] *)
Lemma foldSU A (T : finType) f (s1 s2 : {set T}) (l : seq A) :
  foldS f (s1 :|: s2) l = foldS f s1 l :|: foldS f s2 l.
Proof. by elim: l => //= x l ihl; rewrite bindSU. Qed.

(** matching a list of atoms [tl]Z agains ground atoms of an interpretation [i] *)
Definition match_body i tl : {set sub} :=
  foldS (match_atom_all i) [set emptysub] tl.

(** * boolean match - Added *)

(** A default constant that will not be really used *)
Variable def : syntax.constant.

(** [bmatch i cl s] iff for every atom [a] of [cl] body [s a]
   is i [i] *)
Definition bmatch i cl s : bool :=
  (** if s does not cover tl's variables, no *)
  (** otherwise, it's okay to cast s to gr with a random constant *)
   (cl_vars cl \subset dom s)
&& all (mem i) (gr_tl (to_gr def s) (body_cl cl)).

End Match.


From HoTT Require Import Basics.
From HoTT Require Import Categories.
From HoTT Require Import Categories.Category.Morphisms.
Declare ML Module "diagrams_plugin".
Local Open Scope morphism.

Definition mphT (C : PreCategory) (a b : C) := @morphism C a b.
Definition comp (C : PreCategory) (a b c : C) (m1 : mphT C a b) (m2 : mphT C b c) : mphT C a c :=
  @HoTT.Categories.compose C a b c m2 m1.

Lemma compose_eq (C : PreCategory) (a b c : C) (m1 m2 : morphism C a b) (m3 m4 : morphism C b c)
      (p1 : m1 = m2) (p2 : m3 = m4) : comp C a b c m1 m3 = comp C a b c m2 m4.
Proof. f_ap. Defined.
Definition assoc (C : PreCategory) (a b c d : C)
      (m1 : morphism C a b) (m2 : morphism C b c) (m3 : morphism C c d) :
  comp C a c d (comp C a b c m1 m2) m3 = comp C a b d m1 (comp C b c d m2 m3)
  := (associativity C a b c d m1 m2 m3)^.

Definition id (C : PreCategory) (a : C) : morphism C a a := @identity C a.
Definition left_id (C : PreCategory) (a b : C) (m : morphism C a b) :
  comp C a b b m (id C b) = m := left_identity C a b m.
Definition right_id (C : PreCategory) (a b : C) (m : morphism C a b) :
  comp C a a b (id C a) m = m := right_identity C a b m.

Definition r_ap (C : PreCategory) (a b c : C) (m : morphism C a b) (m1 m2 : morphism C b c) :
  m1 = m2 -> m1 o m = m2 o m := fun p => ap (fun m' => m' o m) p.
Definition l_ap (C : PreCategory) (a b c : C) (m1 m2 : morphism C a b) (m : morphism C b c) :
  m1 = m2 -> m o m1 = m o m2 := fun p => ap (fun m' => m o m') p.

Definition mph_inv (C : PreCategory) (a b : C) (m : morphism C a b) (H : IsIsomorphism m) :
  morphism C b a := @morphism_inverse C a b m H.
Definition right_inv (C : PreCategory) (a b : C) (m : morphism C a b) (H : IsIsomorphism m) :
  m^-1 o m = 1 :=
  @left_inverse C a b m H.
Definition left_inv (C : PreCategory) (a b : C) (m : morphism C a b) (H : IsIsomorphism m) :
  m o m^-1 = 1 :=
  @right_inverse C a b m H.

Ltac reify_hyp H :=
  unfold mphT in H; unfold comp in H; unfold compose_eq in H; unfold assoc in H;
  unfold id in H; unfold left_id in H; unfold right_id in H;
  unfold r_ap in H; unfold l_ap in H;
  unfold mph_inv in H; unfold right_inv in H; unfold left_inv in H.
Ltac reify :=
  unfold mphT; unfold comp; unfold compose_eq; unfold assoc;
  unfold id; unfold left_id; unfold right_id;
  unfold r_ap; unfold l_ap;
  unfold mph_inv; unfold right_inv; unfold left_inv.


(*
   Copyright 2001, 2009 Luc Rutten

   This file is part of ModRed.

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

   ModRed is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public License
   along with ModRed.  If not, see <http://www.gnu.org/licenses/>.
*)

(*
   Fast reduction of integers in Z_(2 ^ (log_sup M + w)))
   by moduli M such that 1 <= M <= 2 ^ (w - 1)
   where w denotes a processor's word size.
*)

(* Coq 8.2 *)

Require Import ZArith.

Require Import preparation.
Require Import unsigned.

Open Scope Z_scope.

Section parm_sec.

Variable M_in_Z_ : Z_ (2 ^ w).
Variable ptM' : Z_ w * Z_ w * Z_ (2 ^ w).
Variables v_in_Z_ u_in_Z_ : Z_ (2 ^ w).

Let p_in_Z_w := fst (fst ptM').
Let t_in_Z_w := snd (fst ptM').
Let M'_in_Z_ := snd ptM'.

Let M := _Z M_in_Z_.
Let p := _Z p_in_Z_w.
Let t := _Z t_in_Z_w.
Let M' := _Z M'_in_Z_.
Let v := _Z v_in_Z_.
Let u := _Z u_in_Z_.

Hypothesis le_1_M : 1 <= M.
Hypothesis le_M_max : M <= 2 ^ (w - 1).
Hypothesis p_M : p = Zlog_sup M.
Hypothesis t_M : t = w - p \/ M = 1.
Hypothesis M'_M : M' = 2 ^ (p + w) / M mod 2 ^ w.
Hypothesis v_M : v < 2 ^ p.

Let x := v * 2 ^ w + u.

Lemma le_0_p : 0 <= p.

  unfold p. apply le_0__Z. Qed.

Lemma le_0_l : 0 <= u.

  unfold u. apply le_0__Z. Qed.

Lemma lt_l_2w : u < 2 ^ w.

  unfold u. apply lt_z__Z. Qed.

Lemma le_0_v : 0 <= v.

  unfold v. apply le_0__Z. Qed.

Lemma lt_v_2w : v < 2 ^ w.

  unfold v. apply lt_z__Z. Qed.

Lemma le02w : 0 <= 2 ^ w.

  apply Zlt_le_weak. exact lt02w. Qed.

Local Hint Resolve le_0_w lt02w le02w : a.
Local Hint Resolve le_0_p le_0_l lt_l_2w le_0_v lt_v_2w : a.

Lemma le_0_x : 0 <= x.

  unfold x. fold (0 + 0). apply Zplus_le_compat; auto with a. apply Zmult_le_0_compat; auto with a. Qed.

Local Hint Resolve le_0_x : a.

(* <KEEP TOGETHER - modred_equations *)
Let s := ursh u_in_Z_ p_in_Z_w.

Let s' := multp2 s p_in_Z_w.

Let h := multp2 v_in_Z_ t_in_Z_w.

Let h' := plusw h s.

Let q := uhwm h' M'_in_Z_.

Let q' := plusw q h'.

Let y := multw q' M_in_Z_.

Let d := minusw s' y.

Let r := minusw u_in_Z_ y.

Let r' := ltw d M_in_Z_ r (minusw r M_in_Z_).

Let r'' := ltw r' M_in_Z_ r' (minusw r' M_in_Z_).

Let r''' := ltw r'' M_in_Z_ r'' (minusw r'' M_in_Z_).
(* KEEP TOGETHER> *)

Definition ModRed := _Z r'''. (* keeps _Z out of ModRed_eq *)

Lemma l_eq : u = x mod 2 ^ w.

  unfold x. rewrite Zmod_km_plus. symmetry. apply modred. auto with a. auto with a. auto with a. Qed.

Lemma v_eq : v = x / 2 ^ w.

  unfold x. rewrite Zdiv_times_plus. rewrite Zdiv_small_0. ring. auto with a. auto with a. auto with a. Qed.

(* <KEEP TOGETHER - s_eq *)
Lemma s_eq : _Z s = x mod 2 ^ w / 2 ^ p.
(* KEEP TOGETHER> *)

  simpl. fold u. fold p. rewrite l_eq. trivial. Qed.

Lemma lt_0_2ppw : 0 < 2 ^ (p + w).

  apply lt_0_Zpow. fold (0 + 0). apply Zplus_le_compat; auto with a. Qed.

Lemma lt_0_2pp : 0 < 2 ^ p.

  apply lt_0_Zpow. auto with a. Qed.

Local Hint Resolve lt_0_2pp : a.

Lemma lt_x_xmax : x < 2 ^ (p + w).

  unfold x. apply Zle_lt_trans with ((2 ^ p - 1) * 2 ^ w + (2 ^ w - 1)). apply Zplus_le_compat.
  apply Zmult_le_compat. auto with a. auto with a. cut (v < 2 ^ p). omega. auto with a. omega. auto with a.
  auto with a. cut (u < 2 ^ w). omega. auto with a. rewrite Zmult_minus_distr_r. rewrite <- Zpower_exp.
  omega. auto with a. apply Zle_ge. auto with a. apply Zle_ge. auto with a. Qed.

Lemma le_x_xmax : x <= 2 ^ (p + w) - 1.

  cut (x < 2 ^ (p + w)). omega. exact lt_x_xmax. Qed.

Local Hint Resolve lt_x_xmax le_x_xmax : a.

Lemma le_0_wm1 : 0 <= w - 1.

  cut (0 < w). omega. exact lt_0_w. Qed.

Local Hint Resolve le_0_wm1 lt_0_w : a.

Lemma lt_p_w : p < w.

  rewrite p_M. apply Zle_lt_trans with (w - 1). rewrite <- Zlog_sup_pow. apply Zlog_sup_seq.
  assumption. auto with a. omega. Qed.

Lemma le_p_w : p <= w.

  apply Zlt_le_weak. exact lt_p_w. Qed.

Lemma le_0_wmp : 0 <= w - p.

  cut (p <= w). omega. exact le_p_w. Qed.

Local Hint Resolve lt_p_w le_p_w le_0_wmp : a.

(* <KEEP TOGETHER - s'_eq *)
Lemma s'_eq : _Z s' = x mod 2 ^ w - x mod 2 ^ p.
(* KEEP TOGETHER> *)

  unfold s'. rewrite Z_from_multp2. fold p. rewrite s_eq. rewrite Zmult_comm. rewrite modred.
  replace (x mod 2 ^ p) with (x mod 2 ^ w mod 2 ^ p). apply Zdiv_a_b_b_Zmod. auto with a.
  replace (2 ^ w) with (2 ^ (w - p) * 2 ^ p). apply Zmod_prod_Zmod. apply lt_0_Zpow. auto with a.
  auto with a. rewrite <- Zpower_exp. apply f_equal2 with (f := Zpower). trivial. ring. apply Zle_ge.
  auto with a. apply Zle_ge. auto with a. fold (0 * 0). apply Zmult_le_compat. apply Zle_0_div.
  apply Zmod_le_0_z. auto with a. auto with a. apply Zlt_le_weak. auto with a. omega. omega.
  apply Zle_lt_trans with (x mod 2 ^ w). rewrite Zmult_comm. apply Z_mult_div_ge. apply Zlt_gt.
  auto with a. apply Zmod_lt_z_m. auto with a. Qed.

(* <KEEP TOGETHER - h_eq *)
Lemma h_eq : _Z h = x / 2 ^ w * 2 ^ (w - p).
(* KEEP TOGETHER> *)

  simpl. fold t v. elim t_M; intro H. rewrite H. rewrite <- v_eq. rewrite Zmult_comm. apply modred.
  fold (0 * 0). apply Zmult_le_compat. auto with a. apply Zlt_le_weak. apply lt_0_Zpow. auto with a. omega.
  omega. apply Zlt_le_trans with (2 ^ p * 2 ^ (w - p)). apply Zmult_lt_compat_r. auto with a.
  apply lt_0_Zpow. auto with a. assumption. rewrite <- Zpower_exp. replace (p + (w - p)) with w. omega.
  ring. apply Zle_ge. auto with a. apply Zle_ge. auto with a. rewrite H in p_M. simpl in p_M.
  rewrite p_M in v_M. replace (2 ^ 0) with 1 in v_M. cut (v = 0). intro H0. unfold x. rewrite H0.
  replace (2 ^ t * 0) with 0. simpl. rewrite Zdiv_small_0. simpl. apply modred. omega. auto with a.
  auto with a. auto with a. ring. cut (0 <= v). omega. unfold v. apply le_0__Z. ring. Qed.

(* <KEEP TOGETHER - h'_eq *)
Lemma h'_eq : _Z h' = x / 2 ^ p.
(* KEEP TOGETHER> *)

  unfold h'. rewrite Z_from_plusw. rewrite h_eq. simpl. fold u p. rewrite l_eq. rewrite <- Zdiv_times_plus.
  rewrite <- Zmult_assoc. rewrite <- Zpower_exp. replace (w - p + p) with w. rewrite Zdivmod_split.
  apply modred. apply Zle_0_div. auto with a. auto with a. apply Zlt_le_trans with (2 ^ (p + w) / 2 ^ p).
  apply Zle_lt_trans with ((2 ^ (p + w) - 1) / 2 ^ p). apply Zdiv_le. auto with a. cut (x < 2 ^ (p + w)).
  omega. auto with a. rewrite Zpower_exp. rewrite Zmult_comm. rewrite Zdiv_mult_minus. rewrite Z_div_mult.
  omega. apply Zlt_gt. auto with a. auto with a. omega. cut (0 < 2 ^ p). omega. auto with a. apply Zle_ge.
  auto with a. apply Zle_ge. auto with a. rewrite Zpower_exp. rewrite Zmult_comm. rewrite Z_div_mult.
  omega. apply Zlt_gt. auto with a. apply Zle_ge. auto with a. apply Zle_ge. auto with a. auto with a.
  ring. apply Zle_ge. auto with a. apply Zle_ge. auto with a. auto with a. Qed.

(* <KEEP TOGETHER - q_eq *)
Lemma q_eq :
  _Z q = x / 2 ^ p * (2 ^ (p + w) / M mod 2 ^ w) / 2 ^ w.
(* KEEP TOGETHER> *)

  unfold q. rewrite uhwm_eq. rewrite h'_eq. fold M'. rewrite M'_M. trivial. Qed.

Lemma le_M_2pp : M <= 2 ^ p.

  rewrite p_M. generalize le_1_M. case M. intro. absurd (2 <= 0); omega. intros q0 H.
  elim (Zlog_sup_correct2 (Zpos q0)). omega. omega. intros q0 H. absurd (2 <= Zneg q0). apply Zlt_not_le.
  unfold Zlt. trivial. assumption. Qed.

Lemma le_1_p : 1 <= p \/ M = 1.

  rewrite p_M. elim (Zle_lt_or_eq 1 M). intro H. left. apply Zle_trans with (Zlog_sup 2). simpl. omega.
  apply Zlog_sup_seq. omega. intro H. right. symmetry. trivial. assumption. Qed.

Lemma lt_0_p : 0 < p \/ M = 1.

  elim le_1_p; intro H; omega. Qed.

Lemma le_0_pm1 : 0 <= p - 1 \/ M = 1.

  elim lt_0_p; intro H; omega. Qed.

Local Hint Resolve le_M_2pp le_1_p lt_0_p le_0_pm1 : a.

Lemma lt_2pm1_M : 2 ^ (p - 1) < M \/ M = 1.

  elim (Zle_lt_or_eq 1 M). intro H. rewrite p_M. generalize le_1_M. case M. intro. absurd (2 <= 0); omega.
  intros q0 H0. elim (Zlog_sup_correct2 (Zpos q0)). omega. omega. intros q0 H0. absurd (1 <= Zneg q0).
  apply Zlt_not_le. unfold Zlt. trivial. assumption. omega. assumption. Qed.

Local Hint Resolve lt_2pm1_M : a.

Lemma div_M_1 : 2 ^ p / M = 1.

  elim (Zle_lt_or_eq 1 M). intro H. replace (2 ^ p) with (1 * M + (2 ^ p - M)). apply Zdiv_mult_plus. omega.
  cut (M <= 2 ^ p). omega. auto with a. cut (2 ^ p < M + M). omega.
  apply Zlt_le_trans with (2 ^ (p - 1) + 1 + (2 ^ (p - 1) + 1)).
  replace (2 ^ (p - 1) + 1 + (2 ^ (p - 1) + 1)) with (2 ^ (p - 1) + 2 ^ (p - 1) + 2). rewrite Z_pow_plus.
  replace (p - 1 + 1) with p. omega. ring. elim le_0_pm1. omega. intro H0. absurd (1 < M). omega.
  assumption. ring. cut (2 ^ (p - 1) < M). omega. elim lt_2pm1_M. omega. intro H0. absurd (1 < M). omega.
  assumption. ring. intro H0. rewrite p_M. rewrite <- H0. trivial. assumption. Qed.

Lemma large_M'_eq : 2 ^ w + (2 ^ (p + w) / M) mod 2 ^ w = 2 ^ (p + w) / M.

  transitivity (2 ^ (p + w) / M / 2 ^ w * 2 ^ w + (2 ^ (p + w) / M) mod 2 ^ w).
  apply f_equal2 with (f := Zplus). replace (2 ^ (p + w) / M / 2 ^ w) with 1. ring.
  rewrite Zdivdivdiv. rewrite Zmult_comm. rewrite <- Zdivdivdiv. rewrite Zpower_exp; auto with a.
  rewrite Z_div_mult. symmetry. exact div_M_1. apply Zlt_gt. auto with a. apply Zle_ge. auto with a.
  apply Zle_ge. auto with a. auto with a. omega. omega. auto with a. trivial. apply Zdivmod_split.
  auto with a. Qed.

Lemma q'_eq_pre :
  _Z q' = (x / 2 ^ p * (2 ^ (p + w) / M) / 2 ^ w) mod 2 ^ w.

  unfold q'. rewrite Z_from_plusw. rewrite q_eq. rewrite h'_eq. rewrite Zplus_comm.
  rewrite <- Zdiv_times_plus. rewrite <- Zmult_plus_distr_r. rewrite large_M'_eq. trivial. auto with a. Qed.

Lemma mod_ab_mod : forall z a b m : Z, 0 < m ->
  z = a \/ z = b -> z mod m = a mod m \/ z mod m = b mod m.

  intros z a b m H H0. elim H0; intro H1; rewrite H1; tauto. Qed.

(* <KEEP TOGETHER - q'_eq *)
Lemma q'_eq :
  _Z q' = (x / 2 ^ p * 2 ^ p / M) mod 2 ^ w \/
  _Z q' = (x / 2 ^ p * 2 ^ p / M - 1) mod 2 ^ w.
(* KEEP TOGETHER> *)

  rewrite q'_eq_pre. apply mod_ab_mod. auto with a.
  cut (x / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w = x / 2 ^ p * 2 ^ p / M - 1 \/
       x / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w = x / 2 ^ p * 2 ^ p / M).
  rewrite Zpower_exp. tauto. apply Zle_ge. auto with a. apply Zle_ge. auto with a.
  cut (x / 2 ^ p * 2 ^ p / M - 1 <= x / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w).
  cut (x / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w <= x / 2 ^ p * 2 ^ p / M). intros H H0.
  elim (Zle_lt_or_eq (x / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w) (x / 2 ^ p * 2 ^ p / M)). intro H1. left.
  omega. intro H1. right. omega. assumption. apply approx_0_one. omega. auto with a. auto with a.
  auto with a. apply approx_m1_one. auto with a. auto with a. omega. auto with a.
  cut (x < 2 ^ p * 2 ^ w). cut (0 < 2 ^ p). omega. auto with a. rewrite <- Zpower_exp. auto with a.
  apply Zle_ge. auto with a. apply Zle_ge. auto with a. Qed.

(* <KEEP TOGETHER - y_eq *)
Lemma y_eq :
  _Z y = x / 2 ^ p * 2 ^ p / M * M mod 2 ^ w \/
  _Z y = (x / 2 ^ p * 2 ^ p / M * M - M) mod 2 ^ w.
(* KEEP TOGETHER> *)

  unfold y. rewrite Z_from_multw. fold M. elim q'_eq; intro H; rewrite H. left.
  rewrite <- Zmod_mult_distr_l. trivial. auto with a. right. rewrite <- Zmod_mult_distr_l.
  apply f_equal2 with (f := Zmod). ring. trivial. auto with a. Qed.

Lemma lt_M_2pw : M < 2 ^ w.

  unfold M. apply lt_z__Z. Qed.

Lemma le_M_2pw : M <= 2 ^ w.

  apply Zlt_le_weak. exact lt_M_2pw. Qed.

Hint Resolve lt_M_2pw le_M_2pw : a.

(* <KEEP TOGETHER - d_eq *)
Lemma d_eq :
  _Z d = x / 2 ^ p * 2 ^ p mod M \/
  _Z d = x / 2 ^ p * 2 ^ p mod M + M.
(* KEEP TOGETHER> *)

  unfold d. rewrite Z_from_minusw. rewrite s'_eq. rewrite Zmod_minus_distr_l.
  rewrite <- Zmod_minus_distr_l with (b := x mod 2 ^ p). rewrite <- Zmod_minus_distr_l.
  rewrite <- Zdiv_a_b_b_Zmod. elim y_eq; intro H. left. rewrite H. rewrite <- Zmod_minus_distr_r.
  rewrite Zminus_Zdiv_Zmult. apply modred. apply Zmod_le_0_z. omega. apply Zlt_le_trans with M.
  apply Zmod_lt_z_m. omega. auto with a. omega. auto with a. right. rewrite H.
  rewrite <- Zmod_minus_distr_r.
  replace (x / 2 ^ p * 2 ^ p - (x / 2 ^ p * 2 ^ p / M * M - M))
     with (x / 2 ^ p * 2 ^ p - x / 2 ^ p * 2 ^ p / M * M + M). rewrite Zminus_Zdiv_Zmult. apply modred.
  fold (0 + 0). apply Zplus_le_compat. apply Zmod_le_0_z. omega. omega. apply Zlt_le_trans with (M + M).
  apply Zplus_lt_le_compat. apply Zmod_lt_z_m. omega. omega. rewrite Zpow_2_w_is_2Zpow_2_wm1. omega. omega.
  ring. auto with a. auto with a. auto with a. auto with a. auto with a. Qed.

(* <KEEP TOGETHER - r_eq *)
Lemma r_eq : _Z r = (_Z d + x mod 2 ^ p) mod 2 ^ w.
(* KEEP TOGETHER> *)

  unfold r. unfold d. rewrite Z_from_minusw. rewrite Z_from_minusw. fold u. rewrite s'_eq.
  rewrite Zmod_minus_distr_l with (a := x mod 2 ^ w - x mod 2 ^ p).
  rewrite <- Zmod_minus_distr_l with (a := x). rewrite <- Zmod_minus_distr_l. rewrite <- Zmod_plus_distr_l.
  replace (x - x mod 2 ^ p - _Z y + x mod 2 ^ p) with (x - _Z y). rewrite l_eq. (* explicit coercion needed here *)
  rewrite <- Zmod_minus_distr_l. trivial. auto with a. ring. auto with a. auto with a. auto with a.
  auto with a. Qed.

(* <KEEP TOGETHER - r'_eq *)
Lemma r'_eq : _Z r' = x / 2 ^ p * 2 ^ p mod M + x mod 2 ^ p.
(* KEEP TOGETHER> *)

  unfold r'. elim d_eq; intro H. rewrite ltw_true. rewrite r_eq. rewrite H. apply modred. fold (0 + 0).
  apply Zplus_le_compat. apply Zmod_le_0_z. omega. apply Zmod_le_0_z. auto with a.
  rewrite Zpow_2_w_is_2Zpow_2_wm1. apply Zplus_lt_le_compat. apply Zlt_le_trans with M. apply Zmod_lt_z_m. omega.
  assumption. apply Zlt_le_weak. apply Zlt_le_trans with (2 ^ p). apply Zmod_lt_z_m. auto with a. apply Zle_pow_le.
  auto with a. cut (p < w). omega. auto with a. fold M. rewrite H. apply Zmod_lt_z_m. omega.
  rewrite ltw_false. rewrite Z_from_minusw. rewrite r_eq. rewrite H. fold M. rewrite <- Zmod_minus_distr_l.
  replace ((x / 2 ^ p * 2 ^ p) mod M + M + x mod 2 ^ p - M)
     with ((x / 2 ^ p * 2 ^ p) mod M + x mod 2 ^ p). apply modred. fold (0 + 0). apply Zplus_le_compat.
  apply Zmod_le_0_z. omega. apply Zmod_le_0_z. auto with a. rewrite Zpow_2_w_is_2Zpow_2_wm1.
  apply Zplus_lt_le_compat. apply Zlt_le_trans with M. apply Zmod_lt_z_m. omega. assumption.
  apply Zlt_le_weak. apply Zlt_le_trans with (2 ^ p). apply Zmod_lt_z_m. auto with a. apply Zle_pow_le. auto with a.
  cut (p < w). omega. auto with a. ring. auto with a. fold M. rewrite H. cut (0 <= x / 2 ^ p * 2 ^ p mod M).
  omega. apply Zmod_le_0_z. omega. Qed.

Lemma r'_small : _Z r' < M + 2 ^ p.

  rewrite r'_eq. apply Zplus_lt_compat. apply Zmod_lt_z_m. omega. apply Zmod_lt_z_m. auto with a. Qed.

Lemma r'_x : _Z r' = x mod M \/ _Z r' = x mod M + M \/ _Z r' = x mod M + M + M.

  rewrite r'_eq. rewrite <- Zdivmod_split with (x := x mod 2 ^ p) (m := M). rewrite Zdiv_a_b_b_Zmod.
  rewrite Zplus_comm with (m := x mod 2 ^ p mod M). rewrite Zplus_assoc. elim (mod_plus (x - x mod 2 ^ p) (x mod 2 ^ p) M).
  intro H. rewrite H. replace (x - x mod 2 ^ p + x mod 2 ^ p) with x. elim (div_r'_i x M). intro H0. rewrite <- p_M in H0.
  rewrite H0. left. ring. intro H0. rewrite <- p_M in H0. rewrite H0. right. left. ring. omega. ring. intro H. rewrite H.
  replace (x - x mod 2 ^ p + x mod 2 ^ p) with x. elim (div_r'_i x M). intro H0. rewrite <- p_M in H0. rewrite H0. right. left.
  ring. intro H0. rewrite <- p_M in H0. rewrite H0. right. right. ring. omega. ring. omega. auto with a. omega. Qed.

Lemma r''_small : _Z r'' < 2 ^ p.

  unfold r''. elim (Zle_or_lt M r'); intro H. rewrite ltw_false. simpl. fold M. rewrite modred. cut (r' < M + 2 ^ p).
  omega. exact r'_small. omega. apply Zle_lt_trans with (_Z r'). omega. apply lt_z__Z. fold M. assumption. rewrite ltw_true.
  apply Zlt_le_trans with M. assumption. exact le_M_2pp. fold M. assumption. Qed.

(* <KEEP TOGETHER - r''_eq *)
Lemma r''_eq : _Z r'' = x mod M \/ _Z r'' = x mod M + M.
(* KEEP TOGETHER> *)

  unfold r''. elim (Zle_or_lt M r'); intro H. rewrite ltw_false. simpl. fold M. rewrite modred. elim r'_x. intro H0.
  rewrite H0 in H. absurd (M <= x mod M). apply Zlt_not_le. apply Zmod_lt_z_m. omega. assumption. intro H0; elim H0; intro H1.
  rewrite H1. left. ring. rewrite H1. right. ring. omega. apply Zle_lt_trans with (_Z r'). omega. apply lt_z__Z. fold M.
  assumption. rewrite ltw_true. elim r'_x. tauto. intro H0; elim H0; intro H1. tauto. absurd (x mod M + M + M < M).
  apply Zle_not_lt. cut (0 <= x mod M). omega. apply Zmod_le_0_z. omega. rewrite <- H1. assumption. fold M. assumption. Qed.

(* <KEEP TOGETHER - r'''_eq *)
Lemma r'''_eq : _Z r''' = x mod M.
(* KEEP TOGETHER> *)

  unfold r'''. elim r''_eq; intro H. rewrite ltw_true. assumption. rewrite H. fold M. apply Zmod_lt_z_m.
  omega. rewrite ltw_false. rewrite Z_from_minusw. fold M. rewrite H.
  replace (x mod M + M - M) with (x mod M). apply modred. apply Zmod_le_0_z. omega. apply Zlt_trans with M.
  apply Zmod_lt_z_m. omega. auto with a. ring. fold M. rewrite H. cut (0 <= x mod M). omega.
  apply Zmod_le_0_z. omega. Qed.

End parm_sec.

Definition in_Mset (M : Z) := 1 <= M <= 2 ^ (w - 1).

Definition Mset := sig in_Mset.

Coercion Z_from_Mset (M : Mset) := proj1_sig (P := in_Mset) M.

Lemma Mset_l : forall M : Mset, 1 <= M.

  intro M. unfold Z_from_Mset. case M. unfold in_Mset. simpl. tauto. Qed.

Lemma Mset_r : forall M : Mset, M <= 2 ^ (w - 1).

  intro M. unfold Z_from_Mset. case M. unfold in_Mset. simpl. tauto. Qed.

Lemma logsuplew : forall (M : Mset), Zlog_sup M <= w.

  intro M. replace w with (Zlog_sup (2 ^ w)). apply Zlog_sup_seq. apply Zlt_le_weak. case M. unfold in_Mset.
  simpl. intros. cut (2 ^ (w - 1) < 2 ^ w). omega. exact lt_2wm1_2w. apply Zlog_sup_pow. exact le_0_w. Qed.

Lemma xhex : forall (M : Mset) (x : Z_ (2 ^ (Zlog_sup M + w))),
  in_Z_ (2 ^ w) (x / 2 ^ w).

  intros M x. unfold in_Z_. split. apply Zle_0_div. apply le_0__Z. exact lt02w.
  apply Zle_lt_trans with ((2 ^ (Zlog_sup M + w) - 1) / 2 ^ w). apply Zdiv_le. exact lt02w.
  cut (x < 2 ^ (Zlog_sup M + w)). omega. apply lt_z__Z. rewrite Zpower_exp.
  rewrite Zdiv_mult_minus. cut (2 ^ Zlog_sup M <= 2 ^ w). omega. apply Zle_pow_le.
  apply Zlog_sup_correct1. apply Zlt_le_trans with 1. omega. apply Mset_l. apply logsuplew.
  exact lt02w. omega. cut (0 < 2 ^ w). omega. exact lt02w. apply Zle_ge. apply Zlog_sup_correct1.
  apply Zlt_le_trans with 1. omega. apply Mset_l. apply Zle_ge. exact le_0_w. Qed.

Lemma xlex : forall x : Z, in_Z_ (2 ^ w) (x mod 2 ^ w).

  intro. unfold in_Z_. split. apply Zmod_le_0_z. exact lt02w. apply Zmod_lt_z_m. exact lt02w. Qed.

Lemma M'ex : forall M : Mset, in_Z_ (2 ^ w) (2 ^ (Zlog_sup M + w) / M - 2 ^ w).

  intro M. unfold in_Z_. elim (Zle_lt_or_eq 1 M). intro H0. cut (1 <= Zlog_sup M). intro H1.
  split. cut (2 ^ w <= 2 ^ (Zlog_sup M + w) / M). omega. rewrite Zpower_exp.
  apply Zle_trans with (M * 2 ^ w / M). rewrite Zmult_comm. rewrite Z_div_mult. omega. omega.
  apply Zdiv_le. omega. apply Zmult_le_compat_r. elim (Zlog_sup_correct2 M). omega. omega.
  apply Zlt_le_weak. exact lt02w. omega. apply Zle_ge. exact le_0_w.
  cut (2 ^ (Zlog_sup M + w) / M < 2 ^ w + 2 ^ w). omega. rewrite Zpower_exp.
  apply Zle_lt_trans with (((2 * M - 1) * 2 ^ w) / M). apply Zdiv_le. omega. apply Zmult_le_compat_r.
  replace (Zlog_sup M) with (Zlog_sup M - 1 + 1). rewrite Zpower_exp.
  apply Zle_trans with ((M - 1) * 2). apply Zmult_le_compat. elim (Zlog_sup_correct2 M). omega.
  omega. simpl. unfold Zpower_pos. simpl. omega. apply Zle_trans with (2 ^ (1 - 1)). simpl. omega.
  apply Zle_pow_le. omega. omega. simpl. unfold Zpower_pos. simpl. omega. omega. omega. omega. ring.
  apply Zlt_le_weak. exact lt02w. replace ((2 * M - 1) * 2 ^ w) with ((2 ^ w + 2 ^ w) * M + - 2 ^ w).
  rewrite Zdiv_times_plus. cut (- 2 ^ w / M < 0). omega. apply Zle_lt_trans with (-1 / M).
  apply Zdiv_le. omega. cut (0 < 2 ^ w). omega. exact lt02w. replace (-1) with (0 * M - 1).
  rewrite Zdiv_mult_minus. omega. omega. omega. omega. ring. omega. ring. omega. apply Zle_ge. exact le_0_w.
  replace 1 with (Zlog_sup 2). apply Zlog_sup_seq. omega. trivial. intro H0. rewrite <- H0. simpl.
  replace (2 ^ w) with (2 ^ w * 1). rewrite Z_div_mult. split. omega. cut (0 < 2 ^ w). omega. exact lt02w.
  omega. ring. apply Mset_l. Qed.

Lemma p1ex_2le : forall M : Mset, in_Z_ w (Zlog_sup M).

  intro M. unfold in_Z_. split. apply Zle_trans with (Zlog_sup 1). simpl. omega.
  apply Zlog_sup_seq. apply Mset_l. apply Zle_lt_trans with (w - 1).
  rewrite <- Zlog_sup_pow with (i := w - 1). apply Zlog_sup_seq. apply Mset_r. cut (0 < w). omega.
  exact lt_0_w. omega. Qed.

Lemma pex : forall M : Mset, in_Z_ w (Zlog_sup M).

  intros. apply p1ex_2le; omega. Qed.

Lemma tex : forall M : Mset, in_Z_ w (w - Zlog_sup M - 1 / M).

  intro M. unfold in_Z_. elim (Zle_lt_or_eq 1 M). intro H0. replace (1 / M) with 0. split.
  cut (Zlog_sup M <= w). omega. rewrite <- Zlog_sup_pow with (i := w). apply Zlog_sup_seq.
  apply Zle_trans with (2 ^ (w - 1)). apply Mset_r. apply Zlt_le_weak. apply lt_2wm1_2w.
  exact le_0_w. cut (1 <= Zlog_sup M). omega.
  replace 1 with  (Zlog_sup 2). apply Zlog_sup_seq. omega. trivial. replace 1 with (0 * M + 1).
  symmetry. apply Zdiv_mult_plus. omega. omega. omega. ring. intro H0. rewrite <- H0. simpl.
  replace (1 / 1) with 1. cut (0 < w). omega. exact lt_0_w. trivial. apply Mset_l. Qed.

Lemma in_Z__if_in_Mset : forall M : Mset, in_Z_ (2 ^ w) M.

  intro M. unfold in_Z_. case M. unfold in_Mset. simpl. intros. cut (2 ^ (w - 1) < 2 ^ w). omega.
  exact lt_2wm1_2w. Qed.

Definition Z__from_Mset (M : Mset) := exist (in_Z_ (2 ^ w)) M (in_Z__if_in_Mset M).

Coercion Z__from_Mset : Mset >-> sig.

(* <KEEP TOGETHER - Cdef *)
Definition C (M : Mset) :=
      ( exist (in_Z_ w)       (Zlog_sup M)                       (pex M),
        exist (in_Z_ w)       (w - Zlog_sup M - 1 / M)           (tex M),
        exist (in_Z_ (2 ^ w)) (2 ^ (Zlog_sup M + w) / M - 2 ^ w) (M'ex M)).
(* KEEP TOGETHER> *)

(* <KEEP TOGETHER - modred_equality *)
Theorem ModRed_eq : forall (M : Mset)
                           (x : Z_ (2 ^ (Zlog_sup M + w))),
  ModRed M
         (C M)
         (exist (in_Z_ (2 ^ w)) (x / 2 ^ w)   (xhex M x))
         (exist (in_Z_ (2 ^ w)) (x mod 2 ^ w) (xlex x))     =
  x mod M.
(* KEEP TOGETHER> *)

  intros M x. unfold ModRed. rewrite r'''_eq; simpl. rewrite Zdivmod_split. trivial.
  exact lt02w. apply Mset_l. apply Mset_r. trivial. elim (Zle_lt_or_eq 1 M). intro H. left.
  replace 1 with (0 * M + 1). rewrite Zdiv_mult_plus. ring. omega. omega. omega. ring. intro H. right.
  auto. apply Mset_l. rewrite <- modred with (x := 2 ^ (Zlog_sup M + w) / M - 2 ^ w) (m := 2 ^ w).
  rewrite Zmod_minus_distr_r. rewrite Z_mod_same. apply f_equal2 with (f := Zmod). ring. trivial.
  apply Zlt_gt. exact lt02w. exact lt02w. elim (M'ex M). omega. elim (M'ex M). omega.
  apply Zle_lt_trans with ((2 ^ (Zlog_sup M + w) - 1) / 2 ^ w). apply Zdiv_le. exact lt02w.
  cut (x < 2 ^ (Zlog_sup M + w)). omega. apply lt_z__Z. rewrite Zpower_exp. rewrite Zdiv_mult_minus.
  omega. exact lt02w. omega. cut (0 < 2 ^ w). omega. exact lt02w. apply Zle_ge. apply Zlog_sup_correct1.
  apply Zlt_le_trans with 1. omega. apply Mset_l. apply Zle_ge. exact le_0_w. Qed.

Lemma xheex : forall (M : Mset) (h : Z_ (2 ^ Zlog_sup M)),
  in_Z_ (2 ^ w) h.

  intros M h. unfold in_Z_. split. apply le_0__Z. apply Zlt_le_trans with (2 ^ (Zlog_sup M)).
  apply lt_z__Z. apply Zle_pow_le. apply Zlog_sup_correct1. apply Zlt_le_trans with 1. omega. apply Mset_l.
  apply Zle_trans with (Zlog_sup (2 ^ w)).
  apply Zlog_sup_seq. apply Zlt_le_weak. apply Zle_lt_trans with (2 ^ (w - 1)). apply Mset_r.
  exact lt_2wm1_2w. rewrite Zlog_sup_pow. omega. exact le_0_w. Qed.

Lemma xleex : forall (u : Z_ (2 ^ w)),
  in_Z_ (2 ^ w) u.

  intro. unfold in_Z_. split. apply le_0__Z. apply lt_z__Z. Qed.

(* <KEEP TOGETHER - modred_equality2 *)
Theorem ModRed_eq2 : forall (M : Mset) (v : Z_ (2 ^ Zlog_sup M)) (u : Z_ (2 ^ w)),
  ModRed M
        (C M)
        (exist (in_Z_ (2 ^ w)) v (xheex M v))
        (exist (in_Z_ (2 ^ w)) u (xleex u))     =
  (2 ^ w * v + u) mod M.
(* KEEP TOGETHER> *)

  intros M v u. unfold ModRed. rewrite r'''_eq; simpl. rewrite Zmult_comm. trivial. apply Mset_l. apply Mset_r. trivial.
  elim (Zle_lt_or_eq 1 M). intro H. left. replace 1 with (0 * M + 1).
  rewrite Zdiv_mult_plus. ring. omega. omega. omega. ring. intro H. right. auto. apply Mset_l.
  rewrite <- modred with (x := 2 ^ (Zlog_sup M + w) / M - 2 ^ w) (m := 2 ^ w).
  rewrite Zmod_minus_distr_r. rewrite Z_mod_same. apply f_equal2 with (f := Zmod). ring. trivial.
  apply Zlt_gt. exact lt02w. exact lt02w. elim (M'ex M). omega. elim (M'ex M). omega. apply lt_z__Z. Qed.

Close Scope Z_scope.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo73:
  prime  11881666721436151495252921->
  prime  87882427100100997730250576487417.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      87882427100100997730250576487417
      7396473
      ((11881666721436151495252921,1)::nil)
      0
      4823609
      98
      2401)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.