Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.

Section Relations.
  Definition option_eq {A} eq (x y : option A) :=
    match x with
    | None    => y = None
    | Some ax => match y with
                 | None => False
                 | Some ay => eq ax ay
                 end
    end.

  Local Ltac t :=
    cbv; repeat (break_match || intro || intuition congruence ||
                 solve [ apply reflexivity
                       | apply symmetry; eassumption
                       | eapply transitivity; eassumption ] ).

  Global Instance Reflexive_option_eq {T} {R} {Reflexive_R:@Reflexive T R}
    : Reflexive (option_eq R). Proof. t. Qed.

  Global Instance Transitive_option_eq {T} {R} {Transitive_R:@Transitive T R}
    : Transitive (option_eq R). Proof. t. Qed.

  Global Instance Symmetric_option_eq {T} {R} {Symmetric_R:@Symmetric T R}
    : Symmetric (option_eq R). Proof. t. Qed.

  Global Instance Equivalence_option_eq {T} {R} {Equivalence_R:@Equivalence T R}
    : Equivalence (option_eq R). Proof. split; exact _. Qed.
End Relations.

Global Instance Proper_option_rect_nd_changebody
      {A B:Type} {RB:relation B} {a:option A}
  : Proper (pointwise_relation _ RB ==> RB ==> RB) (fun S N => option_rect (fun _ => B) S N a).
Proof. cbv; repeat (intro || break_match); intuition. Qed.

(* FIXME: there used to be a typeclass resolution hint here, something like
  Hint Extern 1 (Proper _ (@option_rect ?A (fun _ => ?B))) => exact (@Proper_option_rect_nd_changebody A B _ _) : typeclass_instances.
 but I could not get it working after generalizing [RB] from [Logic.eq] ~ andreser *)

Global Instance Proper_option_rect_nd_changevalue
      {A B RA RB} some {Proper_some: Proper (RA==>RB) some}
  : Proper (RB ==> option_eq RA ==> RB) (@option_rect A (fun _ => B) some).
Proof. cbv; repeat (intro || break_match || f_equiv || intuition congruence). Qed.

Lemma option_rect_false_returns_true_iff
      {T} {R} {reflexiveR:Reflexive R}
      (f:T->bool) {Proper_f:Proper(R==>eq)f} (o:option T) :
  option_rect (fun _ => bool) f false o = true <-> exists s:T, option_eq R o (Some s) /\ f s = true.
Proof.
  unfold option_rect; break_match; repeat intuition (destruct_head ex; eauto); [ | | congruence.. ].
  { repeat esplit; simpl; easy. }
  { match goal with [H : f _ = true |- f _ = true ] =>
                    solve [rewrite <- H; eauto] end. }
Qed.

Lemma option_rect_false_returns_true_iff_eq
      {T} (f:T->bool) (o:option T) :
  option_rect (fun _ => bool) f false o = true <-> exists s:T, Logic.eq o (Some s) /\ f s = true.
Proof. unfold option_rect; break_match; repeat intuition (destruct_head ex; eauto); congruence. Qed.

Lemma option_rect_option_map : forall {A B C} (f:A->B) some none v,
    option_rect (fun _ => C) (fun x => some (f x)) none v = option_rect (fun _ => C) some none (option_map f v).
Proof.
  destruct v; reflexivity.
Qed.

Lemma option_rect_function {A B C S' N' v} f
  : f (option_rect (fun _ : option A => option B) S' N' v)
    = option_rect (fun _ : option A => C) (fun x => f (S' x)) (f N') v.
Proof. destruct v; reflexivity. Qed.

(*
Ltac commute_option_rect_Let_In := (* pull let binders out side of option_rect pattern matching *)
  idtac;
  lazymatch goal with
  | [ |- ?LHS = option_rect ?P ?S ?N (Let_In ?x ?f) ]
    => (* we want to just do a [change] here, but unification is stupid, so we have to tell it what to unfold in what order *)
    cut (LHS = Let_In x (fun y => option_rect P S N (f y))); cbv beta;
    [ set_evars;
      let H := fresh in
      intro H;
      rewrite H;
      clear;
      abstract (cbv [Let_In]; reflexivity)
    | ]
  end.
*)

Ltac replace_option_match_with_option_rect :=
  idtac;
  lazymatch goal with
  | [ |- _ = ?RHS :> ?T ]
    => lazymatch RHS with
       | match ?a with None => ?N | Some x => @?S x end
         => replace RHS with (option_rect (fun _ => T) S N a) by (destruct a; reflexivity)
       end
  end.

Ltac simpl_option_rect := (* deal with [option_rect _ _ _ None] and [option_rect _ _ _ (Some _)] *)
  repeat match goal with
         | [ |- context[option_rect ?P ?S ?N None] ]
           => change (option_rect P S N None) with N
         | [ |- context[option_rect ?P ?S ?N (Some ?x) ] ]
           => change (option_rect P S N (Some x)) with (S x); cbv beta
         end.

Definition option_leq_to_eq {A} (x y : option A) : x = y -> option_eq eq x y.
Proof. destruct x; intro; subst; simpl; reflexivity. Defined.

Definition option_eq_to_leq {A} (x y : option A) : option_eq eq x y -> x = y.
Proof.
  destruct x, y; simpl;
    try solve [ intros []
              | apply f_equal
              | reflexivity
              | apply eq_sym ].
Defined.

Lemma option_leq_to_eq_to_leq {A x y} v : @option_eq_to_leq A x y (@option_leq_to_eq A x y v) = v.
Proof.
  destruct x; subst; simpl; reflexivity.
Qed.

Lemma option_eq_to_leq_to_eq {A x y} v : @option_leq_to_eq A x y (@option_eq_to_leq A x y v) = v.
Proof.
  compute in *.
  repeat first [ progress subst
               | progress break_innermost_match_step
               | reflexivity ].
Qed.

Lemma UIP_None {A} (p q : @None A = @None A) : p = q.
Proof.
  rewrite <- (option_leq_to_eq_to_leq p), <- (option_leq_to_eq_to_leq q); simpl; reflexivity.
Qed.

Definition invert_Some {A} (x : option A) : match x with
                                            | Some _ => A
                                            | None => unit
                                            end
  := match x with
     | Some x' => x'
     | None => tt
     end.

Lemma invert_eq_Some {A x y} (p : Some x = Some y) : { pf : x = y | @option_eq_to_leq A (Some x) (Some y) pf = p }.
Proof.
  refine (exist _ _ (option_leq_to_eq_to_leq _)).
Qed.

Ltac inversion_option_step :=
  match goal with
  | [ H : Some _ = Some _ |- _ ] => apply option_leq_to_eq in H; unfold option_eq in H
  | [ H : Some _ = Some _ |- _ ]
    => let H' := fresh in
       rename H into H';
       destruct (invert_eq_Some H') as [H ?]; subst H'
  | [ H : None = Some _ |- _ ] => solve [ inversion H ]
  | [ H : Some _ = None |- _ ] => solve [ inversion H ]
  | [ H : None = None |- _ ] => clear H
  | [ H : None = None |- _ ]
    => assert (eq_refl = H) by apply UIP_None; subst H
  end.

Ltac inversion_option := repeat inversion_option_step.


Require Import
        Coq.Lists.SetoidList
        Fiat.QueryStructure.Specification.Representation.QueryStructureNotations.

Open Scope list_scope.

Section PrefixClauses.
  Context {X : Type}
          {X_Qeq : Query_eq X}.

  Definition Prefix (X_eq : X -> X -> Prop)
             (s s' : list X) :=
    exists s'', eqlistA X_eq (s ++ s'') s'.

  Definition IsPrefix (x st : list X) : Prop := @Prefix eq x st.

  Fixpoint Prefix_dec
           {X_eq : X -> X -> Prop}
           (X_eq_dec : forall x x', {X_eq x x'} + {~ X_eq x x'})
           {X_refl : Reflexive X_eq}
           (p s : list X) : {Prefix X_eq p s} + {~ Prefix X_eq p s}.
  refine (match p, s with
            | nil, _ => left _
            | p' :: ps, s' :: ss =>
              if X_eq_dec p' s' then
                if Prefix_dec X_eq X_eq_dec _ ps ss then
                  left _
                else
                  right _
              else
                right _
            | _, _ => right _
          end);  intuition; [
    eexists; intuition |
    inject H |
    let _H0 := match goal with H : ?R _ _ |- _ => constr:(H) end in
    destruct _H0; eexists; simpl; subst |
    let _H0 := match goal with H : ?R _ _ -> False |- _ => constr:(H) end in
    apply _H0; inject H; inversion H0; eexists |
    inject H; simpl in H0; inversion H0 ]; eauto.
  inversion H0.
  Defined.

  Definition IsPrefix_dec
    : forall (p s : list X), {IsPrefix p s} + {~ IsPrefix p s}
  := @Prefix_dec _ A_eq_dec (fun a => eq_refl a).
  Ltac prefix_crush := intros; find_if_inside; intuition eauto; discriminate.

  Instance DecideableEnsemble_HasPrefix st :
    DecideableEnsemble (IsPrefix st) :=
    {| dec a := ?[IsPrefix_dec st a] |}. prefix_crush. Defined.

  Global Instance DecideableEnsemble_HasPrefix_f
         (A : Type)
         (f : A -> list X)
         b :
    DecideableEnsemble (fun a => IsPrefix b (f a)) :=
    {| dec a := ?[IsPrefix_dec b (f a)] |}. prefix_crush. Defined.

  Instance DecideableEnsemble_FindPrefix st :
    DecideableEnsemble (fun a => IsPrefix a st) :=
    {| dec a := ?[IsPrefix_dec a st] |}. prefix_crush. Defined.

  Global Instance DecideableEnsemble_FindPrefix_f
         (A : Type)
         (f : A -> list X)
         b :
    DecideableEnsemble (fun a => IsPrefix (f a) b) :=
    {| dec a := ?[IsPrefix_dec (f a) b] |}. prefix_crush. Defined.
End PrefixClauses.


From Coq Require Import Reals Psatz.
From self.prelude Require Import base.

(* Notation "x ≤ y" := (Rle x y) (at level 70, no associativity) : R_scope. *)
(* Notation "x ≥ y" := (Rge x y) (at level 70, no associativity) : R_scope. *)

#[local] Open Scope R.

#[global] Instance Rge_Transitive: Transitive Rge.
Proof. intros ???. eapply Rge_trans. Qed.
#[global] Instance Rle_Transitive: Transitive Rle.
Proof. intros ???. eapply Rle_trans. Qed.
#[global] Instance Rge_Reflexive: Reflexive Rge.
Proof. intros ?. eapply Rge_refl. Qed.
#[global] Instance Rle_Reflexive: Reflexive Rle.
Proof. intros ?. eapply Rle_refl. Qed.
#[global] Instance Rgt_Transitive: Transitive Rgt.
Proof. intros ???. eapply Rgt_trans. Qed.
#[global] Instance Rlt_Transitive: Transitive Rlt.
Proof. intros ???. eapply Rlt_trans. Qed.

#[global] Instance Rgt_decision (r1 r2 : R) : Decision (Rgt r1 r2).
Proof. apply Rgt_dec. Qed.
#[global] Instance Rge_decision (r1 r2 : R) : Decision (Rge r1 r2).
Proof. apply Rge_dec. Qed.
#[global] Instance Rlt_decision (r1 r2 : R) : Decision (Rlt r1 r2).
Proof. apply Rlt_dec. Qed.
#[global] Instance Rle_decision (r1 r2 : R) : Decision (Rle r1 r2).
Proof. apply Rle_dec. Qed.

#[global] Instance Rlt_plus_proper: Proper (Rlt ==> Rlt ==> Rlt) Rplus.
Proof.
  intros ?? Hle ?? Hle'. apply Rplus_lt_compat; auto.
Qed.
#[global] Instance Rlt_plus_proper': Proper (Rlt ==> eq ==> Rlt) Rplus.
Proof.
  intros ?? Hle ?? Hle'. subst. nra.
Qed.
#[global] Instance Rlt_plus_proper'': Proper (Rlt ==> Rle ==> Rlt) Rplus.
Proof.
  intros ?? Hle ?? Hle'. subst. nra.
Qed.

#[global] Instance Rle_plus_proper_left: Proper (Rle ==> eq ==> Rle) Rplus.
Proof. intros ?? Hle ?? Hle'. nra. Qed.
#[global] Instance Rle_plus_proper_right: Proper (eq ==> Rle ==> Rle) Rplus.
Proof. intros ?? Hle ?? Hle'. nra. Qed.
#[global] Instance Rle_plus_proper: Proper (Rle ==> Rle ==> Rle) Rplus.
Proof. intros ?? Hle ?? Hle'. nra. Qed.

Lemma Rmax_INR a b: Rmax (INR a) (INR b) = INR (max a b).
Proof.
  apply Rmax_case_strong; intros ?%INR_le; f_equal;
    [ rewrite Nat.max_l // | rewrite Nat.max_r // ].
Qed.

Lemma Rmult_neq_0 (r1 r2 : R) :
  r1 * r2 ≠ 0 → r1 ≠ 0 ∧ r2 ≠ 0.
Proof. intros ?. split; intros ->; lra. Qed.

Lemma Rmult_neq_0_pos (r1 r2 : R) :
  r1 * r2 ≠ 0 → 0 <= r1 → 0 <= r2 → 0 < r1 ∧ 0 < r2.
Proof. intros [? ?]%Rmult_neq_0 ? ?. lra. Qed.

Lemma Rle_plus_plus (r1 r2 r3 r4 : R) :
  r1 <= r3 → r2 <= r4 → r1 + r2 <= r3 + r4.
Proof. lra. Qed.

Lemma Rle_plus_l (r1 r2 r3 : R) :
  r1 <= r2 → 0 <= r3 → r1 <= r2 + r3.
Proof. lra. Qed.

Lemma pos_sum_nn_real p q :
    0 <= p →
    0 <= q →
    0 < p + q →
    0 < p ∨ 0 < q.
  Proof.
    intros Hp Hq Hsum.
    destruct Hp as [ Hp | Hp ]; simplify_eq; auto.
    destruct Hq as [ Hq | Hq ]; simplify_eq; auto.
    lra.
  Qed.

Lemma pos_prod_nn_real p q :
    0 <= p →
    0 <= q →
    0 < p * q →
    0 < p ∧ 0 < q.
  Proof.
    intros Hp Hq Hsum.
    destruct Hp as [ Hp | Hp ]; simplify_eq; split; auto; try lra.
    destruct Hq as [ Hq | Hq ]; simplify_eq ; auto; lra.
  Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Subcat.
Require Export Set_cat.
(** Title "The category of semi-groups." *)

Definition law_of_composition (E : SET) := Hom (cart E E:SET) E.

Definition associative (E : SET) (f : law_of_composition E) :=
  forall x y z : E,
  Equal (f (couple (f (couple x y)) z)) (f (couple x (f (couple y z)))).

Record sgroup_on (E : SET) : Type :=
  {sgroup_law_map : law_of_composition E;
   sgroup_assoc_prf : associative sgroup_law_map}.

Record sgroup : Type :=
  {sgroup_set :> Setoid; sgroup_on_def :> sgroup_on sgroup_set}.
Coercion Build_sgroup : sgroup_on >-> sgroup.
Set Strict Implicit.
Unset Implicit Arguments.

Definition sgroup_law (E : sgroup) : E -> E -> E :=
  fun x y : E:Setoid => sgroup_law_map E (couple x y).
Set Implicit Arguments.
Unset Strict Implicit.
Section Hom.
Variable E F : sgroup.

Definition sgroup_hom_prop (f : Hom (E:SET) F) :=
  forall x y : E, Equal (f (sgroup_law _ x y)) (sgroup_law _ (f x) (f y)).

Record sgroup_hom : Type :=
  {sgroup_map :> Map E F; sgroup_hom_prf : sgroup_hom_prop sgroup_map}.
End Hom.

Definition sgroup_hom_comp :
  forall E F G : sgroup, sgroup_hom F G -> sgroup_hom E F -> sgroup_hom E G.
intros E F G g f; try assumption.
apply (Build_sgroup_hom (sgroup_map:=comp_map_map g f)).
unfold sgroup_hom_prop in |- *; auto with algebra.
simpl in |- *.
unfold comp_map_fun in |- *.
intros x y; try assumption.
apply
 Trans
  with
    (Ap (sgroup_map g)
       (sgroup_law _ (Ap (sgroup_map f) x) (Ap (sgroup_map f) y)));
 auto with algebra.
cut
 (Equal (Ap (sgroup_map f) (sgroup_law _ x y))
    (sgroup_law _ (Ap (sgroup_map f) x) (Ap (sgroup_map f) y))).
auto with algebra.
apply (sgroup_hom_prf f).
apply (sgroup_hom_prf g).
Defined.

Definition sgroup_id : forall E : sgroup, sgroup_hom E E.
intros E; try assumption.
apply (Build_sgroup_hom (sgroup_map:=Id E)).
red in |- *.
simpl in |- *; auto with algebra.
Defined.

Definition SGROUP : category.
apply
 (subcat (C:=SET) (C':=sgroup) (i:=sgroup_set)
    (homC':=fun E F : sgroup =>
            Build_subtype_image (E:=MAP E F)
              (subtype_image_carrier:=sgroup_hom E F)
              (sgroup_map (E:=E) (F:=F))) (CompC':=sgroup_hom_comp)
    (idC':=sgroup_id)).
simpl in |- *.
intros a; try assumption.
red in |- *.
auto with algebra.
simpl in |- *.
intros a b c g f; try assumption.
red in |- *.
auto with algebra.
Defined.


Require Import VST.veric.base.
Require Import VST.veric.initial_world.

Lemma filter_filter {A f1 f2}: forall {l:list A},
      filter f1 (filter f2 l) = filter (fun x => andb (f1 x) (f2 x)) l.
Proof.
  induction l; simpl; trivial.
  remember (f1 a) as b1; destruct b1; simpl.
+ destruct (f2 a); simpl; [ rewrite <- Heqb1, IHl |]; trivial.
+  destruct (f2 a); simpl; [ rewrite <- Heqb1 |] ; trivial.
Qed.

Lemma filter_filter_comm {A f1 f2}: forall {l:list A},
      filter f1 (filter f2 l) = filter f2 (filter f1 l).
Proof.
  induction l; simpl; trivial.
  remember (f1 a) as b1; destruct b1; simpl.
+ destruct (f2 a); simpl; [ rewrite <- Heqb1, IHl |]; trivial.
+  destruct (f2 a); simpl; [ rewrite <- Heqb1 |] ; trivial.
Qed.

Lemma app_inj_length {A}: forall {l1 l1' l2 l2'} (L:l1 ++ l2 = l1'++l2') (LEN: @length A l1 = length l1'),
      l1=l1' /\ l2=l2'.
Proof.
  induction l1; simpl; intros.
  + destruct l1'; inv LEN. split; trivial.
  + destruct l1'; inv LEN; simpl in *. inv L.
    destruct (IHl1 _ _ _ H2 H0); subst. split; trivial.
Qed.

Lemma filter_app {A f}: forall {l1 l2: list A}, filter f (l1++l2) = filter f l1 ++ filter f l2.
Proof. induction l1; simpl; intros. trivial. rewrite IHl1. destruct (f a); trivial. Qed.

Lemma id_in_list_app {i l1 l2}: id_in_list i (l1++l2) = orb (id_in_list i l1) (id_in_list i l2).
Proof. induction l1; simpl; [ trivial | rewrite IHl1, orb_assoc; trivial]. Qed.

Lemma find_id_None_iff {A} i: forall (l:list (ident * A)), find_id i l = None <-> ~ In i (map fst l).
Proof.
  induction l; simpl.
+ split; intros; auto.
+ destruct a as [i' a]; simpl.
  destruct (eq_dec i i'); subst; split; intros; [ inv H | | |]; intuition.
Qed.

Lemma find_id_filter_char {A f}: forall l (L: list_norepet (map fst l)) i,
  find_id i (filter f l) = match @find_id A i l with
                           Some x => if f (i,x) then Some x else None
                         | None => None
                         end.
Proof.
  induction l; simpl. trivial.
  intros. destruct a as [j a]. simpl in L; inv L.
  remember (f (j,a)) as d; destruct d; simpl.
  + if_tac; [ subst; rewrite <- Heqd; trivial | auto].
  + specialize (IHl H2). apply find_id_None_iff in H1.
    if_tac; [ subst; rewrite <- Heqd, IHl, H1; trivial | auto].
Qed.

Lemma find_id_filter_Some {A f i l} {a:A}: find_id i (filter f l) = Some a ->
      list_norepet (map fst l) -> find_id i l = Some a /\ f (i,a) = true.
Proof.
  intros. rewrite find_id_filter_char in H; trivial.
  destruct (find_id i l) as [b |]; [ | discriminate].
  remember (f (i, b)) as c; destruct c; [ inv H; rewrite Heqc; split; trivial | discriminate] .
Qed.

Lemma find_id_in_split {A i} {a:A}: forall {l} (Hi: find_id i l = Some a) (LNR: list_norepet (map fst l)),
  exists l1 l2, l=l1++(i,a)::l2 /\ find_id i l1 = None /\ find_id i l2=None.
Proof.
  induction l; simpl; intros. inv Hi. inv LNR; destruct a0 as [j b]; simpl in *.
  if_tac in Hi; [inv Hi |].
+ exists nil, l. split3; trivial. apply find_id_None_iff; trivial.
+ destruct (IHl Hi H2) as [l1 [l2 [Ha [L1 L2]]]]; clear IHl; subst.
  exists ((j, b) :: l1), l2; split3; trivial; simpl.
  rewrite if_false; trivial.
Qed.

Lemma id_in_list_false_i i l: ~ In i l -> id_in_list i l = false.
Proof.
  induction l; simpl; intros; trivial.
  remember (Pos.eqb i a) as b; symmetry in Heqb; destruct b; simpl.
  + apply Peqb_true_eq in Heqb; subst. elim H; left; trivial.
  + apply IHl. intros N. apply H; right; trivial.
Qed.

Lemma id_in_list_true_i i l: In i l -> id_in_list i l = true.
Proof.
  induction l; simpl; intros. contradiction.
  destruct H; subst.
  + remember (Pos.eqb i i) as b; destruct b; simpl. trivial.
    symmetry in Heqb. apply Pos.eqb_neq in Heqb. congruence.
  + rewrite (IHl H), orb_true_r; trivial.
Qed.

Lemma find_id_cons_char {A} l i (a:ident*A): find_id i (a::l) = if ident_eq i (fst a) then Some(snd a) else find_id i l.
Proof. destruct a; reflexivity. Qed.

Lemma In_map_fst_find_id {A i l} (Hi: In i (map fst l)) (L:list_norepet (map fst l)): exists a:A, find_id i l = Some a.
Proof.
  apply list_in_map_inv in Hi. destruct Hi as [[j a] [J Ha]]. simpl in J; subst.
  apply find_id_i in Ha. exists a; trivial. trivial.
Qed.

Lemma list_norepet_map_fst_filter {A f}: forall (l: list (ident * A)),
 list_norepet (map fst l) ->
 list_norepet (map fst (filter f l)).
Proof.
  induction l; simpl; intros; trivial. inv H. specialize (IHl H3).
  remember (f a) as q; destruct q; trivial. simpl.
  constructor; trivial. intros N; apply H2; clear H2.
  destruct a as [i a]; simpl in *.
  apply list_in_map_inv in N. destruct N as [x [X F]]; subst.
  destruct x as [j x]; simpl in *.
  apply filter_In in F. destruct F. apply (in_map fst) in H. apply H.
Qed.

Lemma find_id_app_char {A}: forall l1 l2 i,
  find_id i (l1 ++ l2) = match @find_id A i l1 with
                           Some x => Some x
                         | None => find_id i l2
                         end.
Proof.
  induction l1; simpl. trivial.
  intros. destruct a as [j a].
  if_tac. trivial. auto.
Qed.

Lemma list_disjoint_map_fst_find_id1 {A B l1 l2} (D: list_disjoint (map fst l1) (map fst l2)) i a:
      @find_id A i l1 = Some a -> @find_id B i l2 = None.
Proof.
  intros. remember (find_id i l2) as q; destruct q; [symmetry in Heqq | trivial].
  apply find_id_e in H. apply (in_map fst) in H.
  apply find_id_e in Heqq. apply (in_map fst) in Heqq.
  elim (D i i); trivial.
Qed.

Lemma list_disjoint_map_fst_find_id2 {A B l1 l2} (D: list_disjoint (map fst l1) (map fst l2)) i a:
      @find_id A i l2 = Some a -> @find_id B i l1 = None.
Proof.
  intros. apply list_disjoint_sym in D. eapply list_disjoint_map_fst_find_id1; eassumption.
Qed.

Lemma list_norepet_find_id_app_exclusive1 {A B} {l1 : list (ident *A)} {l2:list (ident * B)}
      (LNR: list_norepet (map fst l1 ++ map fst l2)) {i a} (Hi: find_id i l1 = Some a): find_id i l2 = None.
Proof. clear - LNR Hi.
  apply find_id_None_iff; intros N. apply find_id_In_map_fst in Hi.
  apply list_norepet_app in LNR. destruct LNR as [_ [_ D]]. apply (D i i); trivial.
Qed.

Lemma list_norepet_find_id_app_exclusive2 {A B} {l1 : list (ident *A)} {l2:list (ident * B)}
      (LNR: list_norepet (map fst l1 ++ map fst l2)) {i b} (Hi: find_id i l2 = Some b): find_id i l1 = None.
Proof. clear - LNR Hi.
  apply find_id_None_iff; intros N. apply find_id_In_map_fst in Hi.
  apply list_norepet_app in LNR. destruct LNR as [_ [_ D]]. apply (D i i); trivial.
Qed.

Lemma id_in_list_map_filter {A f i} {l:list (ident *A)} (Hi:id_in_list i (map fst l) = false):
      id_in_list i (map fst (filter f l)) = false.
Proof.
  apply id_in_list_false in Hi. apply id_in_list_false_i. intros N; apply Hi; clear Hi.
  apply list_in_map_inv in N. destruct N as [[j fd] [HI F]]; simpl in HI; subst.
  apply filter_In in F. destruct F as [F _]. apply (in_map fst) in F; apply F.
Qed.

Lemma negb_ident_eq_symm j i: negb (ident_eq j i) = negb (ident_eq i j).
Proof.
  destruct (ident_eq j i); subst; simpl.
+ destruct (ident_eq i i); subst; simpl; trivial. congruence.
+ destruct (ident_eq i j); subst; simpl; trivial. congruence.
Qed.

Lemma sublist_map_fst {A B} {f:A->B}: forall l k, sublist l k -> sublist (map f l) (map f k).
Proof.
  induction l; simpl; intros. inv H; simpl; constructor.
  + induction l2; simpl. constructor. inv H0. constructor. auto.
  + induction k.
    - inv H; simpl; constructor.
    - inv H; simpl; constructor; auto.
Qed.

Lemma sublist_nil_l {A}: forall (l:list A), sublist nil l.
Proof. induction l; constructor; trivial. Qed.

Lemma sublist_filter {A f}: forall l:list A, sublist (filter f l) l.
Proof.
  intros. remember (filter f l) as fl. generalize dependent l.
  induction fl; simpl; intros; try constructor.
  + apply sublist_nil_l.
  + induction l; simpl in Heqfl. congruence.
    destruct (f a0).
    - inv Heqfl. constructor. auto.
    - constructor. auto.
Qed.

Lemma list_disjoint_sublist {A}: forall l1 k1, sublist k1 l1 -> forall l2 k2, sublist k2 l2 -> @list_disjoint A l1 l2 -> list_disjoint k1 k2.
Proof.
  intros. intros ? ? ? ? ?; subst.
  specialize (sublist_In _ _ _ H H2); intros.
  specialize (sublist_In _ _ _ H0 H3); intros.
  apply (H1 y y); trivial.
Qed.

Lemma sublist_refl {A}: forall (l:list A), sublist l l.
Proof. induction l; constructor; trivial. Qed.

Lemma list_disjoint_mono {A} (l1 l1' l2 l2': list A) (L: list_disjoint l1' l2')
      (H1: forall x, In x l2 -> In x l2') (H2: forall x, In x l1 -> In x l1'):
      list_disjoint l1 l2.
Proof. do 4 intros ?; subst. apply (L x y); eauto. Qed.

Lemma list_disjoint_app_L {A} (l1 l2 l: list A)
      (L1: list_disjoint l1 l) (L2: list_disjoint l2 l): list_disjoint (l1++l2) l.
Proof.
  do 4 intros ?. apply in_app_or in H; destruct H.
  apply (L1 x y); trivial. apply (L2 x y); trivial.
Qed.

Lemma list_disjoint_app_R {A} (l l2 l3: list A)
      (L2: list_disjoint l l2) (L3: list_disjoint l l3): list_disjoint l (l2++l3).
Proof.
  apply list_disjoint_sym. apply list_disjoint_sym in L2. apply list_disjoint_sym in L3.
  apply list_disjoint_app_L; trivial.
Qed.

Lemma sublist_trans {A}: forall {l3 l2:list A} (L23: sublist l2 l3) l1 (L12: sublist l1 l2),
      sublist l1 l3.
Proof.
 intros l3 l2 L23. induction L23.
+ trivial.
+ intros. inv L12; constructor; auto.
+ rename l2 into l3. rename l1 into l2. intros l1 L12.
  apply IHL23 in L12. constructor; trivial.
Qed.

Lemma sublist_app {A}: forall {l l1 l2:list A} (L: sublist l1 l2), sublist (l++l1) (l++l2).
Proof. induction l; simpl; intros; [trivial | constructor; auto]. Qed.

Lemma sublist_app_R1 {A}: forall {l l':list A}, sublist l (l++l').
Proof. induction l; simpl; intros; [ apply sublist_nil_l | constructor; auto]. Qed.

Lemma sublist_app_R2 {A}: forall {l l':list A}, sublist l' (l++l').
Proof. induction l; simpl; intros; [ apply sublist_refl | constructor; auto]. Qed.

Lemma sublist_snoc {A}: forall l l' (L : sublist l l') (a:A),
      sublist (l ++ a :: nil) (l' ++ a :: nil).
Proof.
  intros l l' L.
  induction L.
+ simpl; intros. constructor. constructor.
+ simpl; intros. constructor. auto.
+ simpl; intros. eapply sublist_trans. 2: apply (IHL a0).
  constructor; apply sublist_refl.
Qed.

Lemma sublist_snoc_R {A}: forall l l' (L : sublist l l') (a:A),
      sublist l (l' ++ a :: nil).
Proof.
  intros l l' L.
  induction L; simpl; intros; [ apply sublist_nil_l | | ]; constructor; auto.
Qed.

Lemma sublist_app_split {A}: forall {l2 l2':list A} (L2: sublist l2 l2') {l1 l1'}
      (L1: sublist l1 l1'), sublist (l1++l2) (l1'++l2').
Proof.
  intros l2 l2' L2. induction L2.
+ intros. rewrite 2 app_nil_r; trivial.
+ rename l2 into l2'. rename l1 into l2. intros.
  specialize (IHL2 (l1 ++ (cons a nil)) (l1' ++ (cons a nil))).
  do 2 rewrite <- app_assoc in IHL2. apply IHL2; clear IHL2.
  apply sublist_snoc; trivial.
+ rename l2 into l2'. rename l1 into l2. intros.
  specialize (IHL2 l1 (l1' ++ (cons a nil))).
  rewrite <- app_assoc in IHL2. apply IHL2; clear IHL2.
  apply sublist_snoc_R; trivial.
Qed.

Lemma sublist_app_right1 {A}: forall {l1 l l2: list A}, sublist l l2 -> sublist l (l1 ++ l2).
Proof.
  induction l1; simpl; intros. trivial.
  constructor. auto.
Qed.

Lemma sublist_app_right2 {A} {l2 l l1: list A} (L:sublist l l1): sublist l (l1 ++ l2).
Proof. eapply sublist_trans. apply sublist_app_R1. eassumption. Qed.

Lemma sublist_filter_true {A f}: forall {l k: list A}, sublist l k ->
      (forall x, In x l -> f x = true) -> sublist l (filter f k).
Proof.
  intros. induction H; simpl. apply sublist_nil_l.
  rewrite (H0 a). constructor. apply IHsublist. intros. apply H0; right; trivial. left; trivial.
  destruct (f a). constructor; auto. auto.
Qed.

Lemma find_id_filter_None_I {A} f (l:list(ident *A)) i: find_id i l = None -> list_norepet (map fst l) -> find_id i (filter f l) = None.
Proof. intros. rewrite find_id_filter_char, H; trivial. Qed.

Lemma filter_fg {A f g} (l: list A) (FG: forall x, In x l -> f x = g x): filter f l = filter g l.
Proof. induction l; simpl; trivial. rewrite IHl, FG. trivial. left; trivial. intros. apply FG. right; trivial. Qed.

Lemma filter_cons {A P a} {l:list A}: filter P (a::l) = filter P (a::nil) ++ filter P l.
Proof. simpl. destruct (P a); trivial. Qed.

Lemma Indec1 i l: In i l -> true = in_dec ident_eq i l.
Proof. destruct (in_dec ident_eq i l); intros. reflexivity. elim (n H). Qed.

Lemma Indec2 i l: true = in_dec ident_eq i l -> In i l.
Proof. destruct (in_dec ident_eq i l); intros. trivial. inv H. Qed.

Lemma In_map_fst_filter {A}: forall (L: list (ident * A)) i l,
      In i l -> In i (map fst L) ->
      In i (map fst (filter (fun a : positive * A =>  in_dec ident_eq (fst a) l) L)) .
Proof. induction L; simpl; intros; trivial. unfold ident in *.
  destruct H0; subst; simpl.
  + clear IHL. rewrite <- (Indec1 _ _ H). simpl; left; trivial.
  +  specialize (IHL _ _ H H0).
  remember (@proj_sumbool (@In positive (@fst positive A a) l)
         (~ @In positive (@fst positive A a) l)
         (@in_dec positive ident_eq (@fst positive A a) l)).
  destruct b; trivial. right; trivial.
Qed.

Lemma In_map_fst_filter2 {A i l}: forall {L: list (ident * A)},
      In i (map fst (filter (fun a : positive * A =>  in_dec ident_eq (fst a) l) L)) ->
      In i l /\ In i (map fst L).
Proof. induction L; simpl; intros; trivial. contradiction. unfold ident in *.
  remember (@proj_sumbool (@In positive (@fst positive A a) l)
         (~ @In positive (@fst positive A a) l)
         (@in_dec positive ident_eq (@fst positive A a) l)).
  destruct b.
  + apply Indec2 in Heqb. simpl in H.
    destruct H. subst. split; trivial. left; trivial.
    destruct (IHL H). split; trivial. right; trivial.
  + simpl in H. destruct (IHL H). split; trivial. right; trivial.
Qed.


Program Definition test (a b : nat) : { x : nat | x = a + b } :=
  ((a + b) : { x : nat | x = a + b }).
Proof.
intros.
reflexivity.
Qed.

Print test.

Require Import List.

Program hd_opt (l : list nat) : { x : nat | x <> 0 } :=
  match l with
    nil => 1
    | a :: l => a
  end.


From Undecidability.H10 Require Import H10 H10_undec Dio.dio_single H10p.
From Undecidability.Synthetic Require Import Undecidability.
Require Import Fin.
Local Set Implicit Arguments.

(* Reduction from Diophantine equations with parameters to Diophantine equations without parameters *)

Definition embed_poly n (p : dio_polynomial (Fin.t n) (Fin.t 0)) : dio_polynomial_pfree.
Proof.
  induction p.
  - exact (dp_nat_pfree n0).
  - exact (dp_var_pfree (proj1_sig (to_nat v))).
  - inversion p.
  - exact (dp_comp_pfree (if d then do_add_pfree else do_mul_pfree) IHp1 IHp2).
Defined.

Definition embed (x : H10_PROBLEM) : H10p_PROBLEM :=
  let (n, x) := x in let (p, q) := x in (embed_poly p, embed_poly q).

Definition embed_env n (phi : Fin.t n -> nat) : nat -> nat :=
  fun k => match Compare_dec.lt_dec k n with
        | left H => phi (of_nat_lt H)
        | _ => 0
        end.

Lemma embed_env_eval n (p : dio_polynomial (Fin.t n) (Fin.t 0)) nu phi :
  dp_eval phi nu p = dp_eval_pfree (embed_env phi) (embed_poly p).
Proof.
  induction p.
  - reflexivity.
  - cbn. unfold embed_env. destruct Compare_dec.lt_dec as [H|H].
    + erewrite of_nat_ext, of_nat_to_nat_inv. reflexivity.
    + exfalso. apply H. apply proj2_sig.
  - inversion p.
  - cbn [dp_eval]. rewrite IHp1, IHp2. now destruct d.
Qed.

Definition cut_env n (phi : nat -> nat) : Fin.t n -> nat :=
  fun i => phi (proj1_sig (to_nat i)).

Lemma cut_env_eval n (p : dio_polynomial (Fin.t n) (Fin.t 0)) nu phi :
  dp_eval (cut_env phi) nu p = dp_eval_pfree phi (embed_poly p).
Proof.
  induction p.
  - reflexivity.
  - reflexivity.
  - inversion p.
  - cbn [dp_eval]. rewrite IHp1, IHp2. now destruct d.
Qed.

Lemma embed_spec x :
  H10 x <-> H10p (embed x).
Proof.
  destruct x as (n & p & q). cbn. split; intros [phi H]; cbn in H.
  - exists (embed_env phi). cbn. now rewrite !embed_env_eval in H.
  - exists (cut_env phi). cbn. now rewrite !cut_env_eval.
Qed.

Theorem reduction :
  H10 ⪯ H10p.
Proof.
  exists embed. intros x. apply embed_spec.
Qed.