(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2020 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

(** Tactics related to (dependent) equality and proof irrelevance. *)

Require Import Coq.Program.Tactics.
Require Export Equations.Init.
Require Import Equations.CoreTactics.
Require Import Equations.Signature.
Require Import Equations.Prop.Logic.
Require Import Equations.Prop.Classes.
Require Import Equations.Prop.EqDec.

Import Sigma_Notations.
Local Open Scope equations_scope.

Local Set Keyed Unification.

(** Support for the [Equations] command.
   These tactics implement the necessary machinery to solve goals produced by the
   [Equations] command relative to dependent pattern-matching.
   It is inspired from the "Eliminating Dependent Pattern-Matching" paper by
   Goguen, McBride and McKinna. *)

(** The [DependentEliminationPackage] provides the default dependent elimination principle to
   be used by the [equations] resolver. It is especially useful to register the dependent elimination
   principles for things in [Prop] which are not automatically generated. *)

Polymorphic
Class DependentEliminationPackage (A : Type) :=
  { elim_type : Type ; elim : elim_type }.

(** A higher-order tactic to apply a registered eliminator. *)

Ltac elim_tac tac p :=
  let ty := type of p in
  let eliminator := eval simpl in (elim (A:=ty)) in
    tac p eliminator.

(** Specialization to do case analysis or induction.
   Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register
   generated induction principles. *)

Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p.
Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p.

(** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *)

Notation "p # t" := (transport _ p t) (right associativity, at level 65) : equations_scope.

Definition solution_left {A} {B : A -> Type} (t : A) (p : B t) (x : A) (e : x = t) : B x :=
  eq_sym e # p.

Lemma eq_sym_invol {A} (x y : A) (e : x = y) : eq_sym (eq_sym e) = e.
Proof. destruct e. reflexivity. Defined.

Lemma eq_symmetry_dep {A} {t : A} {B : forall (x : A), x = t -> Type} :
  (forall (x : A) (eq : t = x), B x (eq_sym eq)) ->
  (forall (x : A) (eq : x = t), B x eq).
Proof.
  intros. rewrite <- eq_sym_invol.
  generalize (eq_sym eq). apply X.
Defined.

Lemma solution_left_dep : forall {A} (t : A) {B : forall (x : A), (x = t -> Type)},
    B t eq_refl -> (forall x (Heq : x = t), B x Heq).
Proof.
  intros A t B H x eq. apply eq_symmetry_dep. clear eq. intros.
  destruct eq. exact H.
Defined.

Definition solution_right {A} {P : A -> Type} (t : A) (p : P t) x (e : t = x) : P x :=
  transport P e p.

Lemma solution_right_dep : forall {A} (t : A) {B : forall (x : A), (t = x -> Type)},
    B t eq_refl -> (forall x (Heq : t = x), B x Heq).
Proof. intros A t B H x eq. destruct eq. apply H. Defined.

Lemma solution_left_let : forall {A} {B : A -> Type} (b : A) (t : A),
  (b = t -> B t) -> (let x := b in x = t -> B x).
Proof. intros A B b t H x eq. subst x. destruct eq. apply H. reflexivity. Defined.

Lemma solution_right_let : forall {A} {B : A -> Type} (b t : A),
  (t = b -> B t) -> (let x := b in t = x -> B x).
Proof. intros A B b t H x eq. subst x. destruct eq. apply H. reflexivity. Defined.

Lemma deletion : forall {A B} (t : A), B -> (t = t -> B).
Proof. intros; assumption. Defined.

(** Old-style sigma types. *)
Lemma simplification_existT1 : forall {A} {P : A -> Type} {B} (p q : A) (x : P p) (y : P q),
  (p = q -> existT P p x = existT P q y -> B) -> (existT P p x = existT P q y -> B).
Proof.
  intros. refine (X _ H).
  change (projT1 (existT P p x) = projT1 (existT P q y)).
  now destruct H.
Defined.

Polymorphic Lemma simplification_sigma1@{i j | i <= eq.u0} :
  forall {A : Type@{i}} {P : A -> Type@{i}} {B : Type@{j}}
         (p q : A) (x : P p) (y : P q),
  (p = q -> (p, x) = (q, y) -> B) -> ((p, x) = (q, y) -> B).
Proof.
  intros. refine (X _ H).
  change (pr1 (p, x) = pr1 (q, y)).
  now destruct H.
Defined.

Polymorphic Lemma eq_simplification_sigma1@{i j | i <= eq.u0} {A : Type@{i}} {P : Type@{i}} {B : Type@{j}}
  (p q : A) (x : P) (y : P) :
  (p = q -> x = y -> B) ->
  ((p, x) = (q, y) -> B).
Proof.
  intros. revert X.
  change p with (pr1 (p, x)).
  change q with (pr1 (q, y)).
  change x with (pr2 (p, x)) at 2.
  change y with (pr2 (q, y)) at 2.
  destruct H.
  intros X. eapply (X eq_refl). apply eq_refl.
Defined.

Polymorphic Lemma eq_simplification_sigma1_dep@{i j | i <= eq.u0 +} {A : Type@{i}} {P : A -> Type@{i}} {B : Type@{j}}
  (p q : A) (x : P p) (y : P q) :
  (forall e : p = q, (@eq_rect A p P x q e) = y -> B) ->
  ((p, x) = (q, y) -> B).
Proof.
  intros. revert X.
  change p with (pr1 (p, x)).
  change q with (pr1 (q, y)).
  change x with (pr2 (p, x)) at 3.
  change y with (pr2 (q, y)) at 4.
  destruct H.
  intros X. eapply (X eq_refl). apply eq_refl.
Defined.

Polymorphic Definition pack_sigma_eq_nondep@{i | i <= eq.u0} {A : Type@{i}} {P : Type@{i}} {p q : A} {x : P} {y : P}
  (e' : p = q) (e : x = y) : (p, x) = (q, y).
Proof. destruct e'. simpl in e. destruct e. apply eq_refl. Defined.

Polymorphic Lemma eq_simplification_sigma1_nondep_dep@{i j | i <= eq.u0} {A : Type@{i}} {P : Type@{i}}
  (p q : A) (x : P) (y : P) {B : (p, x) = (q, y) -> Type@{j}} :
  (forall e' : p = q, forall e : x = y, B (pack_sigma_eq_nondep e' e)) ->
  (forall e : sigmaI (fun _ => P) p x = sigmaI (fun _ => P) q y, B e).
Proof.
  intros. revert X.
  change p with (pr1 (p, x)).
  change q with (pr1 (q, y)).
  change x with (pr2 (p, x)) at 2 4.
  change y with (pr2 (q, y)) at 2 4.
  destruct e.
  intros X. simpl in *.
  apply (X eq_refl eq_refl).
Defined.

Polymorphic Definition pack_sigma_eq@{i | +} {A : Type@{i}} {P : A -> Type@{i}} {p q : A} {x : P p} {y : P q}
  (e' : p = q) (e : @eq_rect A p P x q e' = y) : (p, x) = (q, y).
Proof. destruct e'. simpl in e. destruct e. apply eq_refl. Defined.

Polymorphic Lemma eq_simplification_sigma1_dep_dep@{i j | i <= eq.u0 +} {A : Type@{i}} {P : A -> Type@{i}}
  (p q : A) (x : P p) (y : P q) {B : (p, x) = (q, y) -> Type@{j}} :
  (forall e' : p = q, forall e : @eq_rect A p P x q e' = y, B (pack_sigma_eq e' e)) ->
  (forall e : (p, x) = (q, y), B e).
Proof.
  intros. revert X.
  change p with (pr1 (p, x)).
  change q with (pr1 (q, y)).
  change x with (pr2 (p, x)) at 3 5.
  change y with (pr2 (q, y)) at 4 6.
  destruct e.
  intros X. simpl in *.
  apply (X eq_refl eq_refl).
Defined.
Set Printing Universes.
Polymorphic Lemma pr2_inv_uip@{i| i <= eq.u0 +} {A : Type@{i}}
            {P : A -> Type@{i}} {x : A} {y y' : P x} :
  y = y' -> sigmaI@{i} P x y = sigmaI@{i} P x y'.
Proof. exact (solution_right (P:=fun y' => (x, y) = (x, y')) y eq_refl y'). Defined.

Polymorphic Lemma pr2_uip@{i | +} {A : Type@{i}}
            {E : UIP A} {P : A -> Type@{i}} {x : A} {y y' : P x} :
  sigmaI@{i} P x y = sigmaI@{i} P x y' -> y = y'.
Proof.
  refine (eq_simplification_sigma1_dep_dep@{i i} _ _ _ _ _).
  intros e'. destruct (uip eq_refl e'). intros e ; exact e.
Defined.

Polymorphic Lemma pr2_uip_refl@{i | +} {A : Type@{i}}
            {E : UIP A} (P : A -> Type@{i}) (x : A) (y : P x) :
  pr2_uip@{i} (@eq_refl _ (x, y)) = eq_refl.
Proof.
  unfold pr2_uip, eq_simplification_sigma1_dep_dep.
  now rewrite uip_refl_refl.
Defined.

(** If we have decidable equality on [A] we use this version which is
   axiom-free! *)

Polymorphic Lemma simplification_sigma2_uip@{i j |+} :
  forall {A : Type@{i}} `{UIP A} {P : A -> Type@{i}} {B : Type@{j}}
    (p : A) (x y : P p),
    (x = y -> B) -> ((p , x) = (p, y) -> B).
Proof. intros. apply X. apply pr2_uip@{i} in H0. assumption. Defined.

Polymorphic Lemma simplification_sigma2_uip_refl@{i j | +} :
  forall {A : Type@{i}} {uip:UIP A} {P : A -> Type@{i}} {B : Type@{j}}
    (p : A) (x : P p) (G : x = x -> B),
      @simplification_sigma2_uip A uip P B p x x G eq_refl = G eq_refl.
Proof.
  intros. unfold simplification_sigma2_uip. now rewrite pr2_uip_refl.
Defined.

Arguments simplification_sigma2_uip : simpl never.

Polymorphic Lemma simplification_sigma2_dec_point :
  forall {A : Type} (p : A) `{EqDecPoint A p} {P : A -> Type} {B : Type}
    (x y : P p),
    (x = y -> B) -> ((p, x) = (p, y) -> B).
Proof. intros. apply X. apply inj_right_sigma_point in H0. assumption. Defined.

Polymorphic Lemma simplification_sigma2_dec_point_refl@{i +} :
  forall {A} (p : A) `{eqdec:EqDecPoint A p} {P : A -> Type} {B}
    (x : P p) (G : x = x -> B),
      @simplification_sigma2_dec_point A p eqdec P B x x G eq_refl = G eq_refl.
Proof.
  intros. unfold simplification_sigma2_dec_point.
  rewrite inj_right_sigma_refl_point. reflexivity.
Defined.
Arguments simplification_sigma2_dec_point : simpl never.

Polymorphic Lemma simplification_K_uip@{i j| i <= eq.u0 +} {A : Type@{i}} `{UIP A} (x : A) {B : x = x -> Type@{j}} :
  B eq_refl -> (forall p : x = x, B p).
Proof. apply UIP_K. Defined.
Arguments simplification_K_uip : simpl never.

Polymorphic Lemma simplification_K_uip_refl :
  forall {A} `{UIP A} (x : A) {B : x = x -> Type} (p : B eq_refl),
  simplification_K_uip x p eq_refl = p.
Proof.
  intros.
  unfold simplification_K_uip, UIP_K. now rewrite uip_refl_refl.
Defined.

Polymorphic
Definition ind_pack_eq@{i | +} {A : Type@{i}} {B : A -> Type@{i}} {x : A} {p q : B x} (e : p = q) :
  @eq (sigma (fun x => B x)) (x, p) (x, q) :=
  (pr2_inv_uip e).

Polymorphic
Definition ind_pack_eq_inv_equiv@{i} {A : Type@{i}} {uip : UIP A}
           {B : A -> Type@{i}} {x : A} (p q : B x) (e : p = q) :
  pr2_uip (pr2_inv_uip e) = e.
Proof.
  destruct e. apply pr2_uip_refl.
Defined.

Polymorphic
Definition opaque_ind_pack_eq_inv@{i j} {A : Type@{i}} {uip : UIP A}
  {B : A -> Type@{i}} {x : A} {p q : B x} (G : p = q -> Type@{j}) (e : (x, p) = (x, q)) :=
  G (pr2_uip@{i} e).
Arguments opaque_ind_pack_eq_inv : simpl never.
Arguments pr2_uip : simpl never.
Arguments pr2_inv_uip : simpl never.

Polymorphic
Lemma simplify_ind_pack@{i j | +} {A : Type@{i}} {uip : UIP A}
      (B : A -> Type@{i}) (x : A) (p q : B x) (G : p = q -> Type@{j}) :
      (forall e : (x, p) = (x, q), opaque_ind_pack_eq_inv G e) ->
  (forall e : p = q, G e).
Proof.
  intros H. intros e.
  specialize (H (ind_pack_eq e)). unfold opaque_ind_pack_eq_inv in H.
  rewrite ind_pack_eq_inv_equiv in H. apply H.
Defined.
Arguments simplify_ind_pack : simpl never.

Polymorphic
Lemma simplify_ind_pack_inv@{i j | +} {A : Type@{i}} {uip : UIP A}
      (B : A -> Type@{i}) (x : A) (p : B x) (G : p = p -> Type@{j}) :
  G eq_refl -> opaque_ind_pack_eq_inv G eq_refl.
Proof.
  intros H. unfold opaque_ind_pack_eq_inv. destruct (pr2_uip_refl B x p). exact H.
Defined.
Arguments simplify_ind_pack_inv : simpl never.

Polymorphic
Definition simplified_ind_pack@{i j | +} {A : Type@{i}} {uip : UIP A}
  (B : A -> Type@{i}) (x : A) (p : B x) (G : p = p -> Type@{j})
  (t : opaque_ind_pack_eq_inv G eq_refl) :=
  eq_rect _ G t _ (@pr2_uip_refl A uip B x p).
Arguments simplified_ind_pack : simpl never.

Polymorphic
Lemma simplify_ind_pack_refl@{i j | +} {A : Type@{i}} {uip : UIP A}
(B : A -> Type@{i}) (x : A) (p : B x) (G : p = p -> Type@{j})
(t : forall (e : (x, p) = (x, p)), opaque_ind_pack_eq_inv G e) :
  simplify_ind_pack B x p p G t eq_refl =
  simplified_ind_pack B x p G (t eq_refl).
Proof. reflexivity. Qed.

Polymorphic
Lemma simplify_ind_pack_elim@{i j | +} {A : Type@{i}} {uip : UIP A}
  (B : A -> Type@{i}) (x : A) (p : B x) (G : p = p -> Type@{j})
  (t : G eq_refl) :
  simplified_ind_pack B x p G (simplify_ind_pack_inv B x p G t) = t.
Proof.
  unfold simplified_ind_pack, simplify_ind_pack_inv.
  now destruct (pr2_uip_refl B x p).
Qed.

(** All the simplification rules involving axioms are treated as opaque
  when proving lemmas about definitions. To actually compute with these
  inside Coq, one has to make them transparent again. *)

Global Opaque simplification_sigma2_uip
       simplification_sigma2_dec_point
       simplification_K_uip
       simplify_ind_pack simplified_ind_pack.
Global Opaque opaque_ind_pack_eq_inv.

Ltac rewrite_sigma2_refl_noK :=
  match goal with
  | |- context [@inj_right_sigma ?A ?H ?x ?P ?y ?y' _] =>
    rewrite (@inj_right_sigma_refl A H x P y)

  | |- context [@simplification_sigma2_uip ?A ?H ?P ?B ?p ?x ?y ?X eq_refl] =>
    rewrite (@simplification_sigma2_uip_refl A H P B p x X); simpl

  | |- context [@simplification_sigma2_dec_point ?A ?p ?H ?P ?B ?x ?y ?X eq_refl] =>
    rewrite (@simplification_sigma2_dec_point_refl A p H P B x X); simpl

  | |- context [@simplification_K_uip ?A ?dec ?x ?B ?p eq_refl] =>
    rewrite (@simplification_K_uip_refl A dec x B p); simpl eq_rect

  (* | |- context [@HSets.inj_sigma_r ?A ?H ?P ?x ?y ?y' _] => *)
  (*   rewrite (@HSets.inj_sigma_r_refl A H P x y) *)

  | |- context [@simplify_ind_pack ?A ?uip ?B ?x ?p _ ?G _ eq_refl] =>
    rewrite (@simplify_ind_pack_refl A uip B x p G _)

  | |- context [@simplified_ind_pack ?A ?uip ?B ?x ?p ?G
        (simplify_ind_pack_inv _ _ _ _ ?t)] =>
    rewrite (@simplify_ind_pack_elim A uip B x p G t)
  end.

Ltac rewrite_sigma2_refl := rewrite_sigma2_refl_noK.

(** This hint database and the following tactic can be used with [autounfold] to
   unfold everything to [eq_rect]s. *)

#[global]
Hint Unfold solution_left solution_right
  eq_sym_invol eq_symmetry_dep
  solution_left_dep solution_right_dep deletion
  simplification_existT1 simplification_sigma1
  eq_simplification_sigma1 eq_simplification_sigma1_dep
  apply_noConfusion
  eq_rect_r eq_rec eq_ind eq_ind_r
  : equations.

(** Makes these definitions disappear at extraction time *)
Extraction Inline solution_right_dep solution_right solution_left solution_left_dep.
Extraction Inline eq_sym_invol eq_symmetry_dep.
Extraction Inline solution_right_let solution_left_let deletion.
Extraction Inline simplification_existT1.
Extraction Inline simplification_sigma1 simplification_sigma2_uip.
Extraction Inline simplification_K_uip.
Extraction Inline eq_simplification_sigma1 eq_simplification_sigma1_dep.
Extraction Inline eq_simplification_sigma1_nondep_dep eq_simplification_sigma1_dep_dep.

(** Simply unfold as much as possible. *)

Ltac unfold_equations := repeat progress autounfold with equations.
Ltac unfold_equations_in H := repeat progress autounfold with equations in H.

Ltac rewrite_refl_id :=
  repeat (progress (autorewrite with refl_id) || (try rewrite_sigma2_refl)).

Ltac simplify_equations_in e :=
  repeat progress (autounfold with equations in e ; simpl in e).

(** Using these we can make a simplifier that will perform the unification
   steps needed to put the goal in normalised form (provided there are only
   constructor forms). Compare with the lemma 16 of the paper.
   We don't have a [noCycle] procedure yet. *)

(** These two tactics are dangerous as they can try to reduce terms
    to head-normal-form and take ages to fail. *)
Ltac try_discriminate := discriminate.
Ltac try_injection H := injection H.

Ltac simplify_one_dep_elim :=
  match goal with
    | [ |- context [eq_rect_r _ _ eq_refl]] => progress simpl eq_rect_r
    | [ |- context [eq_rect _ _ _ _ eq_refl]] => progress simpl eq_rect
    | [ |- context [transport _ eq_refl _]] => progress simpl transport
    | [ |- context [@eq_elim _ _ _ _ _ eq_refl]] => progress simpl eq_rect
    | [ |- context [@eq_elim_r _ _ _ _ _ eq_refl]] => progress simpl eq_elim_r
    | [ |- context [noConfusion_inv _]] => progress simpl noConfusion_inv
    | [ |- @opaque_ind_pack_eq_inv ?A ?uip ?B ?x ?p _ ?G eq_refl] =>
            apply (@simplify_ind_pack_inv A uip B x p G)
    | [ |- let _ := block in _ ] => fail 1
    | [ |- _ ] => (simplify * || simplify ?); cbv beta
    | [ |- _ -> ?B ] => let ty := type of B in (* Works only with non-dependent products *)
      intro || (let H := fresh in intro H)
    | [ |- forall x, _ ] => let H := fresh x in intro H
    | [ |- _ ] => intro
  end.

(** Repeat until no progress is possible. By construction, it should leave the goal with
   no remaining equalities generated by the [generalize_eqs] tactic. *)

Ltac simplify_dep_elim := repeat simplify_one_dep_elim.

(** Apply [noConfusion] on a given hypothsis. *)

Ltac noconf H :=
  block_goal; revert_until H; block_goal;
  on_last_hyp ltac:(fun H' => revert H');
  simplify_dep_elim;
  intros_until_block;
  intros_until_block.

(** Reverse and simplify. *)

Ltac simpdep := reverse; simplify_dep_elim.

(** Decompose existential packages. *)

Ltac decompose_exists id id' := hnf in id ;
  match type of id with
    | @sigma _ _ => let xn := fresh id "'" in
      destruct id as [xn id]; decompose_exists xn id;
        cbv beta delta [ pr1 pr2 ] iota in id, id';
          decompose_exists id id'
    | _ => cbv beta delta [ pr1 pr2 ] iota in id, id'
  end.

(** Dependent generalization using existentials only. *)

Ltac generalize_sig_gen id cont :=
  let id' := fresh id in
  get_signature_pack id id';
  hnf in (value of id'); hnf in (type of id');
  lazymatch goal with
  | id' := ?v |- context[ id ] =>
    generalize (@eq_refl _ id' : v = id') ;
    clearbody id'; simpl in id';
    cont id id' id v
  | id' := ?v |- _ =>
    let id'1 := fresh id' in let id'2 := fresh id' in
    set (id'2 := pr2 id'); set (id'1 := pr1 id') in id'2;
    hnf in (value of id'1), (value of id'2);
    try red in (type of id'2);
    match goal with
      [ id'1 := ?t |- _ ] =>
      generalize (@eq_refl _ id'1 : t = id'1);
        clearbody id'2 id'1; clear id' id;
        try unfold signature in id'2; hnf in id'2; simpl in id'2;
        rename id'2 into id; cont id id id'1 t
    end
  end.

Ltac generalize_sig id cont :=
  generalize_sig_gen id
    ltac:(fun id id' id'1 t => (* Fails if id = id' *)
            try rename id into id', id' into id;
          cont id'1 id).

Ltac generalize_sig_vars id cont :=
  generalize_sig_gen id
    ltac:(fun id id' id'1 t => move_after_deps id' t; revert_until id';
          rename id' into id; cont id'1 id).

Ltac generalize_sig_dest id :=
  generalize_sig id ltac:(fun id id' => decompose_exists id id').

Ltac generalize_sig_vars_dest id :=
  generalize_sig_vars id ltac:(fun id id' => decompose_exists id id').

Ltac generalize_eqs_sig id :=
  (needs_generalization id ; generalize_sig_dest id)
    || idtac.

Ltac generalize_eqs_vars_sig id :=
  (needs_generalization id ; generalize_sig_vars_dest id)
    || idtac.

(** The default implementation of generalization using sigma types. *)

Ltac generalize_by_eqs id := generalize_eqs_sig id.
Ltac generalize_by_eqs_vars id := generalize_eqs_vars_sig id.

(** Do dependent elimination of the last hypothesis, but not simplifying yet
   (used internally). *)

Ltac destruct_last :=
  on_last_hyp ltac:(fun id => simpl in id ; generalize_by_eqs id ; destruct id).

(** The rest is support tactics for the [Equations] command. *)

(** To solve a goal by inversion on a particular target. *)

Ltac do_empty id :=
  exfalso ; simpl in id ;
  solve [ generalize_by_eqs id ; destruct id ; simplify_dep_elim
    | apply id ; eauto with Below ].

(** If defining recursive functions, the prototypes come first. *)

Ltac introduce p := first [
  match p with _ => (* Already there, generalize dependent hyps *)
    generalize dependent p ; intros p
  end
  | intros until p | intros until 1 | intros ].

Ltac do_case p := introduce p ; (elim_case p || destruct p || (case p ; clear p)).
Ltac do_ind p := introduce p ; (elim_ind p || induction p).

(** The following tactics allow to do induction on an already instantiated inductive predicate
   by first generalizing it and adding the proper equalities to the context, in a maner similar to
   the BasicElim tactic of "Elimination with a motive" by Conor McBride. *)

(** The [do_depelim] higher-order tactic takes an elimination tactic as argument and an hypothesis
   and starts a dependent elimination using this tactic. *)

Ltac is_introduced H :=
  match goal with
    | [ H' : _ |- _ ] => match H' with H => idtac end
  end.

Tactic Notation "intro_block" hyp(H) :=
  (is_introduced H ; block_goal ; revert_until H ; block_goal) ||
    (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal).

Tactic Notation "intro_block_id" ident(H) :=
  (is_introduced H ; block_goal ; revert_until H ; block_goal) ||
    (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal).

Ltac unblock_dep_elim :=
  match goal with
    | |- let _ := block in ?T =>
      match T with context [ block ] =>
        change T ; intros_until_block
      end
    | _ => unblock_goal
  end.

(** A tactic that tries to remove trivial equality guards in induction hypotheses coming
   from [dependent induction]/[generalize_eqs] invocations. *)

Ltac simplify_IH_hyps := repeat
  match goal with
    | [ hyp : context [ block ] |- _ ] =>
     cbn beta in hyp; eqns_specialize_eqs_block hyp;
    cbn beta iota delta[eq_rect_r eq_rect] zeta in hyp
  end.

Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_dep_elim.

Ltac do_intros H :=
  (try intros until H) ; (intro_block_id H || intro_block H) ;
  (try simpl in H ; simplify_equations_in H).

Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_by_eqs H ; tac H.

Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim; unblock_goal.

Ltac do_depind tac H :=
  (try intros until H) ; intro_block H ; (try simpl in H ; simplify_equations_in H) ;
  generalize_by_eqs_vars H ;
  block_goal ;
  tac H ;
  intros_until_block;
  simpl_dep_elim; unblock_goal.

(** To dependent elimination on some hyp. *)

Ltac depelim id := do_depelim ltac:(fun hyp => do_case hyp) id.

Ltac depelim_term c :=
  let H := fresh "term" in
    set (H:=c) in *; clearbody H ; depelim H.

(** Used internally. *)

Ltac depelim_nosimpl id := do_depelim_nosimpl ltac:(fun hyp => do_case hyp) id.

(** To dependent induction on some hyp. *)

Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id.

(** A variant where generalized variables should be given by the user. *)

Ltac do_depelim' tac H :=
  (try intros until H) ; block_goal ; generalize_by_eqs H ; tac H ; simplify_dep_elim ;
    simplify_IH_hyps ; unblock_goal.

(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion.
   By default, we don't try to generalize the hyp by its variable indices.  *)

Tactic Notation "dependent" "destruction" ident(H) :=
  do_depelim' ltac:(fun hyp => do_case hyp) H.

Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => destruct hyp using c) H.

(** This tactic also generalizes the goal by the given variables before the elimination. *)

Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) :=
  do_depelim' ltac:(fun hyp => revert l ; do_case hyp) H.

Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => revert l ; destruct hyp using c) H.

(** Then we have wrappers for usual calls to induction. One can customize the induction tactic by
   writting another wrapper calling do_depelim. We suppose the hyp has to be generalized before
   calling [induction]. *)

Tactic Notation "dependent" "induction" ident(H) :=
  do_depind ltac:(fun hyp => do_ind hyp) H.

Tactic Notation "dependent" "induction" ident(H) "using" constr(c) :=
  do_depind ltac:(fun hyp => induction hyp using c) H.

(** This tactic also generalizes the goal by the given variables before the induction. *)

Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) :=
  do_depelim' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H.

Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H.

(** [solve_equation] is used to prove the equation lemmas for an existing definition.  *)

Ltac find_empty := simpl in * ; exfalso ;
  match goal with
    | [ H : _ |- _ ] => solve [ clear_except H ; dependent elimination H | eqns_specialize_eqs H ; assumption ]
    | [ H : _ <> _ |- _ ] => solve [ red in H ; eqns_specialize_eqs H ; assumption ]
  end.

Ltac make_simplify_goal :=
  match goal with
    [ |- @eq ?A ?T ?U ] => let eqP := fresh "eqP" in
      set (eqP := fun x : A => x = U) ; change (eqP T)
  end.

Ltac hnf_gl :=
  match goal with
    [ |- ?P ?T ] => let T' := eval hnf in T in
      change_no_check (P T')
  end.

Ltac hnf_eq :=
  match goal with
    |- ?x = ?y =>
      let x' := eval hnf in x in
      let y' := eval hnf in y in
      change_no_check (x' = y')
  end.

Ltac red_eq_lhs :=
  match goal with
    |- ?R ?x ?y =>
      let x' := eval red in x in
      change_no_check (R x' y)
  end.

Ltac red_one_eq :=
  match goal with
  |- ?R ?x ?y =>
    let x' := eval red in x in
    let y' := eval red in y in
    change_no_check (R x' y')
  end.

Ltac red_eq :=
  match goal with
    |- ?x = ?y =>
    let rec reduce_eq x y :=
      let x' := eval red in x in
      let y' := eval red in y in
          (reduce_eq x' y' || change_no_check (x' = y'))
      in reduce_eq x y
  end.

Ltac red_gl :=
  match goal with
    |- ?P ?x =>
    let rec reduce x :=
      let x' := eval red in x in
      (reduce x' || change_no_check (P x'))
      in reduce x
  end.

Ltac rewrite_sigma2_rule_noK c :=
  match c with
  | @inj_right_sigma ?A ?H ?x ?P ?y ?y' _ =>
    rewrite (@inj_right_sigma_refl A H x P y)
  | @simplify_ind_pack ?A ?uip ?B ?x ?p _ ?G _ eq_refl=>
    rewrite (@simplify_ind_pack_refl A uip B x p G _)
  | @simplification_sigma2_uip ?A ?H ?P ?B ?p ?x ?y ?X eq_refl=>
    rewrite (@simplification_sigma2_uip_refl A H P B p x X); simpl
  | @simplification_sigma2_dec_point ?A ?p ?H ?P ?B ?x ?y ?X eq_refl=>
    rewrite (@simplification_sigma2_dec_point_refl A p H P B x X); simpl
  | @simplification_K_uip ?A ?dec ?x ?B ?p eq_refl=>
    rewrite (@simplification_K_uip_refl A dec x B p); simpl eq_rect
  end.

Ltac rewrite_sigma2_rule c :=
  rewrite_sigma2_rule_noK c.

Ltac rewrite_sigma2_term x :=
  match x with
   | ?f _ _ _ _ _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ _ => rewrite_sigma2_rule f
   | ?f _ _ => rewrite_sigma2_rule f
   | ?f _ => rewrite_sigma2_rule f
   | ?f => rewrite_sigma2_rule f
  end.

Ltac rewrite_sigma2_refl_eq :=
  match goal with
    |- ?x = ?y => rewrite_sigma2_term x || rewrite_sigma2_term y
  end.

Ltac rewrite_sigma2_refl_goal :=
  match goal with
  | |- ?P ?x => rewrite_sigma2_term x
  end.

(* Ltac simpl_equations :=  *)
(*   repeat (repeat (simpl; (hnf_eq || rewrite_sigma2_refl_eq || autorewrite with refl_id); simpl); *)
(*           try progress autounfold with equations). *)

(* Ltac simplify_equation c := *)
(*   make_simplify_goal ; simpl ; *)
(*   repeat (try autounfoldify c; *)
(*           try (red_gl || rewrite_sigma2_refl_goal || autorewrite with refl_id) ; simpl). *)

Ltac simpl_equations :=
  repeat (repeat (simpl; hnf_eq; rewrite_refl_id);
          try progress autounfold with equations).

Ltac simpl_equation_impl :=
  repeat (unfold_equations; rewrite_refl_id).

Ltac simplify_equation c :=
  make_simplify_goal; simpl;
  repeat (try autounfold_ref c;
          progress (simpl; unfold_equations) ||
          (progress (autorewrite with refl_id)) ||
          reflexivity ||
          (progress (rewrite_sigma2_refl))).

Ltac solve_equation c :=
  intros ; try simplify_equation c ; try
    (match goal with
       | [ |- ImpossibleCall _ ] => find_empty
       | _ => try red; try (reflexivity || discriminates)
     end).

Definition depelim_module := tt.

Register depelim_module as equations.depelim.module.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition asc_mark_nonsecure_spec (addr: Z64) (adt: RData) : option (RData * Z64) :=
    match addr with
    | VZ64 addr =>
      rely is_int64 addr;
      let gidx := __addr_to_gidx addr in
      rely is_int64 (gidx - 1);
      if (1 <=? gidx) && (gidx <=? NR_GRANULES) then
        when adt == query_oracle adt;
        rely prop_dec (((gpt_lk (share adt)) @ gidx) = None);
        let e := EVT CPU_ID (ACQ_GPT gidx) in
        if negb ((gpt (share adt)) @ gidx) then
          let e' := EVT CPU_ID (REL_GPT gidx false) in
          Some (adt {log: e' :: e :: (log adt)}, VZ64 1)
        else
          let e' := EVT CPU_ID (REL_GPT gidx false) in
          let gpt' := (gpt (share adt)) # gidx == false in
          Some (adt {log: e' :: e :: (log adt)} {share: (share adt) {gpt: gpt'}}, VZ64 0)
      else Some (adt, VZ64 1)
    end.

End Spec.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List.

From Undecidability.Synthetic Require Import Undecidability.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_nat.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.H10
  Require Import Dio.dio_single H10.

From Undecidability.MuRec
  Require Import recalg ra_dio_poly.

Set Default Proof Using "Type".

Section H10_MUREC_HALTING.

  Let f : H10_PROBLEM -> MUREC_PROBLEM.
  Proof.
    intros (n & p & q).
    exact (ra_dio_poly_find p q).
  Defined.

  Theorem H10_MUREC_HALTING : H10 ⪯ MUREC_HALTING.
  Proof.
    exists f.
    intros (n & p & q); simpl; unfold MUREC_HALTING.
    rewrite ra_dio_poly_find_spec; unfold dio_single_pred.
    split.
    + intros (phi & Hphi); exists (vec_set_pos phi).
      simpl in Hphi; eq goal Hphi; f_equal; apply dp_eval_ext; auto;
        try (intros; rewrite vec_pos_set; auto; fail);
        intros j; analyse pos j.
    + intros (v & Hw); exists (vec_pos v).
      eq goal Hw; f_equal; apply dp_eval_ext; auto;
        intros j; analyse pos j.
  Qed.

End H10_MUREC_HALTING.

Check H10_MUREC_HALTING.


Require Import Coq.Strings.Ascii Coq.Strings.String Coq.Lists.List.
Require Import Coq.Numbers.BinNums.
Require Import Coq.QArith.QArith.
Require Import Coq.ZArith.BinInt.
Require Import Crypto.Util.Option.
Require Coq.Strings.BinaryString.
Require Coq.Strings.OctalString.
Require Coq.Strings.HexString.
Require Import Crypto.Util.Strings.Decimal.
Require Import Crypto.Util.Strings.Parse.Common.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.OptionList.
Require Import Crypto.Util.ListUtil.GroupAllBy.
Require Import Crypto.Util.Notations.
Import ListNotations.
Import BinPosDef.
Local Set Implicit Arguments.
Local Open Scope option_scope.
Local Open Scope list_scope.
Local Open Scope char_scope.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope nat_scope.

Definition is_num (ch : ascii) : bool
  := match DecimalString.uint_of_char ch (Some Decimal.Nil) with Some _ => true | None => false end.

Definition is_oct_num (ch : ascii) : bool
  := match OctalString.ascii_to_digit ch with Some _ => true | None => false end.

Definition is_hex_num (ch : ascii) : bool
  := match HexString.ascii_to_digit ch with Some _ => true | None => false end.

Definition startswith_oct (s : string) : bool
  := match s with
     | String zero (String kind (String d rest))
       => (zero =? "0")%char && (kind =? "o")%char && is_oct_num d
     | _ => false
     end.

Definition startswith_hex (s : string) : bool
  := match s with
     | String zero (String kind (String d rest))
       => (zero =? "0")%char && (kind =? "x")%char && is_hex_num d
     | _ => false
     end.

Definition parse_bin_prefix : ParserAction _ := "0b".
Definition parse_oct_prefix : ParserAction _ := "0o".
Definition parse_dec_prefix : ParserAction _ := "".
Definition parse_hex_prefix : ParserAction _ := "0x".
Definition parse_hex_postfix : ParserAction _ := "h".

(** Is [E]/[e] a valid digit in the given base? *)
Definition base_accepts_E (base : N) : bool
  := (10 + N_of_ascii "E" - N_of_ascii "A" <? base)%N.

Definition parse_digits_gen_step (base : N) : ParserAction N
  := (parse_strs
        (List.flat_map
           (fun v => if (v <? 10)%N
                     then [(String (ascii_of_N (v + N_of_ascii "0")) "", v)]
                     else [(String (ascii_of_N (v - 10 + N_of_ascii "A")) "", v);
                             (String (ascii_of_N (v - 10 + N_of_ascii "a")) "", v)])
           (List.map N.of_nat (List.seq 0 (N.to_nat base))))).

(*
Definition parse_oct_digits : ParserAction (list N)
  := Eval cbv -[ParserAction parse_alt_gen parse_impossible parse_str parse_star] in
      parse_digits_gen 8.
Definition parse_dec_digits : ParserAction (list N)
  := Eval cbv -[ParserAction parse_alt_gen parse_impossible parse_str parse_star] in
      parse_digits_gen 10.
Definition parse_hex_digits : ParserAction (list N)
  := Eval cbv -[ParserAction parse_alt_gen parse_impossible parse_str parse_star] in
      parse_digits_gen 16.
 *)

Definition digits_to_N (base : N) (digits : list N) : N
  := List.fold_left
       (fun so_far d => base * so_far + d)%N
       digits
       0%N.

Redirect "log" Check eq_refl : digits_to_N 10 [1;2;3;4;5;6]%N = 123456%N.

Local Coercion N.of_nat : nat >-> N.
Local Coercion Z.of_N : N >-> Z.
Local Coercion inject_Z : Z >-> Q.

Definition parse_N_digits (base : N) : ParserAction N
  := (parse_map (digits_to_N base) ((parse_digits_gen_step base)+)).

Definition parse_num_gen {P P'} (allow_neg : bool) (base : N) (parse_prefix : option (ParserAction P)) (parse_postfix : option (ParserAction P'))  : ParserAction Q
  := (let parse_E_exponent
        := (("e" || "E") ;;->{ fun _ v => Qpower 10 v }
                         (((strip_whitespace_after "-")?)
                            ;;->{ fun n (v:N) => if n:option _ then (-v)%Z else v }
                            (parse_N_digits base)))%parse in
      let parse_P_exponent
        := (("p" || "P") ;;->{ fun _ v => Qpower 2 v }
                         (((strip_whitespace_after "-")?)
                            ;;->{ fun n (v:N) => if n:option _ then (-v)%Z else v }
                            (parse_N_digits base)))%parse in
      (if allow_neg then ((strip_whitespace_after "-")?) else parse_map (fun _ => None) "")
        ;;->{ fun n v => if n:option _ then (-v)%Q else v }
        let parse_main
          := let parse_main_digits := (parse_digits_gen_step base)* in
             (((match parse_prefix with
                | Some _ => parse_main_digits
                | None => parse_digits_gen_step (N.min 10 base) ;;->{cons} parse_main_digits
                end)
                 ;;->{ fun ds decimals
                       => (digits_to_N base ds
                           + digits_to_N base decimals / base^List.length decimals)%Q }
                 "." ;;R
                         (parse_digits_gen_step base)* )
              || parse_map (digits_to_N base : _ -> Q) ((parse_digits_gen_step base)+))
               ;;->{ fun n e => match e with Some e => n * e | None => n end%Q }
               ((if base_accepts_E base
                 then parse_P_exponent (* if [e] is a valid character in the base, then we don't permit [e] as an exponent *)
                 else (parse_E_exponent || parse_P_exponent))?) in
        match parse_prefix, parse_postfix with
        | None, None => parse_main
        | Some parse_prefix, None => parse_prefix ;;R parse_main
        | Some parse_prefix, Some parse_postfix => parse_prefix ;;R parse_main ;;L parse_postfix
        | None, Some parse_postfix => parse_main ;;L parse_postfix
        end)%parse.

Definition parse_num_gen_prefix {P} (allow_neg : bool) (base : N) (parse_prefix : ParserAction P) : ParserAction Q
  := @parse_num_gen P unit allow_neg base (Some parse_prefix) None.
Definition parse_num_gen_postfix {P} (allow_neg : bool) (base : N) (parse_postfix : ParserAction P) : ParserAction Q
  := @parse_num_gen unit P allow_neg base None (Some parse_postfix).

Definition parse_num (allow_neg : bool) : ParserAction Q
  := parse_num_gen_prefix allow_neg 2 parse_bin_prefix
     || parse_num_gen_prefix allow_neg 8 parse_oct_prefix
     || parse_num_gen_prefix allow_neg 10 parse_dec_prefix
     || parse_num_gen_prefix allow_neg 16 parse_hex_prefix
     || parse_num_gen_postfix allow_neg 16 parse_hex_postfix.

Definition parse_int_gen {P P'} (allow_neg : bool) (base : N) (parse_prefix : option (ParserAction P)) (parse_postfix : option (ParserAction P')) : ParserAction Z
  := (let parse_E_exponent
        := (("e" || "E") ;;->{ fun _ (v:N) => Z.pow 10 v } (parse_N_digits base))%parse in
      let parse_P_exponent
        := (("p" || "P") ;;->{ fun _ (v:N) => Z.pow 2 v } (parse_N_digits base))%parse in
      (if allow_neg then ((strip_whitespace_after "-")?) else parse_map (fun _ => None) "")
        ;;->{ fun n v => if n:option _ then (-v)%Z else v }
        let parse_main
          := let parse_main_digits := (parse_digits_gen_step base)* in
             (parse_map
                (digits_to_N base)
                match parse_prefix with
                | Some _ => parse_main_digits
                | None => parse_digits_gen_step (N.min 10 base) ;;->{cons} parse_main_digits
                end)
               ;;->{ fun (n:N) e => match e with Some e => n * e | None => n end%Z }
               ((if base_accepts_E base
                 then parse_P_exponent (* if [e] is a valid character in the base, then we don't permit [e] as an exponent *)
                 else (parse_E_exponent || parse_P_exponent))?) in
        match parse_prefix, parse_postfix with
        | None, None => parse_main
        | Some parse_prefix, None => parse_prefix ;;R parse_main
        | Some parse_prefix, Some parse_postfix => parse_prefix ;;R parse_main ;;L parse_postfix
        | None, Some parse_postfix => parse_main ;;L parse_postfix
        end)%parse.

Definition parse_int_gen_prefix {P} (allow_neg : bool) (base : N) (parse_prefix : ParserAction P) : ParserAction Z
  := @parse_int_gen P unit allow_neg base (Some parse_prefix) None.
Definition parse_int_gen_postfix {P} (allow_neg : bool) (base : N) (parse_postfix : ParserAction P) : ParserAction Z
  := @parse_int_gen unit P allow_neg base None (Some parse_postfix).

Definition parse_int (allow_neg : bool) : ParserAction Z
  := parse_int_gen_prefix allow_neg 2 parse_bin_prefix
     || parse_int_gen_prefix allow_neg 8 parse_oct_prefix
     || parse_int_gen_prefix allow_neg 10 parse_dec_prefix
     || parse_int_gen_prefix allow_neg 16 parse_hex_prefix
     || parse_int_gen_postfix allow_neg 16 parse_hex_postfix.

Redirect "log" Check let ls := [("-1234", -(1234):Q); ("0xF", 15:Q); ("10.5", (10 + 5/10)); ("-10.5", -(10+5/10))]%Q in
                     eq_refl
                     : List.map (fun '(s, v) => ((parse_num true;;->{fun v _ => v} ε)%parse s )) ls
                       = List.map (fun '(s, v) => [(v, "")]) ls.

(* This was previously stack overflowing due to treating [e] as an exponent *)
Redirect "log" Compute parse_num false "0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551".

Inductive Qexpr_poly {var : Type} := Qvar (v : var) | Qv (_ : Q) | Qeopp (a : Qexpr_poly) | Qeadd (a b : Qexpr_poly) | Qesub (a b : Qexpr_poly) | Qemul (a b : Qexpr_poly) | Qediv (a b : Qexpr_poly) | Qepow (b e : Qexpr_poly).
Global Arguments Qexpr_poly var : clear implicits.
Declare Scope Qexpr_scope.
Delimit Scope Qexpr_scope with Qexpr.
Bind Scope Qexpr_scope with Qexpr_poly.
Infix "^" := Qepow : Qexpr_scope.
Infix "*" := Qemul : Qexpr_scope.
Infix "+" := Qeadd : Qexpr_scope.
Infix "/" := Qediv : Qexpr_scope.
Infix "-" := Qesub : Qexpr_scope.
Notation "- x" := (Qeopp x) : Qexpr_scope.
Notation Qexpr := (@Qexpr_poly Empty_set).
Coercion QvQ (x : Q) : Qexpr := Qv x.

Definition monomial_in T var := (T * (var * Z) * list (var * Z (* approximate exponent *)))%type.
Definition poly_in T var := (T * list (monomial_in T var))%type.
Definition reduce_monomial {T var} (var_beq : var -> var -> bool) (m : monomial_in T var) : T + monomial_in T var
  := let '(c, v, vs) := m in
     let vs := List.groupAllBy (fun '(v, _) '(v', _) => var_beq v v') (v :: vs) in
     match Option.List.map
             (fun vs
              => match vs with
                 | [] => None
                 | (v, _) :: _
                   => let e := fold_right Z.add 0%Z (List.map snd vs) in
                      if (Z.eqb e 0)
                      then None
                      else Some (v, e)
                 end)
             vs with
     | [] => inl c
     | v :: vs => inr (c, v, vs)
     end.
Definition const_poly {T var} (v : T) : poly_in T var := (v, []).
Definition var_monomial {T var} (one : T) (v : var) : monomial_in T var := (one, (v, 1%Z), []).
Definition var_poly {T var} (zero : T) (one : T) (v : var) : poly_in T var := (zero, [var_monomial one v]).
Definition add_poly {T var} (addT : T -> T -> T) (p1 p2 : poly_in T var) : poly_in T var
  := let '(c1, p1) := p1 in
     let '(c2, p2) := p2 in
     (addT c1 c2, p1 ++ p2)%list.
Definition mul_monomial {T var} (mulT : T -> T -> T) (m1 m2 : monomial_in T var) : monomial_in T var
  := let '(coef1, (v1, e1), vs1) := m1 in
     let '(coef2, (v2, e2), vs2) := m2 in
     (mulT coef1 coef2, (v1, e1), vs1 ++ (v2, e2) :: vs2)%list.
Definition scmul_monomial {T var} (mulT : T -> T -> T) (sc : T) (m : monomial_in T var) : monomial_in T var
  := let '(coef, (v, e), vs) := m in
     (mulT sc coef, (v, e), vs).
Definition mul_poly {T var} (addT : T -> T -> T) (mulT : T -> T -> T) (p1 p2 : poly_in T var) : poly_in T var
  := let '(c1, p1) := p1 in
     let '(c2, p2) := p2 in
     (mulT c1 c2, List.map (scmul_monomial mulT c1) p2 ++ List.map (scmul_monomial mulT c2) p1 ++ List.flat_map (fun p => List.map (mul_monomial mulT p) p2) p1)%list.
Definition pow_monomial {T var} (powT : T -> Z -> T) (m : monomial_in T var) (e : Z) : monomial_in T var
  := let '(coef, (v, ev), vs) := m in
     (powT coef e, (v, ev + e), List.map (fun '(v, ev) => (v, ev + e)) vs)%Z.
Definition pow_monomial_strict {T var} (powT : T -> Z -> option T) (m : monomial_in T var) (e : Z) : option (monomial_in T var)
  := let '(coef, (v, ev), vs) := m in
     (coef <- powT coef e;
      Some (coef, (v, ev + e), List.map (fun '(v, ev) => (v, ev + e)) vs))%Z%option.
Definition pow_poly {T var} (addT : T -> T -> T) (mulT : T -> T -> T) (powT : T -> Z -> T) (one : T) (p : poly_in T var) (e : Z) : poly_in T var
  := match p with
     | (c, []) => (powT c e, [])
     | (c, _)
       => match e with
          | Z.neg _ => (powT c e, []) (* approximate *)
          | Z0 => (one, [])
          | Z.pos e => BinPos.Pos.iter (mul_poly addT mulT p) (const_poly one) e
          end
     end.
Definition pow_poly_strict {T var} (addT : T -> T -> T) (mulT : T -> T -> T) (powT : T -> Z -> option T) (one : T) (p : poly_in T var) (e : Z) : option (poly_in T var)
  := match p with
     | (c, []) => c <- powT c e; Some (c, [])
     | (c, _)
       => match e with
          | Z.neg _ => None
          | Z0 => Some (one, [])
          | Z.pos e => Some (BinPos.Pos.iter (mul_poly addT mulT p) (const_poly one) e)
          end
end%option.
Definition monomial_var_part_beq {T var} (var_beq : var -> var -> bool) (m1 m2 : monomial_in T var) : bool
  := match reduce_monomial var_beq (mul_monomial (fun a _ => a) m1 (pow_monomial (fun a _ => a) m2 (-1))) with
     | inl _ => true (* the var parts cancel, and we have only a constant part *)
     | inr _ => false (* var parts don't cancel, so must be different *)
     end.
Definition reduce_poly {T var} (var_beq : var -> var -> bool) (T_zero_beq : T -> bool) (reduceT : T -> T) (addT : T -> T -> T) (p : poly_in T var) : poly_in T var
  := let '(c, vs) := p in
     let vs := List.map (reduce_monomial var_beq) vs in
     let cs := Option.List.map (fun v => match v with inl v => Some v | inr _ => None end) vs in
     let vs := Option.List.map (fun v => match v with inr v => Some v | inl _ => None end) vs in
     let c := fold_right addT c cs in
     let vs := List.groupAllBy (monomial_var_part_beq var_beq) vs in
     (reduceT c,
       Option.List.map
         (fun vs
          => match vs with
             | [] => None
             | (c, v0, v0s) :: vs
               => let c := reduceT (fold_right addT c (List.map (fun '(c, _, _) => c) vs)) in
                  if T_zero_beq c
                  then None
                  else Some (c, v0, v0s)
             end)
         vs).

Definition reduce_Qpoly {var} (var_beq : var -> var -> bool) : poly_in Q var -> poly_in Q var
  := reduce_poly var_beq (Qeq_bool 0) Qred Qplus.

Local Notation add_Qpoly := (add_poly Qplus).
Local Notation mul_Qpoly := (mul_poly Qplus Qmult).
Local Notation pow_Qpoly := (pow_poly Qplus Qmult Qpower 1%Q).
Local Notation pow_Qpoly_strict := (pow_poly_strict Qplus Qmult (fun x y => if andb (Qeq_bool x 0) (Z.leb y 0) then None else Some (Qpower x y)) 1%Q).
Local Notation opp_Qpoly := (mul_Qpoly (const_poly (-1)%Q)).
Local Notation sub_Qpoly a b := (add_Qpoly a (opp_Qpoly b)).

Definition poly_coef_map {T1 T2 var} (f : T1 -> T2) (p : poly_in T1 var) : poly_in T2 var
  := let '(c, vs) := p in
     (f c, List.map (fun '(c, v, vs) => (f c, v, vs)) vs).

Definition poly_coef_map_strict {T1 T2 var} (f : T1 -> option T2) (p : poly_in T1 var) : option (poly_in T2 var)
  := let '(c, vs) := p in
     (c <- f c;
      vs <-- List.map (fun '(c, v, vs) => c <- f c; Some (c, v, vs)) vs;
      Some (c, vs))%option.

Fixpoint eval_Qexpr_poly {var} (v : Qexpr_poly var) : poly_in Q var
  := match v with
     | Qvar v => var_poly 0 1 v
     | Qv x => const_poly x
     | Qeopp a => opp_Qpoly (eval_Qexpr_poly a)
     | Qeadd a b => add_Qpoly (eval_Qexpr_poly a) (eval_Qexpr_poly b)
     | Qesub a b => sub_Qpoly (eval_Qexpr_poly a) (eval_Qexpr_poly b)
     | Qemul a b => mul_Qpoly (eval_Qexpr_poly a) (eval_Qexpr_poly b)
     | Qediv a b => mul_Qpoly (eval_Qexpr_poly a) (pow_Qpoly (eval_Qexpr_poly b) (-1))
     | Qepow b e => let b := eval_Qexpr_poly b in
                    let '(e, _) := eval_Qexpr_poly e in
                    let (qe, re) := Z.div_eucl (Qnum e) (Z.pos (Qden e)) in
                    (* (b^qe)*(b^(re/Qden e)) *)
                    mul_Qpoly (pow_Qpoly b qe) (pow_Qpoly b (* approximate *) (re / Z.pos (Qden e)))
     end%Q.

Definition eval_Qexpr (v : Qexpr) : Q
  := match eval_Qexpr_poly v with
     | (c, []) => c
     | (c, (_, (v, _), _)::_) => match v with end
     end.

Fixpoint eval_Qexpr_poly_strict {var} (v : Qexpr_poly var) : option (poly_in Q var)
  := match v with
     | Qvar v => Some (var_poly 0%Q 1%Q v)
     | Qv x => Some (const_poly x)
     | Qeopp a => option_map opp_Qpoly (eval_Qexpr_poly_strict a)
     | Qeadd a b => (a <- eval_Qexpr_poly_strict a; b <- eval_Qexpr_poly_strict b; Some (add_Qpoly a b))
     | Qesub a b => (a <- eval_Qexpr_poly_strict a; b <- eval_Qexpr_poly_strict b; Some (sub_Qpoly a b))
     | Qemul a b => (a <- eval_Qexpr_poly_strict a; b <- eval_Qexpr_poly_strict b; Some (mul_Qpoly a b))
     | Qediv a b => (a <- eval_Qexpr_poly_strict a;
                     b <- eval_Qexpr_poly_strict b;
                     b <- pow_Qpoly_strict b (-1);
                     Some (mul_Qpoly a b))
     | Qepow b e => (b <- eval_Qexpr_poly_strict b;
                     e <- eval_Qexpr_poly_strict e;
                     match e with
                     | (_, _::_) => None
                     | (e, [])
                       => let (qe, re) := Z.div_eucl (Qnum e) (Z.pos (Qden e)) in
                          if Z.eqb re 0
                          then pow_Qpoly_strict b qe
                          else None
                     end)
     end.

Definition eval_Qexpr_strict (v : Qexpr) : option Q
  := match eval_Qexpr_poly_strict v with
     | Some (c, []) => Some c
     | Some (c, (_, (v, _), _)::_) => match v with end
     | None => None
     end.

Definition eval_Qexpr_poly_reduced {var} (var_beq : var -> var -> bool) (v : Qexpr_poly var) : poly_in Q var
  := reduce_Qpoly var_beq (eval_Qexpr_poly v).

Definition eval_Qexpr_poly_reduced_strict {var} (var_beq : var -> var -> bool) (v : Qexpr_poly var) : option (poly_in Q var)
  := option_map (reduce_Qpoly var_beq) (eval_Qexpr_poly_strict v).

Definition parse_ops {A} (ls : list (string * (A -> A -> A))) (parse : ParserAction A) : ParserAction A
  := parse ;;->{fun l fs => List.fold_left (fun v f => f v) fs l}
           (strip_whitespace_around (parse_strs ls) ;;->{fun f r l => f l r}
                                    parse)*.

Definition parse_prefix_ops {A} (ls : list (string * (A -> A))) (parse : ParserAction A) : ParserAction A
  := ((strip_whitespace_after (parse_strs ls))* )
       ;;->{fun ls v => fold_right (fun f x => f x) v ls }
       parse.

Section step.
  Context {var : Type}
          (parse_num : ParserAction Q)
          (parse_var : ParserAction var).
  Local Notation Qexpr_poly := (Qexpr_poly var).
  Context (parse : ParserAction Qexpr_poly).

  Definition parseQexpr_poly_gen_parens : ParserAction Qexpr_poly
    := ("(" ;;->{fun _ v => v} strip_whitespace_around parse ;;->{fun v _ => v} ")")
       || parse_map Qv parse_num
       || parse_map Qvar parse_var.
  Definition parseQexpr_poly_gen_exp : ParserAction Qexpr_poly
    := parse_ops [("^", Qepow)] parseQexpr_poly_gen_parens.
  Definition parseQexpr_poly_gen_opp : ParserAction Qexpr_poly
    := parse_prefix_ops [("-", Qeopp)] parseQexpr_poly_gen_exp.
  Definition parseQexpr_poly_gen_mul_div : ParserAction Qexpr_poly
    := parse_ops [("*", Qemul); ("/", Qediv)] parseQexpr_poly_gen_opp.
  Definition parseQexpr_poly_gen_add_sub : ParserAction Qexpr_poly
    := parse_ops [("+", Qeadd); ("-", Qesub)] parseQexpr_poly_gen_mul_div.
End step.

Fixpoint parse_Qexpr_poly_fueled {var} (parse_num : ParserAction Q) (parse_var : ParserAction var) (fuel : nat) : ParserAction (Qexpr_poly var)
  := strip_whitespace_around
       (parseQexpr_poly_gen_add_sub
          parse_num
          parse_var
          (match fuel with
           | O => parse_impossible
           | S fuel => parse_Qexpr_poly_fueled parse_num parse_var fuel
           end)).

Definition parse_Qexpr_poly_gen {var} (parse_num : ParserAction Q) (parse_var : ParserAction var) : ParserAction (Qexpr_poly var) := fuel (parse_Qexpr_poly_fueled parse_num parse_var).

Definition parse_Qexpr_gen (parse_num : ParserAction Q) : ParserAction Qexpr := parse_Qexpr_poly_gen parse_num parse_impossible.

Definition parse_Qexpr_poly {var} (parse_var : ParserAction var) : ParserAction (Qexpr_poly var) := parse_Qexpr_poly_gen (parse_num false) parse_var.

Definition parse_Qexpr_with_vars (vars : list (string * Q)) : ParserAction Qexpr
  := parse_Qexpr_poly_gen
       (List.fold_right
          (fun '((s, q) : string * Q) default => default || parse_map (fun _ => q) s)%parse
          (parse_num false)
          vars)
       parse_impossible.

Definition Q_to_Z (q : Q) : Z := (Qnum q / Z.pos (Qden q))%Z.
Definition Q_to_Z_strict (x : Q) : option Z
  := let '(q, r) := Z.div_eucl (Qnum x) (Zpos (Qden x)) in
     if Z.eqb r 0
     then Some q
     else None.
Definition N_of_Z_strict (z : Z) : option N
  := match z with Z0 => Some N0 | Zpos p => Some (Npos p) | Zneg _ => None end.
Definition positive_of_N (n : N) : positive
  := match n with N0 => 1%positive | Npos p => p end.
Definition positive_of_N_strict (n : N) : option positive
  := match n with N0 => None | Npos p => Some p end.

Section with_var.
  Context {var : Type}
          (var_beq : var -> var -> bool)
          (parse_var : ParserAction var).

  Definition parse_Q_with_vars (vars : list (string * Q)) : ParserAction Q
    := parse_map eval_Qexpr (parse_Qexpr_with_vars vars).
  Definition parse_Q_strict_with_vars (vars : list (string * Q)) : ParserAction Q
    := parse_option_list_map eval_Qexpr_strict (parse_Qexpr_with_vars vars).
  Definition parse_Q_poly : ParserAction (poly_in Q var)
    := parse_map (eval_Qexpr_poly_reduced var_beq) (parse_Qexpr_poly parse_var).
  Definition parse_Q_poly_strict : ParserAction (poly_in Q var)
    := parse_option_list_map (eval_Qexpr_poly_reduced_strict var_beq) (parse_Qexpr_poly parse_var).
  Definition parse_Z_with_vars (vars : list (string * Q)) : ParserAction Z
    := parse_map Q_to_Z (parse_Q_with_vars vars).
  Definition parse_Z_strict_with_vars (vars : list (string * Q)) : ParserAction Z
    := parse_option_list_map Q_to_Z_strict (parse_Q_strict_with_vars vars).
  Definition parse_Z_poly : ParserAction (poly_in Z var)
    := parse_map (poly_coef_map Q_to_Z) parse_Q_poly.
  Definition parse_Z_poly_strict : ParserAction (poly_in Z var)
    := parse_option_list_map (poly_coef_map_strict Q_to_Z_strict) parse_Q_poly_strict.
  Definition parse_N_with_vars (vars : list (string * Q)) : ParserAction N
    := parse_map Z.to_N (parse_Z_with_vars vars).
  Definition parse_N_strict_with_vars (vars : list (string * Q)) : ParserAction N
    := parse_option_list_map N_of_Z_strict (parse_Z_strict_with_vars vars).
  Definition parse_N_poly : ParserAction (poly_in N var)
    := parse_map (poly_coef_map Z.to_N) parse_Z_poly.
  Definition parse_N_poly_strict : ParserAction (poly_in N var)
    := parse_option_list_map (poly_coef_map_strict N_of_Z_strict) parse_Z_poly_strict.
  Definition parse_nat_with_vars (vars : list (string * Q)) : ParserAction nat
    := parse_map N.to_nat (parse_N_with_vars vars).
  Definition parse_nat_strict_with_vars (vars : list (string * Q)) : ParserAction nat
    := parse_map N.to_nat (parse_N_strict_with_vars vars).
  Definition parse_nat_poly : ParserAction (poly_in nat var)
    := parse_map (poly_coef_map N.to_nat) parse_N_poly.
  Definition parse_nat_poly_strict : ParserAction (poly_in nat var)
    := parse_map (poly_coef_map N.to_nat) parse_N_poly_strict.
  Definition parse_positive_with_vars (vars : list (string * Q)) : ParserAction positive
    := parse_map positive_of_N (parse_N_with_vars vars).
  Definition parse_positive_strict_with_vars (vars : list (string * Q)) : ParserAction positive
    := parse_option_list_map positive_of_N_strict (parse_N_strict_with_vars vars).
  Definition parse_positive_poly : ParserAction (poly_in positive var)
    := parse_map (poly_coef_map positive_of_N) parse_N_poly.
  Definition parse_positive_poly_strict : ParserAction (poly_in positive var)
    := parse_option_list_map (poly_coef_map_strict positive_of_N_strict) parse_N_poly_strict.

  Definition parseQexpr_arith_with_vars (vars : list (string * Q)) (s : string) : option Qexpr
    := finalize (parse_Qexpr_with_vars vars) s.
  Definition parseQ_arith_with_vars (vars : list (string * Q)) (s : string) : option Q
    := option_map eval_Qexpr (parseQexpr_arith_with_vars vars s).
  Definition parseZ_arith_with_vars (vars : list (string * Q)) (s : string) : option Z
    := (q <- parseQ_arith_with_vars vars s; Some (Qnum q / Z.pos (Qden q)))%Z%option.
  Definition parsepositive_arith_with_vars (vars : list (string * Q)) (s : string) : option positive
    := (z <- parseZ_arith_with_vars vars s; match z with Z0 => None | Zpos p => Some p | Zneg _ => None end).
  Definition parseN_arith_with_vars (vars : list (string * Q)) (s : string) : option N
    := (z <- parseZ_arith_with_vars vars s; match z with Z0 => Some 0 | Zpos p => Some (Npos p) | Zneg _ => None end)%N%option.
  Definition parsenat_arith_with_vars (vars : list (string * Q)) (s : string) : option nat
    := (n <- parseN_arith_with_vars vars s; Some (N.to_nat n)).

  Definition parseQ_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option Q
    := (q <- parseQexpr_arith_with_vars vars s; eval_Qexpr_strict q)%option.
  Definition parseZ_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option Z
    := (q <- parseQ_arith_strict_with_vars vars s; Q_to_Z_strict q)%option.
  Definition parsepositive_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option positive
    := (z <- parseZ_arith_strict_with_vars vars s; match z with Z0 => None | Zpos p => Some p | Zneg _ => None end).
  Definition parseN_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option N
    := (z <- parseZ_arith_strict_with_vars vars s; match z with Z0 => Some 0 | Zpos p => Some (Npos p) | Zneg _ => None end)%N%option.
  Definition parsenat_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option nat
    := (n <- parseN_arith_strict_with_vars vars s; Some (N.to_nat n)).

  Definition parseQexpr_poly_arith (s : string) : option (Qexpr_poly var)
    := finalize (parse_Qexpr_poly parse_var) s.
  Definition parseQ_poly_arith (s : string) : option (poly_in Q var)
    := option_map (eval_Qexpr_poly_reduced var_beq) (parseQexpr_poly_arith s).
  Definition parseZ_poly_arith (s : string) : option (poly_in Z var)
    := (q <- parseQ_poly_arith s; Some (poly_coef_map (fun q => (Qnum q / Z.pos (Qden q))%Z) q))%option.
  Definition parsepositive_poly_arith (s : string) : option (poly_in positive var)
    := (z <- parseZ_poly_arith s; poly_coef_map_strict (fun z => match z with Z0 => None | Zpos p => Some p | Zneg _ => None end) z).
  Definition parseN_poly_arith (s : string) : option (poly_in N var)
    := (z <- parseZ_poly_arith s; poly_coef_map_strict (fun z => match z with Z0 => Some 0 | Zpos p => Some (Npos p) | Zneg _ => None end)%N z)%option.
  Definition parsenat_poly_arith (s : string) : option (poly_in nat var)
    := (n <- parseN_poly_arith s; Some (poly_coef_map N.to_nat n)).

  Definition parseQ_poly_arith_strict (s : string) : option (poly_in Q var)
    := (q <- parseQexpr_poly_arith s; eval_Qexpr_poly_strict q)%option.
  Definition parseZ_poly_arith_strict (s : string) : option (poly_in Z var)
    := (q <- parseQ_poly_arith_strict s; poly_coef_map_strict Q_to_Z_strict q)%option.
  Definition parsepositive_poly_arith_strict (s : string) : option (poly_in positive var)
    := (z <- parseZ_poly_arith_strict s; poly_coef_map_strict (fun z => match z with Z0 => None | Zpos p => Some p | Zneg _ => None end) z).
  Definition parseN_poly_arith_strict (s : string) : option (poly_in N var)
    := (z <- parseZ_poly_arith_strict s; poly_coef_map_strict (fun z => match z with Z0 => Some 0 | Zpos p => Some (Npos p) | Zneg _ => None end)%N z)%option.
  Definition parsenat_poly_arith_strict (s : string) : option (poly_in nat var)
    := (n <- parseN_poly_arith_strict s; Some (poly_coef_map N.to_nat n)).

  Definition parse_Qexpr := parse_Qexpr_with_vars [].
  Definition parseQexpr_arith := parseQexpr_arith_with_vars [].
  Definition parseQ_arith := parseQ_arith_with_vars [].
  Definition parseZ_arith := parseZ_arith_with_vars [].
  Definition parsepositive_arith := parsepositive_arith_with_vars [].
  Definition parseN_arith := parseN_arith_with_vars [].
  Definition parsenat_arith := parsenat_arith_with_vars [].
  Definition parseQ_arith_strict := parseQ_arith_strict_with_vars [].
  Definition parseZ_arith_strict := parseZ_arith_strict_with_vars [].
  Definition parsepositive_arith_strict := parsepositive_arith_strict_with_vars [].
  Definition parseN_arith_strict := parseN_arith_strict_with_vars [].
  Definition parsenat_arith_strict := parsenat_arith_strict_with_vars [].

  Definition parse_Q_arith := parse_Q_with_vars [].
  Definition parse_Q_arith_strict := parse_Q_strict_with_vars [].
  Definition parse_Z_arith := parse_Z_with_vars [].
  Definition parse_Z_arith_strict := parse_Z_strict_with_vars [].
  Definition parse_N_arith := parse_N_with_vars [].
  Definition parse_N_arith_strict := parse_N_strict_with_vars [].
  Definition parse_nat_arith := parse_nat_with_vars [].
  Definition parse_nat_arith_strict := parse_nat_strict_with_vars [].
  Definition parse_positive_arith := parse_positive_with_vars [].
  Definition parse_positive_arith_strict := parse_positive_strict_with_vars [].
End with_var.

Redirect "log" Check eq_refl : parseQexpr_arith "1 + -2" = Some (1%Q + - 2%Q)%Qexpr.
Redirect "log" Check eq_refl : parseQ_poly_arith String.eqb "x" "(5 * x + 3 * x^2 + 10)/2" = Some (5, [(5 / 2, ("x", 1%Z), []); (3 / 2, ("x", 2%Z), [])])%Q.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Map.FMapPositive.
Require Import ExtLib.Data.Vector.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.Views.View.
Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Polymorphic.

Set Implicit Arguments.
Set Strict Implicit.

Section poly.
  Context {typ : Set} {sym : Set}.
  Context {RT : RType typ}
          {RS : RSym sym}.

  Variable mkVar : positive -> typ.

  Variable typ_unify : typ -> typ -> pmap typ -> option (pmap typ).

  Definition sym_unifier : Type :=
    sym -> sym -> pmap typ -> option (pmap typ).

  Definition type_sym_unifier : sym_unifier :=
    fun a b s =>
      match typeof_sym a
          , typeof_sym b
      with
      | Some ta , Some tb =>
        match typ_unify ta tb s with
        | Some s' => Some s'
        | None => None
        end
      | _ , _ => None
      end.

  Variable su : sym_unifier.

  (** NOTE: This function does not need to be complete
   ** TODO: We should really stop looking at the term as
   **       soon as we have instantiated everything
   **)
  Local Fixpoint get_types {T} (a b : expr typ sym) (s : pmap typ)
        (ok : pmap typ -> T) (bad : T) {struct a}
  : T :=
    match a , b with
    | App fa aa , App fb ab =>
      get_types fa fb s
                (fun s' => get_types aa ab s' ok bad)
                bad
    | Inj a , Inj b =>
      match su a b s with
      | Some s => ok s
      | None => bad
      end
    | Inj _ , App _ _
    | App _ _ , Inj _
    | Abs _ _ , App _ _
    | App _ _ , Abs _ _ => bad
    | _ , _ => ok s
    end.

  Local Fixpoint build_vector p (n : nat) : vector typ n :=
    match n with
    | 0 => Vnil _
    | S n => Vcons (mkVar p) (build_vector (Pos.succ p) n)
    end.

  Local Fixpoint get_vector {T} n p
  : forall (ok : vector typ n -> T) (bad : T) (m : pmap typ), T :=
    match n as n return (vector typ n -> T) -> T -> pmap typ -> T with
    | 0 => fun ok _ _ => ok (Vnil _)
    | S n => fun ok bad m =>
               match pmap_lookup p m with
               | None => bad
               | Some z => get_vector (Pos.succ p)
                                      (fun vs => ok (Vcons z vs)) bad m
               end
    end.

  Definition get_inst {n} (t : polymorphic typ n (expr typ sym))
             (w : expr typ sym)
  : option (vector typ n) :=
    let t' := inst t (build_vector 1 n) in
    get_types t' w (pmap_empty _)
              (get_vector 1 Some None)
              None.
End poly.


Require Import List.
Require Import Compare_dec.

Require Import Utils.
Require Import SimpSubst.

Require Import Le Lt.
Require Import Plus Minus.

(* Syntax of Simple type system *)

Definition simpFam := list (nat * list nat).

Definition laBump n l := map (varBump n l).
Definition laSubst la l b := map (varSubst l b) la.

Definition pBumpG n l (p:nat * _) := let (f,la) := p in (f,laBump n l la).
Definition pSubstG (p:nat * _) l b := let (f,la) := p in (f,laSubst la l b).

Definition pMSubstG (p:nat * _) v := let (f,la) := p in (f,map (fun a=>match nat_compare a (length v) with
	Lt => nth a v O |
	_ => a - length v
end) la).

Fixpoint fBumpG n l (F:simpFam) : simpFam := match F with
	nil => nil |
	p :: F => pBumpG n l p :: fBumpG n (S l) F
end.

Fixpoint fSubstG (F:simpFam) l b : simpFam := match F with
	nil => nil |
	p :: F => pSubstG p l b :: fSubstG F (S l) b
end.

Definition fBumpD n (F:simpFam) : simpFam := map (fun p:_ * _=>let (f,la) := p in (n + f,la)) F.

Fixpoint fApply (F:simpFam) la := match la with
	nil => F |
	a :: la => fSubstG (tl (fApply F la)) O a
end.

Lemma laBump_O l la : laBump O l la = la.
	unfold laBump.
	rewrite map_ext with (g := fun a=>a).
		rewrite map_id.
		reflexivity.
	intro.
	unfold varBump.
	destruct (nat_compare a l);reflexivity.
Qed.

Lemma laBump_Bump n1 n2 l1 l2 la : (l1 <= l2)->
(laBump n2 (n1 + l2) (laBump n1 l1 la) = laBump n1 l1 (laBump n2 l2 la)).
	intro.
	unfold laBump.
	rewrite map_map.
	rewrite map_map.
	apply map_ext.
	clear la.
	intro i.
	apply varBump_Bump with (1 := H).
Qed.

Lemma laBumpDiv a b n l la : (n <= b)->(laBump a (l + n) (laBump b l la) = laBump (a + b) l la).
	intro.
	unfold laBump.
	rewrite map_map.
	apply map_ext.
	clear la.
	intro i.
	apply varBumpDiv with (1 := H).
Qed.

Lemma laBump_Subst n x la l b :
laBump n (x + l) (laSubst la l b) = laSubst (laBump n (S x + l) la) l (varBump n x b).
	unfold laBump.
	unfold laSubst.
	rewrite map_map.
	rewrite map_map.
	apply map_ext.
	clear la.
	intro i.
	apply varBump_Subst.
Qed.

Lemma laFreeBump n l la : (laBump 1 l la = la)->(laBump n l la = la).
	intro.
	induction n.

	apply laBump_O.

	change (S n) with (1 + n).
	rewrite <- laBumpDiv with (1 := le_O_n _).
	rewrite <- plus_n_O.
	rewrite IHn.
	exact H.
Qed.

Lemma laSubst_Bump n la l1 l2 b : (l1 <= l2)->
(laSubst (laBump n l1 la) (n + l2) b = laBump n l1 (laSubst la l2 b)).
	intro.
	unfold laBump.
	unfold laSubst.
	rewrite map_map.
	rewrite map_map.
	apply map_ext.
	clear la.
	intro i.
	apply varSubst_Bump with (1 := H).
Qed.

Lemma laSubstDiv n la l1 l2 b : (l1 <= l2 <= l1 + n)->(laSubst (laBump (S n) l1 la) l2 b = laBump n l1 la).
	intro.
	unfold laBump.
	unfold laSubst.
	rewrite map_map.
	apply map_ext.
	clear la.
	intro i.
	apply varSubstDiv with (1 := H).
Qed.

Lemma laSubst_Subst x la l b1 b2 : laSubst (laSubst la l b2) (x + l) b1 =
laSubst (laSubst la (S x + l) b1) l (varSubst x b1 b2).
	unfold laSubst.
	rewrite map_map.
	rewrite map_map.
	apply map_ext.
	clear la.
	intro i.
	apply varSubst_Subst.
Qed.

Lemma fBumpG_O F : forall l,fBumpG O l F = F.
	induction F;intro.

	reflexivity.

	destruct a as (f,la).
	simpl.
	rewrite laBump_O.
	rewrite IHF.
	reflexivity.
Qed.

Lemma fSubstG_length F a : forall l,length (fSubstG F l a) = length F.
	induction F as [| p];intro.

	reflexivity.

	simpl.
	rewrite IHF.
	reflexivity.
Qed.

Lemma fSubstG_nth n a : forall F l,(n < length F)->(nth n (fSubstG F l a) (O,nil) = pSubstG (nth n F (O,nil)) (n + l) a).
	induction n;intros ? ?;(destruct F;intro;[destruct lt_n_O with (1 := H) |]);simpl.

	reflexivity.

	rewrite plus_n_Sm.
	apply IHn.
	apply lt_S_n with (1 := H).
Qed.

Lemma pMSubstG_nil p : pMSubstG p nil = p.
	destruct p as (f,la).
	simpl.
	rewrite map_ext with (g := fun a=>a).
		rewrite map_id.
		reflexivity.
	clear f.
	intro.
	rewrite <- minus_n_O.
	destruct (nat_compare_spec a O);try reflexivity.
	destruct lt_n_O with (1 := H).
Qed.

Lemma pMSubstG_snoc p v b : pMSubstG p (v ++ b :: nil) = pMSubstG (pSubstG p (length v) b) v.
	destruct p as (f,la).
	simpl.
	rewrite app_length.
	simpl.
	rewrite <- plus_n_Sm.
	rewrite <- plus_n_O.
	refine (match _ in _ = m return (_,_) = (_,m) with eq_refl => eq_refl _ end).
	clear f.
	unfold laSubst.
	rewrite map_map.
	apply map_ext.
	intro.
	unfold varSubst.
	destruct (nat_compare_spec a (length v)).

	rewrite H.
	rewrite (proj1 (nat_compare_lt _ _) (le_n _)).
	rewrite app_nth2 with (1 := le_n _).
	rewrite <- minus_n_n.
	simpl.
	rewrite minus_plus.
	destruct (nat_compare_spec (length v + b) (length v));try reflexivity.
	destruct (lt_n_O b).
	apply plus_lt_reg_l with (length v).
	rewrite <- plus_n_O.
	exact H0.

	rewrite (proj1 (nat_compare_lt _ _) (lt_S _ _ H)).
	rewrite app_nth1 with (1 := H).
	rewrite (proj1 (nat_compare_lt _ _) H).
	reflexivity.

	destruct a.
		destruct lt_n_O with (1 := H).
	simpl.
	destruct (nat_compare_spec a (length v));try reflexivity.
	destruct (lt_irrefl a).
	apply le_trans with (1 := H0).
	apply le_S_n with (1 := H).
Qed.

Lemma fBumpD_O F : fBumpD O F = F.
	unfold fBumpD.
	simpl.
	rewrite map_ext with (g := fun p=>p).
		rewrite map_id.
		reflexivity.
	intro.
	destruct a as (f,la).
	reflexivity.
Qed.

Lemma fBumpD_length n F : length (fBumpD n F) = length F.
	apply map_length.
Qed.

Lemma fBumpD_nth n m F d : (n < length F)->(nth n (fBumpD m F) d = let (f,la) := nth n F d in (m + f,la)).
	intro.
	unfold fBumpD.
	set (pB (p:_ * list nat) := let (f,la) := p in (m + f,la)).
	fold (pB (nth n F d)).
	rewrite nth_indep with (d' := pB d).
		apply map_nth.
	rewrite map_length.
	exact H.
Qed.

Lemma fApply_nil la : fApply nil la = nil.
	induction la;simpl.

	reflexivity.

	rewrite IHla.
	reflexivity.
Qed.

Lemma fApply_cons p F la a : fApply (p :: F) (la ++ a :: nil) = fApply (fSubstG F O a) la.
	induction la;simpl.

	reflexivity.

	rewrite IHla.
	reflexivity.
Qed.

Lemma fApply_length F la : length (fApply F la) = length F - length la.
	induction la;simpl.

	apply minus_n_O.

	rewrite fSubstG_length.
	rewrite length_tl.
	rewrite IHla.
	apply minus_n_Sm.
Qed.

Lemma fApply_hd la : forall F,(length la < length F)->(hd (O,nil) (fApply F la) = pMSubstG (nth (length la) F (O,nil)) la).
	induction la as [| a] using rev_ind;intro;(destruct F;[intro;destruct lt_n_O with (1 := H) |]).

	simpl.
	intro.
	rewrite pMSubstG_nil.
	reflexivity.

	rewrite app_length.
	simpl plus.
	rewrite <- plus_n_Sm.
	rewrite <- plus_n_O.
	simpl.
	intro.
	pose proof (lt_S_n _ _ H).
	rewrite fApply_cons.
	rewrite IHla;[| rewrite fSubstG_length;exact H0].
	rewrite fSubstG_nth with (1 := H0).
	rewrite <- plus_n_O.
	rewrite pMSubstG_snoc.
	reflexivity.
Qed.

(* Simple typing rules (But I don't mean simply-typed as in simply-typed lambda calculus.) *)

Inductive SimpParamOK G F : list nat->simpFam->Set :=
	spOKNil : SimpParamOK G F nil F |
	spOKCons a la (B:simpFam) : (a < length G)->
		SimpParamOK G F la (pBumpG (S a) O (nth a G (O,nil)) :: B)->
		SimpParamOK G F (a :: la) (fSubstG B O a).

Inductive SimpFamOK (D:list simpFam) G : simpFam->Set :=
	sfOKNil : SimpFamOK D G nil |
	sfOKCons f la T : (f < length D)->
		SimpParamOK G (fBumpD (S f) (nth f D nil)) la nil->
		SimpFamOK D ((f,la) :: G) T->
		SimpFamOK D G ((f,la) :: T).

Inductive SimpFamsOK D : list simpFam->Set :=
	sfsOKOne F : SimpFamOK D nil F->SimpFamsOK D (F :: nil) |
	sfsOKCons F Fs : SimpFamOK D nil F->SimpFamsOK (F :: D) Fs->SimpFamsOK D (F :: Fs).

Inductive SimpFCtxOK : list simpFam->Set :=
	sfcOKNil : SimpFCtxOK nil |
	sfcOKCons D F : SimpFCtxOK D->SimpFamOK D nil F->SimpFCtxOK (F :: D).

Inductive SimpPCtxOK (D:list simpFam) : list (nat * list nat)->Set :=
	spcOKNil : SimpPCtxOK D nil |
	spcOKCons G f la : (f < length D)->
		SimpPCtxOK D G->
		SimpParamOK G (fBumpD (S f) (nth f D nil)) la nil->
		SimpPCtxOK D ((f,la) :: G).

Lemma fctxProjOK f : forall D,SimpFCtxOK D->(f < length D)->SimpFamOK (skipn (S f) D) nil (nth f D nil).
	induction f;intros ? ?;(destruct H;intro;[destruct lt_n_O with (1 := H) |]).

	simpl.
	exact s.

	simpl in H0.
	exact (IHf _ H (lt_S_n _ _ H0)).
Qed.

Lemma pctxProjOK D a P : forall G,SimpPCtxOK D G->(a < length G)->(forall f la,
	((f,la) = nth a G (O,nil))->
	SimpParamOK (skipn (S a) G) (fBumpD (S f) (nth f D nil)) la nil->
P)->P.
	induction a;intros ? ?;(destruct H;intro;[destruct lt_n_O with (1 := H) |]).

	simpl.
	intro rtn.
	exact (rtn _ _ (eq_refl _) s).

	simpl in H0.
	exact (IHa _ H (lt_S_n _ _ H0)).
Qed.

Lemma spOKFree G F la T : SimpParamOK G F la T->(laBump 1 (length G) la = la).
	intro.
	induction H.

	reflexivity.

	simpl.
	rewrite varBumpLo with (1 := l).
	rewrite IHSimpParamOK.
	reflexivity.
Qed.

Lemma sfOKFree D G T : SimpFamOK D G T->(fBumpG 1 (length G) T = T).
	intro.
	induction H.

	reflexivity.

	simpl in IHSimpFamOK |- *.
	rewrite spOKFree with (1 := s).
	rewrite IHSimpFamOK.
	reflexivity.
Qed.

Lemma sfsOKUnzip D F : SimpFamOK D nil F->
	(forall s,(s < length D)->SimpFamOK (skipn (S s) D) nil (nth s D nil))->
SimpFamsOK nil (unzip (length D) D (F :: nil)).
	intros.
	assert (forall s,(s <= length D)->SimpFamsOK (skipn s D) (unzip s D (F :: nil)));
	[|
		pose proof (H1 _ (le_n _));
		rewrite skipnSkipAll in H2;
		exact H2
	].
	intro.
	induction s;intro.

	simpl.
	apply sfsOKOne with (1 := H).

	rewrite <- unzip_consNth with (d := nil) (1 := H1).
	apply sfsOKCons with (1 := H0 _ H1).
	rewrite skipn_consNth with (1 := H1).
	apply IHs.
	apply lt_le_weak with (1 := H1).
Qed.


Require Import BinInt.
From mathcomp Require Import all_ssreflect all_algebra.
Require Import tactics binomialz shift rat_of_Z seq_defs.
Require annotated_recs_c annotated_recs_v algo_closures initial_conds.

Import Order.TTheory GRing.Theory Num.Theory.

Local Open Scope ring_scope.

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

Section ReduceBToOrder2.

Fixpoint b'_rec (n : nat) : rat :=
match n with
| 0 => b 0
| 1 => b 1
| S (S o as o') =>
    let n' := Posz o in
    - (annotated_recs_c.P_cf0 n' * b'_rec o +
       annotated_recs_c.P_cf1 n' * b'_rec o') /
      annotated_recs_c.P_cf2 n'
end.

Lemma b'_rec_eq (o : nat) (n := Posz o) :
  b'_rec o.+2 =
    - (annotated_recs_c.P_cf0 n * b'_rec o +
       annotated_recs_c.P_cf1 n * b'_rec o.+1) /
      annotated_recs_c.P_cf2 n.
Proof.  by [].  Qed.

Definition b' (n : int) : rat :=
match n with
| Negz _ => 0
| Posz o => b'_rec o
end.

Lemma b'_Posz (o : nat) : b' (Posz o) = b'_rec o.
Proof.  done.  Qed.

Lemma b'_Sn2_rew (n : int) :
n >= 0 ->
  b' (int.shift 2 n) =
    - (annotated_recs_c.P_cf0 n * b' n +
       annotated_recs_c.P_cf1 n * b' (int.shift 1 n)) /
      annotated_recs_c.P_cf2 n.
Proof.
case: n => // o _.
rewrite 2!int.shift2Z -2!PoszD.
have -> : (o + 2)%N = o.+2 by rewrite addnC.
have -> : (o + 1)%N = o.+1 by rewrite addnC.
by rewrite b'_Posz b'_rec_eq.
Qed.

Lemma b'0_eq : b' 0 = 0.
Proof.  by rewrite /= initial_conds.b0_eq.  Qed.

Lemma b'1_eq : b' 1 = 6%:Q.
Proof.  by rewrite /= initial_conds.b1_eq.  Qed.

Lemma b'2_eq : b' 2%N = rat_of_Z 351 / rat_of_Z 4.
Proof.
rewrite -[Posz 2]/(int.shift 2 0) b'_Sn2_rew // b'0_eq b'1_eq.
rewrite /annotated_recs_c.P_cf0 /annotated_recs_c.P_cf1 /annotated_recs_c.P_cf2.
by apply/eqP; rewrite rat_of_ZEdef; vm_compute.
(* Faster than: rat_field; goal_to_lia; intlia. *)
Qed.

Lemma b'3_eq : b' 3%N = rat_of_Z 62531 / rat_of_Z 36.
Proof.
rewrite -[Posz 3]/(int.shift 2 1) b'_Sn2_rew // b'1_eq b'2_eq.
rewrite /annotated_recs_c.P_cf0 /annotated_recs_c.P_cf1 /annotated_recs_c.P_cf2.
(* Doesn't finish: apply/eqP; rewrite rat_of_ZEdef; vm_compute. *)
by field.
Qed.

Lemma b'4_eq : b' 4%N = rat_of_Z 11424695 / rat_of_Z 288.
Proof.
rewrite -[Posz 4]/(int.shift 2 2) b'_Sn2_rew // b'2_eq b'3_eq.
rewrite /annotated_recs_c.P_cf0 /annotated_recs_c.P_cf1 /annotated_recs_c.P_cf2.
by field.
Qed.

Lemma b'_Sn4 (n : int) : n >= 0 -> annotated_recs_v.P_horner b' n = 0.
Proof.
move=> ?.
rewrite /annotated_recs_v.P_horner /punk.horner_seqop [LHS]/=.
rewrite !b'_Sn2_rew //; [ | lia ..].
set b'1 := b' _.
set b'2 := b' _.
Fail set b'3 := b' _.
rewrite /annotated_recs_c.P_cf0 /annotated_recs_c.P_cf1 /annotated_recs_c.P_cf2.
rewrite  /annotated_recs_v.P_cf0 /annotated_recs_v.P_cf1.
rewrite /annotated_recs_v.P_cf2 /annotated_recs_v.P_cf3 /annotated_recs_v.P_cf4.
rewrite !rmorphD /=.
field; ring_lia.
Qed.

Lemma Sn4_flat_to_Sn4_rew (w : int -> rat) :
  (forall n : int, 2 <= n :> int -> annotated_recs_v.P_horner w n = 0) ->
  (forall n : int, 2 <= n :> int ->
    w (int.shift 4 n) =
      - (annotated_recs_v.P_cf0 n * w n +
         annotated_recs_v.P_cf1 n * w (int.shift 1 n) +
         annotated_recs_v.P_cf2 n * w (int.shift 2 n) +
         annotated_recs_v.P_cf3 n * w (int.shift 3 n)) /
         annotated_recs_v.P_cf4 n).
Proof.
move=> horner_hyp n le_2_n.
have le_0_n : n >= 0 by apply: (le_trans _ le_2_n).
set goal := (_ = _).
move: {horner_hyp} (horner_hyp n le_2_n).
rewrite /annotated_recs_v.P_horner /punk.horner_seqop /=.
set t0 := (X in _ + X = 0).
set t1 := (X in _ + X + t0 = 0).
set t2 := (X in _ + X + t1 + t0 = 0).
set t3 := (X in _ + X + t2 + t1 + t0 = 0).
set t4 := (X in X + t3 + t2 + t1 + t0 = 0).
move=> horner_hyp.
rewrite {}/goal -{1}/t0 -{1}/t1 -{1}/t2 -{1}/t3.
move: @t4 horner_hyp => /=.
set c4 := annotated_recs_v.P_cf4 n => hyp.
clearbody t0 t1 t2 t3.
have c4_neq_0 : c4 != 0.
  rewrite /c4 /annotated_recs_v.P_cf4.
  apply: mulf_neq0; last by ring_lia.
  apply: mulf_neq0; first by ring_lia.
  apply: lt0r_neq0; apply: addr_gt0; last by ring_lia.
  apply: addr_gt0; last by ring_lia.
  apply: addr_gt0; last by ring_lia.
  by apply: addr_gt0; ring_lia.
clearbody c4.  clear le_0_n.
rewrite mulNr.
apply/eqP.
rewrite -addr_eq0.
have <- : (c4 * (w (int.shift 4 n) + (t0 + t1 + t2 + t3) / c4) == 0) =
    (w (int.shift 4 n) + (t0 + t1 + t2 + t3) / c4 == 0).
  by apply: mulrI_eq0; first by apply/lregP.
rewrite mulrDr [c4 * (_ / c4)]mulrC.
rewrite -{}hyp 3!(int.shiftS n).
apply/eqP.
by field.
Qed.

Lemma shift1_to_plus1 (o : nat) : int.shift 1 (Posz o) = Posz (o.+1).
Proof.  by rewrite /int.shift intS addrC.  Qed.

(* In order to improve modularity wrt to the bound from which we are able to *)
(* establish the recurrence of order 4 for b, we generalize the previous *)
(* version of b'_eq_b which now comes in two steps. The following just says *)
(* that we shift the verification of the initial conditions to the first *)
(* values from which we are able to establish the recurrence by closures. *)
Lemma b'_eq_b_reduction (k : int) :
  2 <= k :> int ->
  b' k = b k -> b' (k + 1) = b (k + 1) ->
  b' (k + 2) = b (k + 2) -> b' (k + 3) = b (k + 3) ->
  forall (n : int), n >= k -> b' n = b n.
Proof.
move=> kpos ebk0 ebk1 ebk2 ebk3 /= n.
(* We would like a usable induction principle on int...*)
(* For now we do the variable change "by hand" in order to call int_rect. *)
pose p : int := n - k; simpl in p.
have -> : n = p + k by rewrite /p addrNK.
clearbody p; clear n.
rewrite ler_addr.
suff gen (n : int) : 0 <= n -> n <= p -> b' (n + k) = b (n + k).
  by move=> p_pos; apply: (gen _ p_pos).
move: n.
elim/int_rect: p => [p h0p hp0 | p ihp n le0n hnp | p _ n hn hp]; last 1 first.
- by have := (le_trans hn hp).
- have -> : p = 0 by apply/eqP; rewrite eq_le h0p hp0.
  by rewrite add0r.
case: (altP (n =P 0)) => [-> | hn0].
  by rewrite add0r.
case: (altP (n =P 1)) => [-> | hn1].
  by rewrite addrC.
case: (altP (n =P 2)) => [-> | hn2].
  by rewrite addrC.
case: (altP (n =P 3)) => [-> | hn3].
  by rewrite addrC.
clear ebk0 ebk1 ebk2 ebk3.
(* Again a variable change. *)
pose m : int := n - (4 : int); simpl in m.
have hm : n = m + 4 by rewrite /m addrK.
have le0m : m >= 0 by lia.
have hmp : m + 3 <= p by lia.
rewrite hm; clearbody m; clear le0n hnp hn0 hn1 hn2 hn3 hm n.
have -> : m + 4 + k = int.shift 4 (m + k).
  by rewrite int.shift2Z addrAC.
have b'_Sn4_from2 n : 2 <= n :> int -> annotated_recs_v.P_horner b' n = 0.
  by move=> hn; apply: b'_Sn4; apply: le_trans hn.
have hmk2 : 2 <= m + k :> int by lia.
rewrite (Sn4_flat_to_Sn4_rew b'_Sn4_from2 hmk2); clear b'_Sn4_from2.
rewrite (Sn4_flat_to_Sn4_rew algo_closures.b_Sn4 hmk2); clear hmk2.
rewrite !int.shift2Z ![m + k + _]addrAC.
by do 4! (rewrite ihp; [| lia ..]).
Qed.

(* Maybe should part of this go to initial_conds. *)
Lemma b'_eq_b (n : int) : n >= Posz 2 -> b' n = b n.
Proof.
apply: b'_eq_b_reduction => //.
- by rewrite b'2_eq initial_conds.b2_eq.
- by rewrite b'3_eq initial_conds.b3_eq.
- rewrite -[(2 : int) + (2 : int)]/(int.shift 2 2).
  rewrite b'_Sn2_rew // b'2_eq b'3_eq.
  rewrite /annotated_recs_c.P_cf0 /annotated_recs_c.P_cf1.
  rewrite /annotated_recs_c.P_cf2.
  by initial_conds.solve_b_evaluation.
- rewrite -[(2 : int) + (3 : int)]/(int.shift 2 3).
  rewrite b'_Sn2_rew // b'3_eq b'4_eq.
  rewrite /annotated_recs_c.P_cf0 /annotated_recs_c.P_cf1.
  rewrite /annotated_recs_c.P_cf2.
  by initial_conds.solve_b_evaluation.
Qed.

Lemma b_Sn2_almost (n : int) :
  n >= 2 :> int -> annotated_recs_c.P_horner b n = 0.
Proof.
move=> h.
rewrite /annotated_recs_c.P_horner/punk.horner_seqop [LHS]/=.
rewrite -!b'_eq_b; [ | lia ..].
have h' : 0 <= n by lia.
rewrite b'_Sn2_rew //.
field.
by apply/expfz_neq0; ring_lia.
Qed.

Lemma b_Sn2_at_0 : annotated_recs_c.P_horner b 0 = 0.
Proof.
rewrite  /annotated_recs_c.P_horner /punk.horner_seqop /=.
rewrite initial_conds.b0_eq initial_conds.b1_eq initial_conds.b2_eq.
rewrite /annotated_recs_c.P_cf1 /annotated_recs_c.P_cf2.
by field; ring_lia.
Qed.

Lemma b_Sn2_at_1 : annotated_recs_c.P_horner b 1 = 0.
Proof.
rewrite /annotated_recs_c.P_horner /punk.horner_seqop /=.
rewrite initial_conds.b1_eq initial_conds.b2_eq initial_conds.b3_eq.
rewrite /annotated_recs_c.P_cf0 /annotated_recs_c.P_cf1 /annotated_recs_c.P_cf2.
by field; ring_lia.
Qed.

Lemma b_Sn2 (n : int) : n >= 0 -> annotated_recs_c.P_horner b n = 0.
Proof.
move=> hn.
case: (altP (n =P 0)) => [-> | h0]; first exact: b_Sn2_at_0.
case: (altP (n =P 1)) => [-> | h1]; first exact: b_Sn2_at_1.
pose p : int := n - (2 : int); simpl in p.
have hnp : n = p + (2 : int) by rewrite /p addrNK.
have {hn h0 h1} le0p : 0 <= p by lia.
have {le0p hnp p} h : (2 : int) <= n by rewrite hnp ler_addr.
exact: b_Sn2_almost.
Qed.

End ReduceBToOrder2.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q : Universe, ((wd_ A B /\ (wd_ C B /\ (wd_ P B /\ (wd_ Q B /\ (wd_ A P /\ (wd_ A C /\ (col_ B P Q /\ col_ B A Q))))))) -> col_ B A P)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.omega.Omega.
Require Import Platform.AutoSep Platform.Bags.

Set Implicit Arguments.

(** * A stronger [starL_weaken] *)

Section starL_weaken_mem.
  Variable A : Type.
  Variables P P' : A -> HProp.

  Theorem starL_weaken_mem : forall ls,
    List.Forall (fun x => P x ===> P' x) ls
    -> starL P ls ===> starL P' ls.
    induction 1; simpl; intuition.
    sepLemma.
    apply Himp_star_frame; auto.
  Qed.
End starL_weaken_mem.

(** * Generic set functionality *)

Module Type S.
  Parameter A : Type.
  Parameter eq_dec : forall x y : A, {x = y} + {x <> y}.
End S.

Module Make(M : S).
  Import M.

  Definition set := A -> Prop.

  Definition mem (x : A) (s : set) := s x.
  Infix "%in" := mem (at level 70, no associativity).

  Definition empty : set := fun _ => False.

  Definition equiv (s1 s2 : set) := forall x, s1 x <-> s2 x.
  Infix "%=" := equiv (at level 70, no associativity).

  Definition incl (s1 s2 : set) : Prop := forall x, s1 x -> s2 x.
  Infix "%<=" := incl (at level 70, no associativity).

  Definition add (s : set) (x : A) : set := fun x' => x' = x \/ s x'.
  Infix "%+" := add (at level 50, left associativity).

  Definition del (s : set) (x : A) : set := fun x' => x' <> x /\ s x'.
  Infix "%-" := del (at level 50, left associativity).

  Ltac sets := subst;
    repeat match goal with
             | [ H : _ %= _ |- _ ] => generalize dependent H
             | [ H : _ %<= _ |- _ ] => generalize dependent H
             | [ H : _ %in _ |- _ ] => generalize dependent H
             | [ H : ~ _ %in _ |- _ ] => generalize dependent H
             | [ H : _ %in _ -> False |- _ ] => generalize dependent H
             | [ H : _ \is _ |- _ ] => generalize dependent H
             | [ H : @eq W _ _ |- _ ] => generalize dependent H
             | [ H : ~(@eq W _ _) |- _ ] => generalize dependent H
           end; clear;
    unfold equiv, empty, incl, mem, add, del, propToWord, IF_then_else; intuition idtac;
      repeat (match goal with
                | [ H : (_, _) = (_, _) |- _ ] => injection H; clear H; intros; subst
                | [ |- context[if ?E then _ else _] ] => destruct E; subst
                | [ _ : context[if ?E then _ else _] |- _ ] => destruct E; subst
              end; intuition idtac);
      try match goal with
            | [ |- _ \/ _ ] => right; intuition idtac
          end;
      repeat match goal with
               | [ x : A, H : forall p : A, _ |- _ ] => specialize (H x)
             end;
      try subst; intuition (try (discriminate || omega)).

  Hint Extern 5 (_ %= _) => sets.
  Hint Extern 5 (_ %<= _) => sets.
  Hint Extern 5 (_ %in _) => sets.
  Hint Extern 5 (~ _ %in _) => sets.
  Hint Extern 5 (_ \is _) => sets.

  Theorem equiv_symm : forall b1 b2,
    b1 %= b2
    -> b2 %= b1.
    sets.
  Qed.

  Theorem equiv_trans : forall b1 b2 b3,
    b1 %= b2
    -> b2 %= b3
    -> b1 %= b3.
    sets.
  Qed.

  Lemma incl_refl : forall b,
    b %<= b.
    sets.
  Qed.

  Lemma incl_trans : forall b1 b2 b3,
    b1 %<= b2
    -> b2 %<= b3
    -> b1 %<= b3.
    sets.
  Qed.

  Lemma incl_mem : forall x b1 b2,
    x %in b1
    -> b1 %<= b2
    -> x %in b2.
    sets.
  Qed.

  Lemma exists_starL_fwd : forall A (P : A -> _) Q,
    (Ex x, P x) * Q ===> Ex x, P x * Q.
    sepLemma.
  Qed.

  Lemma exists_starR_bwd : forall P A (Q : A -> _),
    Ex x, P * Q x ===> P * (Ex x, Q x).
    sepLemma.
  Qed.

  Definition setify (ls : list A) : set :=
    fold_left add ls empty.

  Section starS.
    Variable G : list Type.
    Definition predS := A -> hpropB G.
    Variable P : predS.

    Open Scope Sep_scope.

    Definition starS (s : set) : hpropB G :=
      Ex ls, [| s %= setify ls |] * [| NoDup ls |] * starL P ls.
  End starS.

  Theorem starS_substH_fwd : forall T (P : predS (T :: nil)) b v,
    substH (starS P b) v ===> starS (fun x => substH (P x) v) b.
    unfold starS; intros; autorewrite with sepFormula.
    apply Himp'_ex; intro; apply Himp_ex_c; eexists.
    autorewrite with sepFormula.
    apply Himp_star_frame.
    apply Himp_refl.
    rewrite starL_substH.
    apply Himp_refl.
  Qed.

  Theorem starS_substH_bwd : forall T (P : predS (T :: nil)) b v,
    starS (fun x => substH (P x) v) b ===> substH (starS P b) v.
    unfold starS; intros; autorewrite with sepFormula.
    apply Himp'_ex; intro; apply Himp_ex_c; eexists.
    autorewrite with sepFormula.
    apply Himp_star_frame.
    apply Himp_refl.
    rewrite starL_substH.
    apply Himp_refl.
  Qed.

  Hint Constructors NoDup.

  Section starS_closed.
    Variable P : predS nil.

    Ltac to_himp := repeat intro.
    Ltac from_himp := match goal with
                        | [ |- interp ?specs (?p ?x ?y ---> ?q ?x ?y) ] =>
                          generalize dependent y; generalize dependent x; generalize dependent specs;
                            change (p ===> q)
                      end.

    Theorem starS_empty_bwd : Emp ===> starS P empty.
      to_himp; apply existsR with nil; from_himp; sepLemma.
    Qed.

    Lemma setify_cong : forall ls b1 b2,
      b1 %= b2
      -> fold_left add ls b1 %= fold_left add ls b2.
      induction ls; simpl; intuition.
    Qed.

    Lemma add_something : forall v ls b,
      fold_left add ls (b %+ v) %= fold_left add ls b %+ v.
      induction ls; simpl; intuition.
      eapply equiv_trans; [ | apply IHls ].
      apply setify_cong; auto.
    Qed.

    Lemma setify_include' : forall v ls b b',
      In v ls
      -> b %= fold_left add ls b'
      -> v %in b.
      induction ls; simpl; intuition (subst; eauto).
      assert (b %= fold_left add ls b' %+ v) by (eapply equiv_trans; [ eassumption | apply add_something ]); auto.
    Qed.

    Lemma setify_include : forall v ls b,
      In v ls
      -> b %= setify ls
      -> v %in b.
      intros; eapply setify_include'; eauto.
    Qed.

    Lemma setify_omit : forall v ls b,
      ~v %in b
      -> b %= setify ls
      -> ~In v ls.
      intuition.
      specialize (setify_include _ _ H1 H0); assumption.
    Qed.

    Hint Immediate setify_omit.

    Theorem starS_add_bwd : forall b v, ~v %in b -> starS P b * P v ===> starS P (b %+ v).
      intros; eapply Himp_trans; [ apply exists_starL_fwd | ]; cbv beta.
      to_himp; apply existsL; intro ls; apply existsR with (v :: ls); from_himp.
      simpl; generalize (starL P ls); generalize (P v); sepLemma.
      unfold setify in *; simpl.
      apply equiv_symm; eapply equiv_trans; [ apply add_something | ]; auto.
      eauto.
    Qed.

    Fixpoint nuke (p : A) (ls : list A) : list A :=
      match ls with
        | nil => nil
        | p' :: ls => if eq_dec p p' then ls else p' :: nuke p ls
      end.

    Lemma starL_del_fwd : forall v ls, In v ls
      -> starL P ls ===> P v * starL P (nuke v ls).
      induction ls; unfold setify in *; simpl in *; intuition subst.
      destruct (eq_dec v v); apply Himp_refl || tauto.
      destruct (eq_dec v a); subst; try apply Himp_refl.
      simpl.
      eapply Himp_trans.
      apply Himp_star_frame; [ apply Himp_refl | apply H ].
      generalize (starL P (nuke v ls)); generalize (P a); generalize (P v); sepLemma.
    Qed.

    Lemma In_nuke : forall v x ls,
      In x (nuke v ls)
      -> In x ls.
      induction ls; simpl; intuition;
        match goal with
          | [ _ : context[if ?E then _ else _] |- _ ] => destruct E; subst; simpl in *; intuition
        end.
    Qed.

    Hint Immediate In_nuke.

    Lemma NoDup_nuke : forall v ls,
      NoDup ls
      -> NoDup (nuke v ls).
      induction 1; simpl; intuition;
        match goal with
          | [ |- context[if ?E then _ else _] ] => destruct E; subst
        end; eauto.
    Qed.

    Hint Immediate NoDup_nuke.

    Lemma setify_cases : forall v ls b,
      v %in fold_left add ls b
      -> In v ls \/ v %in b.
      induction ls; simpl; intuition.
      apply IHls in H; intuition sets.
    Qed.

    Lemma setify_In : forall v ls,
      v %in setify ls
      -> In v ls.
      intros; apply setify_cases in H; intuition.
    Qed.

    Lemma setify_In' : forall v ls b,
      v %in b
      -> b %= setify ls
      -> In v ls.
      intros; apply setify_In; sets.
    Qed.

    Hint Immediate setify_In'.

    Lemma setify_nuke' : forall v ls, NoDup ls
      -> forall b b', In v ls
      -> ~v %in b'
      -> b %= fold_left add ls b'
      -> b %- v %= fold_left add (nuke v ls) b'.
      induction 1; simpl; intuition subst;
        match goal with
          | [ |- context[if ?E then _ else _] ] => destruct E; subst; intuition
        end.
      assert (b %= fold_left add l b' %+ v) by (eapply equiv_trans; [ eassumption | apply add_something ]); auto.

      Lemma add_to_del : forall b b' v,
        ~v %in b'
        -> b %= b' %+ v
        -> b %- v %= b'.
        sets.
      Qed.

      apply add_to_del; auto.
      intro.
      apply setify_cases in H4; destruct H4; intuition.

      apply IHNoDup in H3; auto.
      intros.
      assert (v %in b' \/ v = x) by sets.
      tauto.
    Qed.

    Lemma setify_nuke : forall v ls b,
      NoDup ls
      -> In v ls
      -> b %= setify ls
      -> b %- v %= setify (nuke v ls).
      intros; apply setify_nuke'; auto.
    Qed.

    Theorem starS_del_fwd : forall b v, v %in b
      -> starS P b ===> P v * starS P (b %- v).
      intros; eapply Himp_trans; [ | apply exists_starR_bwd ]; cbv beta.
      to_himp; apply existsL; intro ls; apply existsR with (nuke v ls).
      specialize (starL_del_fwd v ls);
        generalize (starL P ls); generalize (P v); generalize (starL P (nuke v ls)).
      intros; from_himp.
      sepLemma.
      apply setify_nuke; eauto.
      transitivity (h0 * h)%Sep; eauto.
      sepLemma.
    Qed.

    Lemma fun_fun_fun : forall A P Q R,
      P * (Ex ls : A, Q ls * R ls)
      ===> (Ex ls : A, Q ls * (P * R ls)).
      sepLemma.
    Qed.

    Theorem starS_del_bwd : forall b v, v %in b
      -> P v * starS P (b %- v) ===> starS P b.
      unfold starS; intros.
      eapply Himp_trans; [ apply fun_fun_fun | ]; cbv beta.
      apply Himp'_ex; intro ls.
      apply Himp_ex_c; exists (v :: ls).
      simpl.
      apply Himp_star_frame; [ | apply Himp_refl ].
      apply Himp_star_pure_c; intro.
      apply Himp_star_pure_cc.
      unfold setify in *; simpl.
      eapply equiv_trans; [ | apply equiv_symm; apply add_something ].

      Lemma del_to_add : forall b b' v,
        v %in b
        -> b %- v %= b'
        -> b %= b' %+ v.
        intros.
        assert (b %- v %+ v %= b' %+ v) by sets.
        clear H0.
        apply equiv_trans with (b %- v %+ v); auto.
        clear H1.
        unfold mem, equiv, del, add in *.
        intros.
        destruct (eq_dec v x); subst; intuition.
      Qed.

      apply del_to_add; auto.

      sepLemma.
      constructor; auto.
      intro.
      eapply setify_include in H2; eauto.
      sets.
    Qed.

    Lemma star_cancel_right : forall a b c, b ===> c -> b * a ===> c * a.
      sepLemma.
    Qed.

    Lemma starS_equiv : forall P a b, a %= b -> starS P a ===> starS P b.
      intros; unfold starS; to_himp; apply existsL; intros; apply existsR with x; from_himp; eapply star_cancel_right; sepLemma.
    Qed.

    Variable P' : predS nil.

    Theorem starS_weaken : forall b,
      (forall x, x %in b -> P x ===> P' x)
      -> starS P b ===> starS P' b.
      unfold starS; intros.
      apply Himp'_ex; intro; apply Himp_ex_c; eexists.
      eapply Himp_trans; [ apply Himp_star_assoc | ].
      apply Himp_star_pure_c; intro.
      apply Himp_star_frame.
      instantiate (1 := x); sepLemma.
      apply starL_weaken_mem; auto.
      apply Forall_forall; intros.
      apply H.
      eapply setify_include; eauto.
    Qed.

    Section starS_weak.
      Hypothesis HP' : forall x, P x ===>* P' x.

      Theorem starS_weaken_weak : forall b, starS P b ===>* starS P' b.
        unfold HimpWeak in *; propxFo.
        do 4 esplit; eauto.
        split.
        eauto 10.
        apply simplify_fwd.
        eapply starL_weaken_weak; eauto.
      Qed.
    End starS_weak.
  End starS_closed.

End Make.