Require Import Setoid.
Require Import Coq.Lists.List.
Require Import Bool.
Require Import Coq.Program.Equality.
Import ListNotations.
Import PeanoNat.Nat.

Require Import Lib.Deduplicated.
Require Import Lib.Sorted.
Require Import Lib.EqDec.
Require Import Lib.LinearOrder.

Inductive BTree (A: Type) : Type :=
| leaf : BTree A
| node : A -> BTree A -> BTree A -> BTree A.

Arguments leaf {A}.
Arguments node {A} _ _ _.

Definition treeComp {A: Type} `{LinearOrder A} (x: A) (t: BTree A) : option comparison :=
match t with
| leaf => None
| node y _ _ =>  Some (comp x y)
end.

Fixpoint add_tree {A: Type} `{LinearOrder A} (x: A) (t : BTree A) : BTree A :=
match t with
| leaf => node x leaf leaf
| node v l r => match comp x v with
                | Lt => node v (add_tree x l) r
                | Eq => node v l r
                | Gt => node v l (add_tree x r)
                end
end.

Fixpoint to_tree {A: Type} `{LinearOrder A} (l : list A) : BTree A :=
  match l with
  | []      => leaf
  | (x::l') => add_tree x (to_tree l')
  end.

Fixpoint to_list {A: Type} (l : BTree A) : list A :=
  match l with
  | leaf       => []
  | node x l r => to_list l ++ [x] ++ to_list r
  end.

Fixpoint TCount {A: Type}(p: A -> bool)(t: BTree A) : nat :=
  match t with
  | leaf => 0
  | node x l r => if (p x) then S (TCount p l + TCount p r) else TCount p l + TCount p r
  end.

Fixpoint TAny {A: Type}(p: A -> bool)(t: BTree A) : bool :=
  match t with
  | leaf => false
  | node x l r => p x || TAny p l || TAny p r
  end.

Definition BTreeListPermutation {A: Type} (t: BTree A) (l: list A) : Prop :=
  forall p: A->bool, TCount p t = count p l.

Definition BTreePermutation {A: Type} (t1 t2: BTree A) : Prop :=
  forall p: A->bool, TCount p t1 = TCount p t2.

Definition BTreeElem_eq (A: Type) (l l' : BTree A) : Prop :=
  forall p : A -> bool, TAny p l = TAny p l'.

Definition BTreeListElem_eq {A: Type} (t: BTree A) (l: list A) : Prop :=
  forall p : A -> bool, TAny p t = any p l.

Definition dedupSort {A: Type} `{LinearOrder A} (l : list A) : list A :=
  to_list (to_tree l).

Lemma to_list_perm {A: Type} (t: BTree A) : BTreeListPermutation t (to_list t).
Proof.
  intros p. induction t; [auto|].
  cbn. rewrite count_list_concat. cbn. destruct (p a).
  - rewrite plus_n_Sm, IHt1, IHt2. reflexivity.
  - rewrite IHt1, IHt2. reflexivity.
Qed.

Lemma same_count_TCount {A: Type} (t: BTree A) : forall p: A-> bool,
  TCount p t = count p (to_list t).
Proof.
  apply to_list_perm.
Qed.

Fixpoint TIn {A: Type} (x: A) (t: BTree A) : Prop :=
match t with
| leaf => False
| node v l r => v = x \/ TIn x l \/ TIn x r
end.

Inductive NormalTree {A: Type} `{LinearOrder A} : BTree A -> Prop :=
| NormLeaf : NormalTree leaf
| NormNode : forall (x: A) (l r: BTree A), NormalTree l -> NormalTree r ->
  (forall y: A, TIn y l -> comp y x = Lt) -> (forall y: A, TIn y r -> comp y x = Gt) ->
  NormalTree (node x l r).

Definition TDeduplicated {A: Type} `{EqDec A} (t: BTree A) : Prop :=
  forall x : A, TIn x t -> TCount (eqf x) t = 1.

Lemma in_to_list {A: Type} (x: A) (t: BTree A) :
  In x (to_list t) <-> TIn x t.
Proof.
  split.
  - induction t; [auto | cbn].
    intro H. rewrite in_app_iff in H. cbn in *. destruct H as [H | [H | H]].
    + right. left. apply IHt1. assumption.
    + left. assumption.
    + right. right. apply IHt2. assumption.
  - induction t; [auto | cbn].
    intro H. rewrite in_app_iff. cbn. destruct H as [H | [H | H]].
    + right. left. assumption.
    + left. apply IHt1. assumption.
    + right. right. apply IHt2. assumption.
Qed.

Lemma add_dont_remove {A: Type} `{LinearOrder A} (t : BTree A) (v: A):
  TIn v t -> forall n: A, TIn v (add_tree n t).
Proof.
  intros I n. induction t; cbn in *; [destruct I|].
  destruct (comp n a) eqn:c.
  - apply I.
  - cbn. destruct I as [e|[l | r]]; subst; auto.
  - cbn. destruct I as [e|[l | r]]; subst; auto.
Qed.

Lemma TIn_add {A: Type} `{LinearOrder A} (n: A) (t : BTree A) (v: A) :
  TIn v (add_tree n t) <-> n = v \/ TIn v t.
Proof.
  split.
  - intros I. induction t.
    + left. cbn in *. destruct I as [I | [I | I]]; [auto | destruct I | destruct I].
    + cbn in *. destruct (comp n a) eqn:c.
      * rewrite comp_eq in c; subst. cbn in *. destruct I as [e|[l|r]]; subst; auto.
      * cbn in *. destruct I as [e|[l|r]]; subst; auto. destruct (IHt1 l); auto.
      * cbn in *. destruct I as [e|[l|r]]; subst; auto. destruct  (IHt2 r); auto.
  - intros [e | I].
    + subst. induction t; cbn; [auto |].
      destruct (comp v a) eqn:c; cbn; [| auto | auto]. left. symmetry.
      now apply comp_eq.
    + apply add_dont_remove. assumption.
Qed.

Theorem add_preserves_normal {A: Type} `{LinearOrder A} (n: A) (t : BTree A) :
  NormalTree t -> NormalTree (add_tree n t).
Proof.
  intro N. induction N.
  - cbn. constructor; [constructor| constructor| |]; intros y I; cbn in *; try inversion I.
  - cbn in *. destruct (comp n x) eqn:c.
    + constructor; assumption.
    + constructor; auto. intros y I. rewrite TIn_add in I. destruct I; subst; auto.
    + constructor; auto. intros y I. rewrite TIn_add in I. destruct I; subst; auto.
Qed.

Lemma TCount_for_not_satisfied_pred {A: Type} (t : BTree A) (p: A -> bool):
  (forall x:A, TIn x t -> p x = false) -> TCount p t = 0.
Proof.
  intros N. induction t; [auto|].
  cbn in *. rewrite (N a); auto. rewrite IHt1, IHt2; auto.
Qed.

(* Deduplicated *)
Theorem normal_is_deduplicated {A: Type} `{LinearOrder A} (t: BTree A) :
  NormalTree t -> TDeduplicated t.
Proof.
  intro N. induction N; intros y I; cbn in I; [destruct I|].
  destruct I as [e|[I|I]].
  - subst. cbn [TCount]. rewrite eqf_refl, TCount_for_not_satisfied_pred, TCount_for_not_satisfied_pred; auto.
    + intros x I. specialize (H1 x I). rewrite <-eqf_comp_not_eq, comp_inv_iff. cbn. rewrite H1. intros [=].
    + intros x I. specialize (H0 x I). rewrite <-eqf_comp_not_eq, comp_inv_iff. cbn. rewrite H0. intros [=].
  - destruct (comp y x) eqn:c.
    + specialize (H0 y I). rewrite H0 in c. inversion c.
    + cbn [TCount]. rewrite eqf_lt, IHN1, TCount_for_not_satisfied_pred; auto.
      intros z I'. rewrite <-eqf_comp_not_eq, comp_eq. specialize (H1 z I'). intros c'.
      subst. rewrite c in H1. discriminate.
    + cbn [TCount]. rewrite eqf_lt, IHN1, TCount_for_not_satisfied_pred; auto.
      intros z I'. rewrite <-eqf_comp_not_eq, comp_eq. specialize (H1 z I'). specialize (H0 y I).
      intros e. subst. rewrite H1 in H0. discriminate.
  - destruct (comp y x) eqn:c.
    + specialize (H1 y I). rewrite H1 in c. inversion c.
    + cbn [TCount]. rewrite eqf_lt, IHN2, TCount_for_not_satisfied_pred; auto.
      intros z I'. rewrite <-eqf_comp_not_eq, comp_eq. intro e; subst. specialize (H0 z I').
      specialize (H1 z I). rewrite H0 in H1. discriminate.
    + cbn [TCount]. rewrite eqf_gt, IHN2, TCount_for_not_satisfied_pred; auto.
      intros z I'. rewrite <-eqf_comp_not_eq, comp_eq. intro e; subst. specialize (H0 z I').
      rewrite c in H0. discriminate.
Qed.

Theorem to_tree_normal {A: Type} `{LinearOrder A} (l: list A) : NormalTree (to_tree l).
Proof.
  induction l; [constructor|]. cbn. apply add_preserves_normal. assumption.
Qed.

Theorem to_tree_dedup {A: Type} `{LinearOrder A} (l: list A) : TDeduplicated (to_tree l).
Proof.
  apply normal_is_deduplicated. apply to_tree_normal.
Qed.

Theorem dedup_dedupSort {A: Type} `{LinearOrder A} (l : list A) : Deduplicated (dedupSort l).
Proof.
  rewrite dup_def_eq. unfold dedupSort, CountDeduplicated. intros x I. rewrite <- same_count_TCount.
  rewrite in_to_list in I. apply to_tree_dedup. assumption.
Qed.

(* Sorted *)
Theorem normal_to_list_sorted {A: Type} `{LinearOrder A} (t: BTree A) : NormalTree t -> Sorted (to_list t).
Proof.
  intros N. induction N; cbn; [constructor|].
  apply concat_sorted; auto.
    + apply head_in_sorted; [auto|]. intros z I. apply comp_gt. apply H1. apply in_to_list. auto.
    + intros z I. apply comp_lt. apply H0. apply in_to_list. auto.
Qed.

Theorem sorted_dedupSort {A: Type} `{LinearOrder A} (l : list A) : Sorted (dedupSort l).
Proof.
  apply normal_to_list_sorted. apply to_tree_normal.
Qed.

(* Preserves elems *)
Lemma to_list_any {A: Type} (t: BTree A) : BTreeListElem_eq t (to_list t).
Proof.
  intros p. induction t; [auto|].
  cbn. rewrite any_concat. cbn. destruct (p a); cbn; auto.
  - rewrite orb_comm. auto.
  - rewrite IHt1, IHt2. reflexivity.
Qed.

Lemma add_tree_any {A: Type} `{LinearOrder A} (x: A) (t: BTree A) (p: A -> bool):
  TAny p (add_tree x t) = (if p x then true else TAny p t).
Proof.
  induction t; cbn; [destruct (p x); auto|].
  destruct (comp x a) eqn:e; cbn.
  - rewrite comp_eq in e. subst. destruct (p a) eqn:p_a; auto.
  - rewrite IHt1. destruct (p a); destruct (p x); auto.
  - rewrite IHt2. destruct (p a); destruct (p x); auto. rewrite orb_false_l, orb_comm. auto.
Qed.

Lemma to_tree_any {A: Type} `{LinearOrder A} (l: list A) : BTreeListElem_eq (to_tree l) l.
Proof.
  intros p. induction l; cbn; [auto|].
  rewrite add_tree_any, IHl. auto.
Qed.

Theorem same_elements_dedupSort {A: Type} `{LinearOrder A} (l : list A) :
  Elem_eq l (dedupSort l).
Proof.
  unfold dedupSort. intros p. rewrite <-to_list_any. symmetry. apply to_tree_any.
Qed.


(* (Deeply Embedded) Church Encoded Datatypes in Coq. *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From PLF Require Import Maps.
From PLF Require Import Smallstep.

  (* Somewhat counterintuitively, we're going to first add numbers to
     our definition of the lambda calculus, then show how we didn't
     really 'need' them in the first place (but they're certainly nice
     to have)! *)

  (* Since numbers make for realistic programs, let's add them to our
     lambda calculus!*)
  Inductive tm : Type :=
  | tm_var   : string -> tm
  | tm_app   : tm -> tm -> tm
  | tm_abs   : string -> tm -> tm
  | tm_zero  : tm
  | tm_succ  : tm -> tm
  | tm_iter  : tm -> tm -> tm -> tm.

  (* We define three things: zero and successor constructors for
     number, and an interator for recursing over / destructing numbers
     *)

Declare Custom Entry stlc.
Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "'iter' x 'zero=>' y 'succ=>' z" :=
  (tm_iter x y z) (in custom stlc at level 89,
                    x custom stlc at level 99,
                    y custom stlc at level 99,
                    z custom stlc at level 99,
                    left associativity).

Notation "'S' x" := (tm_succ x) (in custom stlc at level 1, left associativity).

Notation "\ x , y" :=
  (tm_abs x y) (in custom stlc at level 90, x at level 99,
                     y custom stlc at level 99,
                     left associativity).

Coercion tm_var : string >-> tm.
Open Scope string_scope.

(** Some more notation magic to set up the concrete syntax, as we did
    in the [Imp] chapter... *)

Definition x : string := "x".
Definition y : string := "y".
Definition z : string := "z".
Definition w : string := "w".
Definition t : string := "t".
Definition f : string := "f".
Definition s : string := "s".

Hint Unfold x : core.
Hint Unfold y : core.
Hint Unfold z : core.
Hint Unfold w : core.
Hint Unfold s : core.

(** Some examples... *)

Definition two : tm := <{S (S tm_zero) }>.

Print Nat.add.
Definition plus_tm : tm :=
  <{\x, \y, iter x zero=> y succ=> (\w, S w) }>.

Definition mult_tm : tm :=
  <{\x, \y, iter x zero=> tm_zero succ=> (\z, plus_tm y z) }>.

(* ################################################################# *)
(** * Operational Semantics *)

(* ================================================================= *)
(** ** Values *)

(** Numbers are now values: *)
(* Following our previous convention for lambda abstractions, we don't
   require the subterm of a successor to be a value.  *)
Inductive value : tm -> Prop :=
  | v_abs : forall x t1,
      value <{\x, t1}>
  | v_zero : value tm_zero
  | v_succ : forall t1, value <{S t1}>.

Hint Constructors value : core.

(* ================================================================= *)
(** ** LC+Nat Programs *)

(* ================================================================= *)
(** ** Substitution *)

(** Can you fill in the rest of the substitution function?

       [x:=s]x               = s
       [x:=s]y               = y                     if x <> y
       [x:=s](\x, t)         = \x:T, t
       [x:=s](\y, t)         = \y:T, [x:=s]t         if x <> y
       [x:=s](t1 t2)         = ([x:=s]t1) ([x:=s]t2)

*)

(** ... and formally: *)

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | tm_var y =>
      if x =? y then s else t
  | <{\y, t1}> =>
      if x =? y then t else <{\y, [x:=s] t1}>
  | <{S t1}> => <{S ([x:=s] t1)}>
  | <{t1 t2}> =>
    <{([x:=s] t1) ([x:=s] t2)}>

  | tm_zero => tm_zero     (* NEW *)
  | <{iter z zero=> cz succ=> cs}> => (* NEW *)
    <{iter ([x:=s] z) zero=> ([x:=s] cz) succ=> ([x := s] cs)}>
  end

where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc).

(** For example... *)

(* ================================================================= *)
(** ** Reduction *)

(**
                               value v2
                     ---------------------------                     (ST_AppAbs)
                     (\x,t1) v2 --> [x:=v2]t1

                              t1 --> t1'
                           ----------------                           (ST_App1)
                           t1 t2 --> t1' t2

                              value v1
                              t2 --> t2'
                           ----------------                           (ST_App2)
                           v1 t2 --> v1 t2'

                           t1 --> t1'
               --------------------------
               iter t1 zero=> cz succ=> cs --> iter t1' zero=> cz succ=> cs

               --------------------------
          iter tm_zero zero=> cz succ=> cs --> cz

              ----------------------------
          iter (tm_succ t1) z zero=> cz succ=> cs -->
          cs (iter t1 z zero=> cz succ=> cs)
*)

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x t1 v2, (* <- beta reduction *)
         value v2 ->
         <{(\x, t1) v2}> --> <{ [x:=v2]t1 }>
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         <{t1 t2}> --> <{t1' t2}>
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         <{v1 t2}> --> <{v1  t2'}>

  (* NEW RULES: *)
  | ST_Zero : forall cz cs,
      <{iter tm_zero zero=> cz succ=> cs}> --> cz

  | ST_Succ : forall t1 cz cs,
      <{iter (S t1) zero=> cz succ=> cs}> --> <{cs (iter t1 zero=> cz succ=> cs) }>

  | ST_Iter : forall t1 t1' cz cs,
      t1 --> t1' ->
      <{iter t1 zero=> cz succ=> cs}> -->
      <{iter t1' zero=> cz succ=> cs}>

where "t '-->' t'" := (step t t').

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

(* We can once again reason about the execution of terms using
   theorems. *)
Example plus_two_ex :
  <{plus_tm two two}> -->* <{S (S (S (S tm_zero))) }>.
Proof.
  eapply multi_step.
  { unfold plus_tm, two.
    apply ST_App1.
    apply ST_AppAbs.
    apply v_succ. }
  simpl; eapply multi_step.
  { simpl.
    apply ST_AppAbs.
    apply v_succ. }
  simpl; eapply multi_step.
  { eapply ST_Succ. }
  simpl; eapply multi_step.
  { apply ST_App2.
    constructor.
    eapply ST_Succ. }
  simpl; eapply multi_step.
  { apply ST_App2.
    constructor.
    apply ST_App2.
    constructor.
    eapply ST_Zero. }
  simpl. eapply multi_step.
  { eapply ST_App2. constructor.
    apply ST_AppAbs.
    apply v_succ. }
  simpl. eapply multi_step.
  { apply ST_AppAbs.
    constructor. }
  simpl. apply multi_refl.
Qed.

(* That was exhausting, and rather mechanical. Can we do better?  Yes,
   proof automation to the rescue!  note that at each step, only one
   evaluation rule applies. To know if a rule applies, we just need to
   look at the shape of the goal, and (some of the time), tell if a
   subterm is a value.  *)
Ltac next_step :=
  first [apply ST_AppAbs; solve [repeat constructor]
        | apply ST_App2; solve [repeat constructor]
        | apply ST_Zero
        | apply ST_Succ
        | apply ST_App1; next_step
        | apply ST_Iter; next_step ].

Ltac normalize_lambda :=
  repeat (eapply multi_step;
          [ simpl; next_step | simpl ]).

Example plus_two_ex' :
  <{plus_tm two two}> -->* <{S (S (S (S tm_zero))) }>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* With this tactic, evaluating terms becomes a lot easier :) *)
Example mult_two_ex :
  <{mult_tm two (S tm_zero)}> -->* <{S (S tm_zero) }>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* (λx.x x) (λx.x x)*)
Definition omega :=
  <{(\x, x x) (\x, x x) }>.

(* (λx.x x x) (λx.x x x)*)
Definition omega_grow :=
  <{(\x, x x x) (\x, x x x) }>.

(* Note that [normalize_lambda] stops when a normal form is reached.
   For diverging terms, this never happens: *)
Lemma looping_example2 :
    omega -->* omega.
  normalize_lambda.
  do 5 (eapply multi_step;
          [ next_step | ]). simpl.
  apply multi_refl.
Qed.

Lemma looping_example3 :
  omega_grow -->* <{(\x, x x x) (\x, x x x) (\x, x x x) (\x, x x x) }>.
Proof.
  do 15 (eapply multi_step;
         [ next_step | ]). simpl.
  Undo 3.
  do 2 (eapply multi_step;
        [ next_step | ]). simpl.
  constructor.
Qed.


(* TLC in Coq
 *
 * Module: tlc.utility.function
 * Purpose: Contains helpers for functional programming.
 *)

Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrnat.

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

(* Iterate f over x n times *)
Fixpoint iter A (f : A -> A) (x : A) n :=
  match n with
  | 0 => x
  | n.+1 => iter f (f x) n
  end.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.arrival_sequence rt.model.priority.
Require Import rt.model.schedule.uni.schedule.
Require Import rt.model.schedule.uni.basic.platform.
Require Import rt.model.schedule.uni.transformation.construction.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype bigop seq path.

Module ConcreteScheduler.

  Import Job ArrivalSequence UniprocessorSchedule Platform Priority ScheduleConstruction.

  (* In this section, we implement a priority-based uniprocessor scheduler *)
  Section Implementation.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.

    (* Let arr_seq be any job arrival sequence with consistent arrivals.*)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.

    (* Assume a JLDP policy is given. *)
    Variable higher_eq_priority: JLDP_policy Job.

    (* Next, we show how to recursively construct the schedule. *)
    Section ScheduleConstruction.

      (* For any time t, suppose that we have generated the schedule prefix in the
         interval [0, t). Then, we must define what should be scheduled at time t. *)
      Variable sched_prefix: schedule Job.
      Variable t: time.

      (* For simplicity, let's use some local names. *)
      Let is_pending := pending job_arrival job_cost sched_prefix.

      (* Consider the list of pending jobs at time t. *)
      Definition pending_jobs :=
        [seq j <- jobs_arrived_up_to arr_seq t | is_pending j t].

      (* To make the scheduling decision, we just pick one of the highest-priority jobs
         that are pending (if it exists). *)
      Definition highest_priority_job :=
        seq_min (higher_eq_priority t) pending_jobs.

    End ScheduleConstruction.

    (* Starting from the empty schedule, the final schedule is obtained by iteratively
       picking the highest-priority job. *)
    Let empty_schedule : schedule Job := fun t => None.
    Definition scheduler :=
      build_schedule_from_prefixes highest_priority_job empty_schedule.

    (* Then, by showing that the construction function depends only on the prefix, ... *)
    Lemma scheduler_depends_only_on_prefix:
      forall sched1 sched2 t,
        (forall t0, t0 < t -> sched1 t0 = sched2 t0) ->
        highest_priority_job sched1 t = highest_priority_job sched2 t.
    Proof.
      intros sched1 sched2 t ALL.
      rewrite /highest_priority_job.
      suff SAME: pending_jobs sched1 t = pending_jobs sched2 t by rewrite SAME.
      apply eq_in_filter.
      intros j ARR.
      apply in_arrivals_implies_arrived_before with (job_arrival0 := job_arrival) in ARR;
        last by done.
      rewrite /arrived_before ltnS in ARR.
      rewrite /pending /has_arrived ARR 2!andTb; f_equal.
      rewrite /completed_by; f_equal.
      apply eq_big_nat; move => i /= LTi.
      by rewrite /service_at /scheduled_at ALL.
    Qed.

    (* ...we infer that the generated schedule is indeed based on the construction function. *)
    Corollary scheduler_uses_construction_function:
      forall t, scheduler t = highest_priority_job scheduler t.
    Proof.
      by ins; apply prefix_dependent_schedule_construction,
                    scheduler_depends_only_on_prefix.
    Qed.

  End Implementation.

  (* In this section, we prove the properties of the scheduler that are used
     as hypotheses in the analyses. *)
  Section Proofs.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.

    (* Let arr_seq be any job arrival sequence with consistent, non-duplicate arrivals. *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_arrival_sequence_is_a_set: arrival_sequence_is_a_set arr_seq.

    (* Consider any JLDP policy that is transitive and total. *)
    Variable higher_eq_priority: JLDP_policy Job.
    Hypothesis H_priority_is_transitive: forall t, transitive (higher_eq_priority t).
    Hypothesis H_priority_is_total: forall t, total (higher_eq_priority t).

    (* Let sched denote our concrete scheduler implementation. *)
    Let sched := scheduler job_arrival job_cost arr_seq higher_eq_priority.

    (* To conclude, we prove the important properties of the scheduler implementation. *)

    (* First, we show that scheduled jobs come from the arrival sequence. *)
      Lemma scheduler_jobs_come_from_arrival_sequence:
        jobs_come_from_arrival_sequence sched arr_seq.
      Proof.
        move => j t /eqP SCHED.
        rewrite /sched scheduler_uses_construction_function // /highest_priority_job in SCHED.
        apply seq_min_in_seq in SCHED.
        rewrite mem_filter in SCHED.
        move: SCHED => /andP [_ ARR].
        by eapply in_arrivals_implies_arrived, ARR.
      Qed.

    (* Next, we show that jobs do not execute before they arrive...*)
    Theorem scheduler_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute job_arrival sched.
    Proof.
      move => j t /eqP SCHED.
      rewrite /sched scheduler_uses_construction_function // /highest_priority_job in SCHED.
      apply seq_min_in_seq in SCHED.
      rewrite mem_filter in SCHED.
      by move: SCHED => /andP [/andP [ARR _] _].
    Qed.

    (* ... nor after completion. *)
    Theorem scheduler_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.
    Proof.
      intros j t.
      induction t;
        first by rewrite /service /service_during big_geq //.
      rewrite /service /service_during big_nat_recr //=.
      rewrite leq_eqVlt in IHt; move: IHt => /orP [/eqP EQ | LT]; last first.
      {
        apply: leq_trans LT; rewrite -addn1.
          by apply leq_add; last by apply leq_b1.
      }
      rewrite -[job_cost _]addn0; apply leq_add; first by rewrite -EQ.
      rewrite leqn0 eqb0 /scheduled_at.
      rewrite /sched scheduler_uses_construction_function //.
      rewrite /highest_priority_job.
      apply/eqP; intro HP.
      apply seq_min_in_seq in HP.
      by rewrite mem_filter /pending /completed_by -EQ eq_refl andbF andFb in HP.
    Qed.

    (* In addition, the scheduler is work conserving, ... *)
    Theorem scheduler_work_conserving:
      work_conserving job_arrival job_cost arr_seq sched.
    Proof.
      intros j t IN BACK.
      move: BACK => /andP [/andP [ARR NOTCOMP] NOTSCHED].
      rewrite /scheduled_at /sched scheduler_uses_construction_function // in NOTSCHED.
      rewrite /scheduled_at /sched scheduler_uses_construction_function //.
      case HP: (highest_priority_job _ _ _ _ ) => [j_hp|]; first by exists j_hp.
      set hp := highest_priority_job _ _ _ _ _ _ in NOTSCHED HP.
      suff BUG: hp != None by rewrite HP in BUG.
      apply seq_min_exists with (x := j).
      rewrite mem_filter /pending ARR NOTCOMP /=.
      by eapply arrived_between_implies_in_arrivals, ARR.
    Qed.

    (* ...and respects the JLDP policy. *)
    Theorem scheduler_respects_policy :
      respects_JLDP_policy job_arrival job_cost arr_seq sched higher_eq_priority.
    Proof.
      rename H_priority_is_transitive into TRANS, H_priority_is_total into TOTAL.
      move => j1 j2 t ARR1 BACK /eqP SCHED.
      move: BACK => /andP [/andP [ARR NOTCOMP] NOTSCHED].
      rewrite /scheduled_at /sched scheduler_uses_construction_function // in NOTSCHED.
      rewrite /scheduled_at /sched scheduler_uses_construction_function // in SCHED.
      rewrite /highest_priority_job in SCHED NOTSCHED.
      set jobs := pending_jobs _ _ _ _ _ in SCHED NOTSCHED.
      have IN: j1 \in jobs.
      {
        rewrite mem_filter /pending ARR NOTCOMP /=.
        by eapply arrived_between_implies_in_arrivals, ARR.
      }
      apply seq_min_computes_min with (y := j1) in SCHED; try (by done).
      by intros x y; rewrite 2!mem_filter; move => /andP [_ INx] /andP [_ INy];
         apply TOTAL; eapply in_arrivals_implies_arrived; eauto 2.
    Qed.

  End Proofs.

End ConcreteScheduler.


Set Implicit Arguments.

Require Import Coq.omega.Omega.
Require Import Coq.Structures.OrderedType.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.FSets.FSetAVL.
Require Import Coq.Arith.Peano_dec.

Require Import Aniceto.Map.

(* requires *)

Require Coq.FSets.FMapFacts.
Require Coq.Arith.Compare_dec.

Require Bijection.

Inductive node := make : nat -> node.

Definition node_id r := match r with | make n => n end.

Definition node_first := make 0.

Definition node_next m := make (S (node_id m)).

Module NODE <: UsualOrderedType.
  Definition t := node.
  Definition eq := @eq node.
  Definition lt x y := lt (node_id x) (node_id y).
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.
  Lemma lt_trans: forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    intros.
    unfold lt in *.
    destruct x, y, z.
    simpl in *.
    omega.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    unfold lt in *.
    intros.
    destruct x, y.
    simpl in *.
    unfold not; intros.
    inversion H0.
    subst.
    apply Lt.lt_irrefl in H.
    inversion H.
  Qed.

  Import Coq.Arith.Compare_dec.
  Lemma compare:
    forall x y, Compare lt eq x y.
  Proof.
    intros.
    destruct x, y.
    destruct (Nat_as_OT.compare n n0);
    eauto using LT, GT.
    apply EQ.
    unfold Nat_as_OT.eq in *.
    subst.
    intuition.
  Defined.

  Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    intros.
    unfold eq.
    destruct x, y.
    destruct (eq_nat_dec n n0).
    - subst; eauto.
    - right.
      unfold not.
      intros.
      contradiction n1.
      inversion H; auto.
  Defined.
End NODE.

Module MN := FMapAVL.Make NODE.
Module MN_Facts := FMapFacts.Facts MN.
Module MN_Props := FMapFacts.Properties MN.
Module MN_Extra := MapUtil MN.
Module SN := FSetAVL.Make NODE.
Definition set_node := SN.t.

Lemma node_eq_rw:
  forall (k k':node), NODE.eq k k' <-> k = k'.
Proof.
  intros.
  auto with *.
Qed.

Lemma node_eq_dec:
  forall x y : node, {x = y} + {x <> y}.
Proof.
  auto using node_eq_rw, NODE.eq_dec.
Defined.

Section NotIn.
  Variable elt:Type.

  Lemma node_lt_irrefl:
    forall x : node, ~ NODE.lt x x.
  Proof.
    unfold not; intros.
    apply NODE.lt_not_eq in H.
    contradiction H.
    apply NODE.eq_refl.
  Qed.

  Let lt_next:
    forall x, NODE.lt x (node_next x).
  Proof.
    intros.
    destruct x.
    unfold node_next, node_id, NODE.lt.
    simpl.
    auto.
  Qed.

  Let node_impl_eq:
    forall k k' : node, k = k' -> k = k'.
  Proof.
    auto.
  Qed.

  Definition supremum {elt:Type} := @MN_Extra.supremum elt node_first node_next NODE.lt NODE.compare.

  Theorem find_not_in:
    forall (m: MN.t elt),
    ~ MN.In (supremum m) m.
  Proof.
    intros.
    eauto using MN_Extra.find_not_in, NODE.lt_trans, node_lt_irrefl.
  Qed.

End NotIn.

Section Props.

  Variable A:Type.

  Definition MapsTo (x:A) (n:node) (vs:list A) := Bijection.MapsTo x (node_id n) vs.

  Definition fresh (vs:list A) := make (length vs).

  Definition Node x (vs:list A) := Bijection.Index (node_id x) vs.

  Definition TaskOf (n:node) (x:A) (vs:list A) := Bijection.IndexOf x (node_id n) vs.

  Lemma maps_to_fun_1:
    forall x y n (vs:list A),
    MapsTo x n vs ->
    MapsTo y n vs ->
    y = x.
  Proof.
    unfold MapsTo; eauto using Bijection.maps_to_fun_1.
  Qed.

  Lemma maps_to_fun_2:
    forall vs (x:A) n n',
    MapsTo x n vs ->
    MapsTo x n' vs ->
    n' = n.
  Proof.
    intros.
    unfold MapsTo in *.
    destruct n as (n), n' as (n').
    simpl in *.
    eauto using Bijection.maps_to_fun_2.
  Qed.

  Lemma task_of_fun_2:
    forall vs (x y:A) n,
    TaskOf n x vs ->
    TaskOf n y vs ->
    x = y.
  Proof.
    unfold TaskOf; intros.
    eauto using Bijection.index_of_fun_2.
  Qed.

  Lemma maps_to_inv_eq:
    forall (x:A) n vs,
    MapsTo x n (x :: vs) ->
    n = fresh vs.
  Proof.
    intros.
    unfold MapsTo, fresh in *.
    destruct n as (n).
    simpl in *.
    eauto using Bijection.maps_to_inv_eq.
  Qed.

  Lemma task_of_inv_key:
    forall (x:A) y vs,
    TaskOf (fresh vs) x (y :: vs) ->
    x = y.
  Proof.
    intros.
    unfold TaskOf, fresh in *; simpl in *.
    eauto using Bijection.index_of_inv_key.
  Qed.

  Lemma maps_to_neq:
    forall (x:A) y vs n,
    x <> y ->
    MapsTo y n (x :: vs) ->
    MapsTo y n vs.
  Proof.
    intros.
    destruct n as (n).
    unfold MapsTo in *; simpl in *.
    eauto using Bijection.maps_to_neq.
  Qed.

  Lemma node_eq:
    forall x vs,
    Node (fresh vs) (x::vs).
  Proof.
    intros.
    unfold Node, fresh in *.
    eauto using Bijection.index_eq.
  Qed.

  Lemma maps_to_eq:
    forall x vs,
    MapsTo x (fresh vs) (x::vs).
  Proof.
    intros.
    unfold MapsTo, fresh.
    simpl.
    auto using Bijection.maps_to_eq.
  Qed.

  Lemma maps_to_cons:
    forall x vs y n,
    x <> y ->
    MapsTo x n vs ->
    MapsTo x n (y :: vs).
  Proof.
    unfold MapsTo, fresh.
    auto using Bijection.maps_to_cons.
  Qed.

  Lemma maps_to_lt:
    forall (x:A) n vs,
    MapsTo x n vs ->
    NODE.lt n (fresh vs).
  Proof.
    intros.
    unfold NODE.lt, fresh, MapsTo in *.
    destruct n; simpl in *.
    eauto using Bijection.maps_to_lt.
  Qed.

  Lemma node_lt:
    forall n vs,
    Node n vs ->
    NODE.lt n (fresh vs).
  Proof.
    intros.
    destruct n.
    unfold Node, fresh, NODE.lt in *.
    eauto using Bijection.index_lt.
  Qed.

  Lemma lt_to_node:
    forall n vs,
    NODE.lt n (fresh vs) ->
    Node n vs.
  Proof.
    unfold NODE.lt, Node, fresh.
    auto using Bijection.lt_to_index.
  Qed.

  Lemma node_cons:
    forall n vs x,
    Node n vs ->
    Node n (x::vs).
  Proof.
    unfold NODE.lt, Node, fresh.
    auto using Bijection.index_cons.
  Qed.

  Lemma maps_to_absurd_fresh:
    forall (x:A) vs,
    ~ MapsTo x (fresh vs) vs.
  Proof.
    unfold fresh, MapsTo.
    eauto using Bijection.maps_to_absurd_length.
  Qed.

  Lemma task_of_absurd_fresh:
    forall (x:A) vs,
    ~ TaskOf (fresh vs) x vs.
  Proof.
    unfold fresh, TaskOf.
    eauto using Bijection.index_of_absurd_length.
  Qed.

  Lemma node_absurd_fresh:
    forall vs,
    ~ Node (fresh vs) vs.
  Proof.
    intros.
    unfold Node.
    simpl.
    apply Bijection.index_absurd_length.
  Qed.

  Lemma maps_to_to_node:
    forall (x:A) n vs,
    MapsTo x n vs ->
    Node n vs.
  Proof.
    unfold MapsTo, Node.
    intros.
    eauto using Bijection.maps_to_to_index.
  Qed.

  Lemma maps_to_to_task_of:
    forall (x:A) n vs,
    MapsTo x n vs ->
    TaskOf n x vs.
  Proof.
    unfold MapsTo, TaskOf.
    eauto using Bijection.maps_to_to_index_of.
  Qed.

End Props.

Section MoreProps.

  Lemma maps_to_length_rw:
    forall {A:Type} {B:Type} (vs:list A) (vs':list B),
    length vs = length vs' ->
    fresh vs = fresh vs'.
  Proof.
    intros.
    unfold fresh.
    auto.
  Qed.

  Let length_node_id_rw:
    forall {A} (vs:list A) n,
    length vs = node_id n ->
    fresh vs = n.
  Proof.
    unfold fresh.
    intros.
    destruct n; auto.
  Qed.

  Lemma maps_to_to_in:
    forall {A} x n (vs:list A),
    MapsTo x n vs ->
    List.In x vs.
  Proof.
    unfold MapsTo; eauto using Bijection.maps_to_to_in.
  Qed.

  Lemma maps_to_inv:
    forall {A} x (y:A) n vs,
    MapsTo x n (y :: vs) ->
    (x = y /\ n = fresh vs) \/ (x <> y /\ MapsTo x n vs).
  Proof.
    intros.
    inversion H; subst.
    - apply length_node_id_rw in H1.
      subst.
      intuition.
    - intuition.
  Qed.

  Lemma task_of_inv:
    forall {A} x (y:A) n vs,
    TaskOf n x (y :: vs) ->
    (x = y /\ n = fresh vs) \/ TaskOf n x vs.
  Proof.
    intros.
    inversion H; subst.
    - apply length_node_id_rw in H1.
      subst.
      intuition.
    - intuition.
  Qed.

  Lemma node_to_task_of:
    forall {A} n (vs:list A),
    Node n vs ->
    exists x, TaskOf n x vs.
  Proof.
    intros.
    destruct H as (x, H).
    eauto.
  Qed.

  Lemma task_of_to_node:
    forall {A} x n (vs:list A),
    TaskOf n x vs ->
    Node n vs.
  Proof.
    intros.
    unfold Node, TaskOf in *.
    eauto using Bijection.index_def.
  Qed.

  Lemma task_of_to_in:
    forall {A} x n (vs:list A),
    TaskOf n x vs ->
    List.In x vs.
  Proof.
    unfold TaskOf; eauto using Bijection.index_of_to_in.
  Qed.

  Lemma task_of_cons:
    forall {A} x y n (vs:list A),
    TaskOf n x vs ->
    TaskOf n x (y::vs).
  Proof.
    unfold TaskOf; eauto using Bijection.index_of_cons.
  Qed.

  Lemma node_inv:
    forall {A} (x:A) n vs,
    Node n (x :: vs) ->
    n = fresh vs \/ Node n vs.
  Proof.
    intros.
    apply node_to_task_of in H.
    destruct H as (y, H).
    apply task_of_inv in H.
    destruct H as [(?,?)|?].
    - subst.
      intuition.
    - eauto using task_of_to_node.
  Qed.

  Lemma task_of_inv_eq:
    forall {A} x (y:A) vs,
    TaskOf (fresh vs) x (y :: vs) ->
    x = y.
  Proof.
    unfold TaskOf, fresh; eauto using Bijection.index_of_inv_key.
  Qed.

  Lemma task_of_eq:
    forall {A} (x:A) vs,
    TaskOf (fresh vs) x (x :: vs).
  Proof.
    unfold TaskOf, fresh; eauto using Bijection.index_of_eq.
  Qed.

  Section Lookup.
    Variable A:Type.
    Variable eq_dec: forall (x y:A), {x = y} + {x <> y}.

    Lemma in_to_maps_to:
      forall (x:A) vs,
      List.In x vs ->
      exists n, MapsTo x n vs.
    Proof.
      intros.
      unfold MapsTo.
      apply Bijection.in_to_maps_to in H; auto.
      destruct H as (n, H).
      exists (make n).
      auto.
    Qed.

    Definition lookup (x:A) xs :=
    match Bijection.lookup eq_dec x xs with
    | Some n => Some (make n)
    | _ => None
    end.

    Lemma lookup_some:
      forall xs x n,
      lookup x xs = Some n ->
      MapsTo x n xs.
    Proof.
      unfold lookup.
      intros.
      remember (Bijection.lookup _ _ _).
      symmetry in Heqo.
      destruct o; inversion H; subst; clear H.
      apply Bijection.lookup_some in Heqo.
      auto.
    Qed.

    Lemma lookup_none:
      forall xs x,
      lookup x xs = None ->
      ~ List.In x xs.
    Proof.
      unfold lookup; intros.
      remember (Bijection.lookup _ _ _).
      symmetry in Heqo.
      destruct o; inversion H; subst; clear H.
      apply Bijection.lookup_none in Heqo.
      assumption.
    Qed.
  End Lookup.

  Section TaskOf.
    Variable A:Type.
    Definition task_of n (l:list A) := Bijection.index_of (node_id n) l.

    Lemma task_of_some:
      forall n l x,
      task_of n l = Some x ->
      TaskOf (A:=A) n x l.
    Proof.
      unfold task_of; intros.
      apply Bijection.index_of_some in H.
      auto.
    Qed.

    Lemma task_of_prop:
      forall l n x,
      TaskOf (A:=A) n x l ->
      task_of n l = Some x.
    Proof.
      unfold task_of; intros.
      apply Bijection.index_of_prop.
      auto.
    Qed.
  End TaskOf.
End MoreProps.

  Ltac simpl_node :=
  repeat match goal with
  | [ H1: MapsTo ?x ?n ?v, H2: MapsTo ?y ?n ?v |- _ ] =>
      let H' := fresh "H" in
      assert (H': y = x) by eauto using maps_to_fun_1;
      rewrite H' in *;
      clear H' H2
  | [ H1: MapsTo ?x ?n1 ?v, H2: MapsTo ?x ?n2 ?v |- _ ] =>
      let H' := fresh "H" in
      assert (H': n1 = n2) by eauto using maps_to_fun_2;
      rewrite H' in *;
      clear H' H2
  | [ H: MapsTo _ (fresh ?vs) ?vs |- _ ] =>
      apply maps_to_absurd_fresh in H;
      contradiction
  | [ H: Node (fresh ?vs) ?vs |- _ ] =>
      apply node_absurd_fresh in H;
      contradiction
  | [ H: MapsTo ?x (fresh ?vs) (?x :: ?vs) |- _ ] => clear H
  | [ H1: MapsTo ?x _ (?y :: _), H2: ?x <> ?y |- _ ] => apply maps_to_neq in H1; auto
  | [ H1: MapsTo ?x _ (?y :: _), H2: ?y <> ?x |- _ ] => apply maps_to_neq in H1; auto
  | [ H: MapsTo ?x _ (?x :: _) |- _ ] => apply maps_to_inv_eq in H; rewrite H in *; clear H
  | [ H: TaskOf (fresh ?vs) _ ?vs |- _ ] =>
      apply task_of_absurd_fresh in H;
      contradiction
  | [ H: TaskOf (fresh ?vs) ?x (?y :: ?vs) |- _ ] => apply task_of_inv_eq in H; subst
  | [ H1: TaskOf ?n ?x ?v, H2: TaskOf ?n ?y ?v |- _ ] =>
      let H' := fresh "H" in
      assert (H': y = x) by eauto using task_of_fun_2;
      rewrite H' in *;
      clear H' H2
  end.


Require Import Logic.Axiom.LEM.

Require Import Logic.Fol.Syntax.

Require Import Logic.Set.Set.
Require Import Logic.Set.Incl.
Require Import Logic.Set.Elem.
Require Import Logic.Set.Equal.

Require Import Logic.Lang1.Syntax.
Require Import Logic.Lang1.Context.
Require Import Logic.Lang1.SemanCtx.
Require Import Logic.Lang1.Semantics.
Require Import Logic.Lang1.Environment.

Open Scope Set_Incl_scope.

(* Theorem 'extensionality' expressed in set theory abstract syntax.            *)
(* This formulation is correct provided the variables names n m p are distinct. *)
Definition extensionalityF (n m p:nat) : Formula :=
    All n (All m (Iff (Equ n m) (All p (Iff (Elem p n) (Elem p m))))).

(* Theorem 'doubleIncl' expressed in set theory abstract syntax.                *)
(* This formulation is correct provided the variables names n m are distinct.   *)
Definition doubleInclF (n m:nat) : Formula :=
    All n (All m (Iff (Equ n m) (And (Sub n m) (Sub m n)))).

Import Semantics.
(* Evaluating extensionalityF in any environment 'yields' the theorem.          *)
Lemma evalExtensionalityF : LEM -> forall (e:Env) (n m p:nat),
    m <> n ->
    p <> m ->
    p <> n ->
    eval e (extensionalityF n m p)
        <->
    forall (x y:set), x == y <-> forall (z:set), z :: x <-> z :: y.
Proof.
    intros L e n m p Hmn Hpm Hpn. unfold extensionalityF. rewrite evalAll.
    split; intros H x.
    - intros y.
      remember (H x)  as H' eqn:E. clear E. clear H. rewrite evalAll in H'.
      remember (H' y) as H  eqn:E. clear E. clear H'.
      rewrite evalIff in H. rewrite evalEqu in H. rewrite evalAll in H.
      remember (bind e n x) as e1 eqn:E1. rewrite bindDiff in H.
      rewrite bindSame in H. rewrite E1 in H. rewrite bindSame in H.
      destruct H as [H1 H2]. split; intros H.
        + intros z. remember (H1 H z) as H' eqn:E. clear E. clear H.
          rewrite <- E1 in H'. remember (bind e1 m y) as e2 eqn:E2.
          rewrite evalIff in H'. rewrite evalElem in H'. rewrite evalElem in H'.
          rewrite bindSame in H'. rewrite bindDiff in H'. rewrite bindDiff in H'.
          rewrite E2 in H'. rewrite bindSame in H'. rewrite bindDiff in H'.
          rewrite E1 in H'. rewrite bindSame in H'.
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
        + apply H2. intros z. rewrite <- E1. remember (bind e1 m y) as e2 eqn:E2.
          rewrite evalIff, evalElem, evalElem, bindSame, bindDiff, bindDiff, E2.
          rewrite bindSame, bindDiff, E1, bindSame.
            { apply H. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
        + assumption.
        + assumption.
        + assumption.
    - rewrite evalAll. intros y.
      remember (bind e n x) as e1 eqn:E1. remember (bind e1 m y) as e2 eqn:E2.
      rewrite evalIff, evalEqu, evalAll, E2, bindSame, bindDiff, E1, bindSame.
      destruct (H x y) as [H1 H2]. clear H. split; intros H'.
        + intros z. rewrite <- E1, <- E2, evalIff, evalElem, evalElem, bindSame.
          rewrite  bindDiff, bindDiff, E2, bindSame, bindDiff, E1, bindSame.
           apply H1.
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
        + apply H2. intros z. remember (H' z) as H eqn:E. clear E. clear H'.
          rewrite <- E1 in H. rewrite <- E2 in H. rewrite evalIff in H.
          rewrite evalElem in H. rewrite evalElem in H. rewrite bindSame in H.
          rewrite bindDiff in H. rewrite bindDiff in H. rewrite E2 in H.
          rewrite bindSame in H. rewrite bindDiff in H. rewrite E1 in H.
          rewrite bindSame in H.
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
        + assumption.
        + assumption.
        + assumption.
Qed.

Import SemanCtx.
Lemma evalExtensionalityFCtx : LEM -> forall (G:Context) (n m p:nat),
    n <> m  ->
    n <> p  ->
    m <> p  ->
    G :- (extensionalityF n m p) >>
        forall (x y:set), x == y <-> forall (z:set), z :: x <-> z :: y.
Proof.
    intros L G n m p H1 H2 H3. unfold extensionalityF.
    apply evalAll. intros x. apply evalAll. intros y.
    apply evalIff; try assumption.
    - apply evalEqu; try assumption.
        + apply FindS. assumption. apply FindZ.
        + apply FindZ.
    - apply evalAll. intros z. apply evalIff; try assumption.
        + apply evalElem; try (apply FindZ).
          apply FindS; try assumption. apply FindS; try assumption.
          apply FindZ.
        + apply evalElem; try (apply FindZ).
          apply FindS; try assumption. apply FindZ.
Qed.

Import Semantics.
(* Evaluating doubleInclF in any environment 'yields' the theorem doubleIncl.   *)
Lemma evalDoubleInclF : LEM -> forall (e:Env) (n m:nat),
    m <> n ->
    eval e (doubleInclF n m)
        <->
    forall (x y:set), x == y <-> (x <= y) /\ (y <= x).
Proof.
    intros L e n m Hmn. unfold doubleInclF. rewrite evalAll. split; intros H x.
    - intros y. remember (H x) as H' eqn:E. clear E. clear H.
      rewrite evalAll in H'. remember (H' y) as H eqn:E. clear E. clear H'.
      remember (bind e n x) as e1 eqn:E1.
      rewrite evalIff in H. rewrite evalEqu in H. rewrite evalAnd  in H.
      rewrite evalSub in H. rewrite evalSub in H. rewrite bindSame in H.
      rewrite bindDiff in H. rewrite E1 in H. rewrite bindSame in H.
        + assumption.
        + assumption.
        + assumption.
        + assumption.
        + assumption.
    - rewrite evalAll. intros y.
      remember (bind e n x) as e1 eqn:E1.
      rewrite evalIff, evalEqu, evalAnd, evalSub, evalSub, bindSame.
      rewrite bindDiff, E1, bindSame.
        + apply H.
        + assumption.
        + assumption.
        + assumption.
        + assumption.
Qed.

Import SemanCtx.
Lemma evalDoubleInclFCtx : LEM -> forall (G:Context) (n m:nat),
    n <> m ->
    G :- (doubleInclF n m) >>
        forall (x y:set), x == y <-> (x <= y) /\ (y <= x).
Proof.
    intros L G n m H1. unfold doubleInclF.
    apply evalAll. intros x. apply evalAll. intros y.
    apply evalIff; try assumption.
    - apply evalEqu; try assumption.
        + apply FindS; try assumption. apply FindZ.
        + apply FindZ.
    - apply evalAnd; try assumption.
        + apply evalSub.
            { apply FindS; try assumption. apply FindZ. }
            { apply FindZ. }
        + apply evalSub.
            { apply FindZ. }
            { apply FindS; try assumption. apply FindZ. }
Qed.


Set Universe Polymorphism.

Definition comp {A B C : Type} (f : A -> B) (g : B -> C) := fun x => g (f x).
Definition id (A : Type) := fun x : A => x.

Inductive eq {A : Type} (a : A) : A -> Type := eq_refl : eq a a.

Notation "a == b" := (eq a b) (at level 70).

Lemma eq_sym {A} {x y : A} : x == y -> y == x.
Proof.
  intros [].
  reflexivity.
Defined.

Lemma eq_trans {A} {x y z : A} : x == y -> y == z -> x == z.
Proof.
  intros [] [].
  reflexivity.
Defined.

Lemma eq_trans_assoc {A} {w x y z : A} (p1 : w == x) (p2 : x == y) (p3 : y == z) :
  eq_trans (eq_trans p1 p2) p3 == eq_trans p1 (eq_trans p2 p3).
Proof.
  destruct p1, p2, p3.
  reflexivity.
Defined.

Lemma eq_trans_sym {A} {x y : A} (p1 : eq x y) :
  eq_trans p1 (eq_sym p1) == eq_refl x.
Proof.
  destruct p1.
  reflexivity.
Defined.

Lemma eq_sym_trans {A} {x y : A} (p1 : eq x y) :
  eq_trans (eq_sym p1) p1 == eq_refl y.
Proof.
  destruct p1.
  reflexivity.
Defined.

Lemma eq_trans_refl {A} {x y : A} (p : x == y) : eq_trans p (eq_refl y) == p.
Proof.
  destruct p; reflexivity.
Defined.

Lemma eq_trans_sym_eq {A} {x y z : A} (p : x == y) (q : x == z) (r : y == z) :
  q == eq_trans p r -> eq_trans (eq_sym p) q == r.
Proof.
  destruct r; simpl; destruct q; simpl.
  intro H.
  assert (eq_refl x == p).
  - apply (@eq_trans (x == x) (eq_refl x) (eq_trans p (eq_refl x)) p).
    + apply H.
    + apply eq_trans_refl.
  - destruct X.
    reflexivity.
Defined.

Definition f_equal {A B} (f : A -> B) {x y : A} (p : x == y) : f x == f y.
Proof.
  destruct p.
  reflexivity.
Defined.

Lemma f_equal_id {A} {x y : A} (p : x == y) : f_equal (id A) p == p.
Proof.
  destruct p.
  reflexivity.
Defined.

Lemma f_equal_comp {A B C} (f : A -> B) (g : B -> C) x y (p : x == y) :
  f_equal g (f_equal f p) == f_equal (comp f g) p.
Proof.
  destruct p.
  reflexivity.
Defined.

Lemma natural_transf {A B} {f g : A -> B} (H : forall x, f x == g x) x y (p : x == y) :
  eq_trans (H x) (f_equal g p) == eq_trans (f_equal f p) (H y).
Proof.
  destruct p.
  simpl.
  destruct (H x).
  reflexivity.
Defined.

Definition isContr (A : Type) := {x : A & forall y : A, x == y}.
Definition isProp A := forall a b : A, a == b.

Definition funext_statement :=
  forall A B (f g : forall x : A, B x), (forall x : A, f x == g x) -> f == g.

Definition pinv {A B} (f : A -> B) (g : B -> A) :=
  forall x : B, f (g x) == x.

Definition qinv {A B} (f : A -> B) := {g : B -> A & ((pinv f g) * (pinv g f))%type}.

Definition fiber {A B} (f : A -> B) (y : B) := {x : A & f x == y}.

(* We choose this definition for equivalence (contractible function)
because a rather weak form of functional extensionality is enough to
prove that it is a mere proposition. *)
Definition isEqv {A B} (f : A -> B) :=
  forall y : B, isContr (fiber f y).

Definition eqv A B := sigT (@isEqv A B).

Notation "A ≃ B" := (eqv A B) (at level 70).

Definition eqv_fun {A B} (e : A ≃ B) : A -> B :=
  let (f, _) := e in f.

Coercion eqv_fun : eqv >-> Funclass.

(* This other possible definition of equivalence is used to show qinv f -> isEqv f *)
Definition half_adjoint {A B} f :=
  { g : B -> A &
  { eta : pinv g f &
  { eps : pinv f g &
          forall x, f_equal f (eta x) == eps (f x)}}}.

Lemma qinv_half_adjoint {A B} (f : A -> B) : qinv f -> half_adjoint f.
  intros (g, (eps, eta)).
  exists g.
  exists eta.
  exists (fun b => eq_trans (eq_sym (eps (f(g(b))))) (eq_trans (f_equal f (eta (g b))) (eps b))).
  intro a.
  symmetry.
  assert (eta (g (f a)) == f_equal g (f_equal f (eta a))).
  - assert (forall p, eq_trans (eta (g (f a))) p == eq_trans (f_equal g (f_equal f p)) (eta a)).
    + intro p.
      destruct p.
      simpl.
      destruct (eta (g (f a))).
      reflexivity.
    + specialize (X (eta a)).
      apply (f_equal (fun e => eq_trans e (eq_sym (eta a)))) in X.
      rewrite eq_trans_assoc in X.
      rewrite eq_trans_sym in X.
      simpl in X.
      rewrite eq_trans_assoc in X.
      rewrite eq_trans_sym in X.
      apply (eq_trans (eq_sym (eq_trans_refl (eta (g (f a)))))).
      apply (eq_trans X).
      apply eq_trans_refl.
  - rewrite X.
    apply eq_trans_sym_eq.
    rewrite f_equal_comp.
    symmetry.
    refine (eq_trans _ (natural_transf eps _ _ (f_equal f (eta a)))).
    rewrite f_equal_id.
    reflexivity.
Defined.

Lemma half_adjoint_isEqv {A B} (f : A -> B) :
  half_adjoint f -> isEqv f.
Proof.
  intros (g, (eta, (eps, tau))) y.
  exists (existT _ (g y) (eps y)).
  intros (x, Hx).
  destruct Hx.
  rewrite <- tau.
  destruct (eta x).
  reflexivity.
Defined.

Lemma qinv_isEqv {A B} {f : A -> B} : qinv f -> isEqv f.
Proof.
  intro H.
  apply half_adjoint_isEqv.
  apply qinv_half_adjoint.
  exact H.
Defined.

(* Going in the other direction (from isEqv to qinv) is easy: *)
Definition isEqv_inv {A B} (f : A -> B) :
  isEqv f -> B -> A.
Proof.
  intros Hf y.
  destruct (Hf y) as ((x, _), _).
  exact x.
Defined.

Lemma isEqv_inv_eta {A B} (f : A -> B) (Hf : isEqv f) :
  pinv (isEqv_inv f Hf) f.
Proof.
  intro x.
  unfold isEqv_inv.
  destruct (Hf (f x)) as ((x', Hx'), H').
  specialize (H' (existT (fun x' => f x' == f x) x (eq_refl (f x)))).
  apply (f_equal (@projT1 A (fun x' => f x' == f x))) in H'.
  exact H'.
Defined.

Lemma isEqv_inv_eps {A B} (f : A -> B) (Hf : isEqv f) :
  pinv f (isEqv_inv f Hf).
Proof.
  intro y.
  unfold isEqv_inv.
  destruct (Hf y) as ((x', Hx'), H').
  assumption.
Defined.

Lemma isEqv_qinv {A B} (f : A -> B) : isEqv f -> qinv f.
Proof.
  intro Hf.
  exists (isEqv_inv _ Hf).
  split.
  - apply isEqv_inv_eps.
  - apply isEqv_inv_eta.
Defined.

Section with_funext.
  Hypothesis funext : funext_statement.

  Lemma isProp_isContr A : isProp (isContr A).
  Proof.
    intros a b.
    destruct a as (a, Ha).
    destruct b as (b, Hb).
    transitivity
      (existT (fun x : A => forall y : A, x == y) a
              (fun y => eq_trans (Ha b) (Hb y))).
    - apply f_equal.
      apply funext.
      intro c.
      destruct (Hb c).
      apply eq_sym.
      apply eq_trans_refl.
    - destruct (Ha b).
      apply f_equal.
      apply funext.
      intro b.
      destruct (Hb b).
      reflexivity.
  Defined.

  Lemma isProp_isEqv {A B} (f : A -> B) :
    isProp (isEqv f).
  Proof.
    intros H1 H2.
    apply funext.
    intro x.
    apply isProp_isContr.
  Defined.
End with_funext.

Lemma isEqv_id A : isEqv (id A).
Proof.
  apply qinv_isEqv.
  exists (id A).
  split; exact (fun x => eq_refl x).
Defined.

Definition eqv_refl A : A ≃ A := existT _ (id A) (isEqv_id A).

Lemma id_to_eqv {A B} : A == B -> A ≃ B.
Proof.
  intros [].
  apply eqv_refl.
Defined.

Lemma f_equal_trans {A B} (f : A -> B) x y z (p : x == y) (q : y == z):
  f_equal f (eq_trans p q) == eq_trans (f_equal f p) (f_equal f q).
Proof.
  destruct p, q.
  reflexivity.
Defined.

Lemma f_equal_sym {A B} (f : A -> B) x y (p : x == y) :
  f_equal f (eq_sym p) == eq_sym (f_equal f p).
Proof.
  destruct p.
  reflexivity.
Defined.

Lemma isEqv_intro {A B} {f : A -> B} g : pinv f g -> pinv g f -> isEqv f.
Proof.
  intros eps eta.
  apply qinv_isEqv.
  exists g.
  split; assumption.
Defined.

Lemma inv_isEqv {A B} {f : A -> B} (H : isEqv f) : isEqv (isEqv_inv f H).
Proof.
  apply (isEqv_intro f).
  - apply isEqv_inv_eta.
  - apply isEqv_inv_eps.
Defined.

Lemma eqv_sym {A B} : A ≃ B -> B ≃ A.
Proof.
  intros (f, H).
  exists (isEqv_inv f H).
  apply inv_isEqv.
Defined.

Lemma eqv_sym_eps {A B} (f : A ≃ B) : pinv f (eqv_sym f).
Proof.
  destruct f as (f, Hf).
  simpl.
  apply isEqv_inv_eps.
Defined.

Lemma eqv_sym_eta {A B} (f : A ≃ B) : pinv (eqv_sym f) f.
Proof.
  destruct f as (f, Hf).
  simpl.
  apply isEqv_inv_eta.
Defined.

Lemma eqv_trans {A B C} : A ≃ B -> B ≃ C -> A ≃ C.
Proof.
  intros (f, Hf) (g, Hg).
  exists (comp f g).
  apply (isEqv_intro (comp (isEqv_inv g Hg) (isEqv_inv f Hf))).
  - intro c.
    unfold comp.
    rewrite isEqv_inv_eps.
    apply isEqv_inv_eps.
  - intro a.
    unfold comp.
    rewrite isEqv_inv_eta.
    apply isEqv_inv_eta.
Defined.

Lemma isContr_retract {A B} (f : A -> B) (g : B -> A) :
  pinv f g -> isContr A -> isContr B.
Proof.
  intros H (a, Ha).
  exists (f a).
  intro y.
  rewrite <- H.
  apply f_equal.
  apply Ha.
Defined.

Lemma happly {A B} (f g : forall x : A, B x) : f == g -> forall x, f x == g x.
Proof.
  intros [].
  reflexivity.
Defined.

Lemma between_contr_isEqv {A B} (f : A -> B) :
  isContr A -> isContr B -> isEqv f.
Proof.
  intros (a, HA) (b, HB).
  apply qinv_isEqv.
  exists (fun y => a).
  split.
  - intro y.
    transitivity b.
    + symmetry.
      apply HB.
    + apply HB.
  - intro x.
    apply HA.
Defined.

Lemma isContr_eqv {A B} (f : A ≃ B) : isContr A -> isContr B.
Proof.
  intros (a, HA).
  exists (f a).
  intro y.
  specialize (HA (eqv_sym f y)).
  rewrite HA.
  apply eqv_sym_eps.
Defined.

Definition total {A P Q} (f : forall x : A, P x -> Q x) :
  {x : A & P x} -> {x : A & Q x} :=
  (fun w => existT Q (projT1 w) (f (projT1 w) (projT2 w))).

Definition transport {A} (P : A -> Type) {x y : A} (p : x == y) : P x -> P y.
Proof.
  destruct p; auto.
Defined.

Lemma fiber_total_fun {A P Q} (f : forall x : A, P x -> Q x) (w : sigT Q) :
  (fiber (total f) w) -> (fiber (f (projT1 w)) (projT2 w)).
Proof.
  intros ((a, p), H).
  unfold total in H.
  simpl in H.
  unfold fiber.
  exists (transport P (f_equal (@projT1 A Q) H) p).
  destruct H.
  reflexivity.
Defined.

Lemma fiber_total_inv {A P Q} (f : forall x : A, P x -> Q x) (w : sigT Q) :
  (fiber (f (projT1 w)) (projT2 w)) -> (fiber (total f) w).
Proof.
  destruct w as (x, v).
  intros (p, H).
  unfold total, fiber.
  exists (existT P x p).
  simpl.
  apply f_equal.
  exact H.
Defined.

Lemma fiber_total {A P Q} (f : forall x : A, P x -> Q x) w :
  eqv (fiber (total f) w) (fiber (f (projT1 w)) (projT2 w)).
Proof.
  exists (fiber_total_fun f w).
  apply (isEqv_intro (fiber_total_inv f w)).
  - destruct w as (x, v).
    simpl.
    intros (p, H).
    simpl.
    destruct H.
    reflexivity.
  - intros ((a, p), H).
    simpl.
    destruct H.
    reflexivity.
Defined.

Definition fiberwise_eqv {A P Q} (f : forall x : A, P x -> Q x) :=
  forall x, isEqv (f x).

Lemma fiberwise_eqv_total {A P Q} (f : forall x : A, P x -> Q x) :
  fiberwise_eqv f -> isEqv (total f).
Proof.
  intro H.
  unfold isEqv.
  intros w.
  apply (isContr_eqv (eqv_sym (fiber_total f w))).
  apply H.
Defined.

Lemma fiberwise_eqv_total_rev {A P Q} (f : forall x : A, P x -> Q x) :
  isEqv (total f) -> fiberwise_eqv f.
Proof.
  unfold isEqv.
  intros H x.
  intro q.
  apply (isContr_eqv (fiber_total f (existT Q x q))).
  apply H.
Defined.

Section with_weak_funext.

  (* The proof of weak-funext -> funext from the HoTT book. *)

  Hypothesis weak_funext : forall A (P : A -> Type),
    (forall x, isContr (P x)) -> isContr (forall x, P x).

  Definition codom_happly1 {A B} (f : forall x : A, B x) :=
    {g : forall x, B x & forall x, f x == g x}.

  Lemma codom_happly1_to_fun {A B} (f : forall x : A, B x) :
    codom_happly1 f -> forall x, {u : B x & f x == u}.
  Proof.
    intros (g, H) x.
    exists (g x).
    apply H.
  Defined.

  Lemma fun_to_codom_happly1 {A B} (f : forall x : A, B x) :
    (forall x, {u : B x & f x == u}) -> codom_happly1 f.
  Proof.
    intros H.
    exists (fun x => projT1 (H x)).
    intro x.
    destruct (H x) as (u, Hu).
    exact Hu.
  Defined.

  Lemma isEqv_happly {A B} (f g : forall x : A, B x) : isEqv (happly f g).
  Proof.
    generalize g; clear g.
    apply fiberwise_eqv_total_rev.
    apply between_contr_isEqv.
    - exists (existT _ f (eq_refl f)).
      intros (g, H).
      destruct H.
      reflexivity.
    - apply (isContr_retract (fun_to_codom_happly1 f) (codom_happly1_to_fun f)).
      + intros (g, H).
        reflexivity.
      + apply weak_funext.
        intro x.
        exists (existT _ (f x) (eq_refl _)).
        intros (y, Hy).
        destruct Hy.
        reflexivity.
  Qed.

  Lemma happly_eqv {A B} (f g : forall x : A, B x) : (f == g) ≃ (forall x, f x == g x).
  Proof.
    exists (happly f g).
    apply isEqv_happly.
  Defined.

  Theorem funext : funext_statement.
  Proof.
    intros A B f g.
    exact (eqv_sym (happly_eqv f g)).
  Defined.

  Lemma funext_id {A B} {f : forall x : A, B x} :
    funext A B f f (fun x => eq_refl (f x)) == eq_refl f.
  Proof.
    change (funext A B f f (happly_eqv f f (eq_refl f)) == eq_refl f).
    apply (eqv_sym_eta (happly_eqv f f)).
  Defined.

End with_weak_funext.

Definition FUNEXT := forall A B (f g : forall x : A, B x), isEqv (happly f g).

Lemma isProp_prod {A B} : isProp A -> isProp B -> isProp (A * B).
Proof.
  intros HA HB (a1, b1) (a2, b2).
  specialize (HA a1 a2).
  destruct HA.
  specialize (HB b1 b2).
  destruct HB.
  reflexivity.
Defined.

Lemma Dep_Funext (funext : FUNEXT) {A B} (f g : forall x : A, B x) :
  (forall x, f x == g x) -> f == g.
Proof.
  apply eqv_fun.
  apply eqv_sym.
  exists (happly f g).
  apply funext.
Defined.

Lemma Dep_Funext_funapp (funext : FUNEXT) {A B} (f g : forall x : A, B x) e :
  Dep_Funext funext f g (fun x => happly f g e x) == e.
Proof.
  apply isEqv_inv_eta.
Defined.

Lemma Dep_Funext_refl (funext : FUNEXT) {A B} (f : forall x : A, B x) :
  Dep_Funext funext f f (fun x => eq_refl (f x)) == eq_refl _.
Proof.
  exact (Dep_Funext_funapp funext f f (eq_refl _)).
Defined.

Lemma comp_id_pinv_eqv {A B} (f : A -> B) (g : B -> A) :
  FUNEXT -> pinv f g ≃ (comp g f == id B).
Proof.
  unfold FUNEXT.
  intro funext.
  apply eqv_sym.
  eexists.
  exact (funext _ _ (comp g f) (id B)).
Defined.

Lemma sigT_eqv_fun {A B1 B2} :
  (forall x : A, B1 x ≃ B2 x) ->
  {x : A & B1 x} -> {x : A & B2 x}.
Proof.
  intro H.
  intros (a, b).
  exists a.
  specialize (H a).
  exact (H b).
Defined.

Lemma sigT_eqv_pinv {A B1 B2} {H : forall x : A, B1 x ≃ B2 x} :
  pinv (sigT_eqv_fun H) (sigT_eqv_fun (fun x => eqv_sym (H x))).
Proof.
  intros (a, b).
  simpl.
  assert ((H a) ((eqv_sym (H a)) b) == b).
  - generalize (H a).
    intros (F, HF).
    unfold eqv_sym.
    simpl.
    apply isEqv_inv_eps.
  - rewrite X.
    reflexivity.
Defined.

Lemma sigT_eqv_pinv2 {A B1 B2} {H : forall x : A, B1 x ≃ B2 x} :
  pinv (sigT_eqv_fun (fun x => eqv_sym (H x))) (sigT_eqv_fun H).
Proof.
  intros (a, b).
  simpl.
  assert (((eqv_sym (H a)) ((H a) b)) == b).
  - generalize (H a).
    intros (F, HF).
    unfold eqv_sym.
    simpl.
    apply isEqv_inv_eta.
  - rewrite X.
    reflexivity.
Defined.

Lemma sigT_eqv {A B1 B2} :
  (forall x, B1 x ≃ B2 x) -> {x : A & B1 x} ≃ {x : A & B2 x}.
Proof.
  intro H.
  exists (sigT_eqv_fun H).
  apply (isEqv_intro (sigT_eqv_fun (fun x => eqv_sym (H x)))).
  - apply sigT_eqv_pinv.
  - apply sigT_eqv_pinv2.
Defined.

Lemma isProp_eqv {A B} : isProp A -> A ≃ B -> isProp B.
Proof.
  intros HA HAB b1 b2.
  destruct HAB as (f, Hf).
  rewrite <- (isEqv_inv_eps _ Hf b1).
  rewrite <- (isEqv_inv_eps _ Hf b2).
  apply f_equal.
  apply HA.
Defined.

Definition sigT_eqv_type {A P} (w w' : {x : A & P x}) :=
  let (x, p) := w in
  let (x', p') := w' in
  {e : x == x' & transport P e p == p'}.

Definition sigT_fun {A P} (w w' : {x : A & P x}) :
  w == w' ->
  sigT_eqv_type w w'.
Proof.
  intros [].
  destruct w as (x, p).
  exists (eq_refl _).
  reflexivity.
Defined.

Definition sigT_fun_inv {A P} (w w' : {x : A & P x}) :
  sigT_eqv_type w w' -> w == w'.
Proof.
  destruct w as (x, p).
  destruct w' as (x', p').
  simpl.
  intros (e, gamma).
  destruct e.
  simpl in gamma.
  destruct gamma.
  reflexivity.
Defined.

Lemma sigT_eqv_eq {A P} (w w' : {x : A & P x}) :
  (w == w') ≃ sigT_eqv_type w w'.
Proof.
  exists (sigT_fun w w').
  apply (isEqv_intro (sigT_fun_inv w w')).
  - destruct w as (x, p).
    destruct w' as (x', p').
    simpl.
    intros (e, gamma).
    destruct e.
    simpl in gamma.
    destruct gamma.
    reflexivity.
  - intro e.
    destruct e.
    destruct w as (w, p).
    reflexivity.
Defined.

Lemma fiber_path {A B} (f : A -> B) (y : B) x (p : f x == y) x' (p' : f x' == y) :
  (@eq (fiber f y) (existT _ x p) (existT _ x' p')) ≃ {gamma : x == x' & eq_trans (f_equal f gamma) p' == p}.
Proof.
  apply (eqv_trans (sigT_eqv_eq _ _)).
  simpl.
  apply sigT_eqv.
  intro e.
  destruct e.
  simpl.
  apply (@eqv_trans _ (p' == p)).
  - exists (@eq_sym _ p p').
    apply (isEqv_intro (@eq_sym _ p' p)).
    + intros [].
      reflexivity.
    + intros [].
      reflexivity.
  - destruct p'.
    apply eqv_refl.
Defined.

Lemma isContr_isProp {A : Type} : isContr A -> isProp A.
Proof.
  intros (x, H) a b.
  transitivity x.
  - symmetry.
    apply H.
  - apply H.
Defined.

Lemma isProp_to_isContr {A : Type} (a : A) : isProp A -> isContr A.
Proof.
  intro H.
  exists a.
  apply H.
Defined.

Lemma isProp_eq_is_contr A : isProp A -> forall x y : A, isContr (x == y).
Proof.
  intros f x y.
  exists (f x y).
  assert (forall z : A, forall p : z == y, p == eq_trans (eq_sym (f x z)) (f x y)).
  - intros z p.
    symmetry.
    apply eq_trans_sym_eq.
    destruct p.
    apply eq_sym.
    apply eq_trans_refl.
  - assert (forall e1 e2 : x == y, e1 == e2).
    + specialize (X x).
      intros e1 e2.
      apply (@eq_trans _ _ (eq_trans (eq_sym (f x x)) (f x y))).
      * apply X.
      * apply eq_sym.
        apply X.
    + apply X0.
Defined.

Lemma isProp_eq A : isProp A -> forall x y : A, isProp (x == y).
Proof.
  intros H x y.
  apply isContr_isProp.
  apply isProp_eq_is_contr.
  assumption.
Defined.

Lemma eqv_prod {A A' B B'} : A ≃ B -> A' ≃ B' -> (A * A') ≃ (B * B').
Proof.
  intros (f, H) (f', H').
  exists (fun c : A * A' => let (a, a') := c in (f a, f' a')).
  apply (isEqv_intro (fun c : B * B' => let (b, b') := c in (isEqv_inv _ H b, isEqv_inv _ H' b'))).
  - intros (b, b').
    rewrite isEqv_inv_eps.
    rewrite isEqv_inv_eps.
    reflexivity.
  - intros (a, a').
    rewrite isEqv_inv_eta.
    rewrite isEqv_inv_eta.
    reflexivity.
Defined.

Lemma eqv_prod_sigma {A B} : (A * B) ≃ {x : A & B}.
Proof.
  exists (fun c : A * B => let (a, b) := c in existT (fun _ => B) a b).
  apply (isEqv_intro (fun c : {x : A & B} => let (a, b) := c in (a, b))).
  - intros (a, b). reflexivity.
  - intros (a, b). reflexivity.
Defined.

Lemma isContr_unit {A} : isContr A -> A ≃ unit.
Proof.
  intros (x, H).
  exists (fun _ => tt).
  apply (isEqv_intro (fun _ => x)).
  - intros [].
    reflexivity.
  - intro y.
    apply H.
Defined.

Lemma eqv_prod_unit {A} : (A * unit) ≃ A.
Proof.
  exists (fun au : A * unit => let (a, _) := au in a).
  apply (isEqv_intro (fun a => (a, tt))).
  - intro.
    reflexivity.
  - intros (a, []).
    reflexivity.
Defined.

Lemma isEqv_homotopy {A B} (f g : A -> B) :
  isEqv f -> (forall x, f x == g x) -> isEqv g.
Proof.
  intros Hf Hfg.
  apply isEqv_qinv in Hf.
  destruct Hf as (h, (Hhf, Hfh)).
  apply (isEqv_intro h).
  - intro y.
    rewrite <- Hfg.
    apply Hhf.
  - intro x.
    rewrite <- Hfg.
    apply Hfh.
Defined.


(* AlgCloCharPol.v *)

Require Import Utf8 QArith NPeano ArithRing.

Require Import Misc.
Require Import Field2.
Require Import ConvexHull.
Require Import Newton.
Require Import Fsummation.
Require Import Fpolynomial.
Require Import Puiseux_base.
Require Import Puiseux_series.
Require Import CharactPolyn.

Set Implicit Arguments.

(* euclidean division of a polynomial by (x - c) *)

Fixpoint lap_mod_div_deg_1 α (r : ring α) la c :=
  match la with
  | [] => []
  | [a₁ … la₁] => [apply_lap la c … lap_mod_div_deg_1 r la₁ c]
  end.

Definition lap_div_deg_1 α {R : ring α} la c :=
  match lap_mod_div_deg_1 R la c with
  | [] => []
  | [m … ml] => ml
  end.

Definition lap_mod_deg_1 α {R : ring α} la c :=
  match lap_mod_div_deg_1 R la c with
  | [] => 0%K
  | [m … ml] => m
  end.

Fixpoint comb n k :=
  match k with
  | 0%nat => 1%nat
  | S k₁ =>
      match n with
      | 0%nat => 0%nat
      | S n₁ => (comb n₁ k₁ + comb n₁ k)%nat
      end
  end.

Fixpoint rng_mul_nat α (r : ring α) n x :=
  match n with
  | O => 0%K
  | S n₁ => (rng_mul_nat r n₁ x + x)%K
  end.

Theorem comb_lt : ∀ n k, (n < k)%nat → comb n k = 0%nat.
Proof.
intros n k Hnk.
revert k Hnk.
induction n; intros; simpl.
 destruct k; [ exfalso; revert Hnk; apply Nat.nlt_0_r | auto ].

 destruct k; [ exfalso; revert Hnk; apply Nat.nlt_0_r | auto ].
 apply Nat.succ_lt_mono in Hnk.
 rewrite IHn; [ idtac | assumption ].
 rewrite IHn; [ reflexivity | idtac ].
 apply Nat.lt_lt_succ_r; assumption.
Qed.

Theorem comb_id : ∀ n, comb n n = 1%nat.
Proof.
intros n.
induction n; [ reflexivity | simpl ].
rewrite IHn, comb_lt; [ idtac | apply Nat.lt_succ_r; reflexivity ].
rewrite Nat.add_0_r; reflexivity.
Qed.

Theorem rng_mul_nat_1_l : ∀ α (r : ring α) a, (rng_mul_nat r 1 a = a)%K.
Proof. intros α r a; simpl; rewrite rng_add_0_l; reflexivity. Qed.

Theorem comb_0_r : ∀ i, comb i 0 = 1%nat.
Proof. intros i; destruct i; reflexivity. Qed.

Theorem comb_1_r : ∀ n, comb n 1 = n.
Proof.
intros n.
induction n; [ reflexivity | simpl ].
rewrite comb_0_r, IHn; reflexivity.
Qed.

Add Parametric Morphism α (R : ring α) : (@apply_lap _ R)
  with signature lap_eq ==> rng_eq ==> rng_eq
  as apply_lap_morph.
Proof.
intros la lb Hab x y Hxy.
unfold apply_lap.
revert lb Hab x y Hxy.
induction la as [| a]; intros; simpl.
 revert x y Hxy.
 induction lb as [| b]; intros; [ reflexivity | simpl ].
 apply lap_eq_nil_cons_inv in Hab.
 destruct Hab as (Hb, Hlb).
 rewrite Hb, rng_add_0_r.
 rewrite <- IHlb; try eassumption.
 rewrite rng_mul_0_l; reflexivity.

 destruct lb as [| b].
  apply lap_eq_cons_nil_inv in Hab.
  destruct Hab as (Ha, Hla).
  rewrite Ha, rng_add_0_r; simpl.
  rewrite IHla; try eassumption; simpl.
  rewrite rng_mul_0_l; reflexivity.

  simpl.
  apply lap_eq_cons_inv in Hab.
  destruct Hab as (Hab, Hlab).
  rewrite Hab, Hxy.
  rewrite IHla; try eassumption.
  reflexivity.
Qed.

Add Parametric Morphism α (R : ring α) : (@apply_poly _ R)
  with signature eq_poly ==> rng_eq ==> rng_eq
  as apply_poly_morph.
Proof.
intros p₁ p₂ Hpp v₁ v₂ Hvv.
unfold eq_poly in Hpp.
unfold apply_poly.
rewrite Hpp, Hvv; reflexivity.
Qed.

Theorem rng_mul_nat_add_distr_r : ∀ α (r : ring α) a m n,
  (rng_mul_nat r (m + n) a = rng_mul_nat r m a + rng_mul_nat r n a)%K.
Proof.
intros α r a m n.
revert a n.
induction m; intros; simpl.
 rewrite rng_add_0_l; reflexivity.

 rewrite IHm.
 apply rng_add_shuffle0.
Qed.

Add Parametric Morphism α (r : ring α) : (rng_mul_nat r)
  with signature eq ==> rng_eq ==> rng_eq
  as rng_mul_nat_morph.
Proof.
intros n a b Hab.
induction n; [ reflexivity | simpl ].
rewrite IHn, Hab; reflexivity.
Qed.

Theorem lap_eq_map_ext : ∀ α (r : ring α) A g h,
  (∀ a : A, (g a = h a)%K)
  → ∀ la : list A, (List.map g la = List.map h la)%lap.
Proof.
intros α r A g h Hgh la.
induction la as [| a]; [ reflexivity | simpl ].
constructor; [ apply Hgh | assumption ].
Qed.

Theorem rng_mul_nat_assoc : ∀ α (R : ring α) n a b,
  (rng_mul_nat R n a * b = rng_mul_nat R n (a * b))%K.
Proof.
intros α R n a b.
induction n; simpl.
 rewrite rng_mul_0_l; reflexivity.

 rewrite rng_mul_add_distr_r, IHn; reflexivity.
Qed.

Theorem apply_lap_add : ∀ α (r : ring α) la lb x,
  (apply_lap (lap_add la lb) x =
   apply_lap la x + apply_lap lb x)%K.
Proof.
intros α r la lb x.
revert lb x.
induction la as [| a]; intros; simpl.
 rewrite rng_add_0_l; reflexivity.

 destruct lb as [| b]; simpl.
  rewrite rng_add_0_r; reflexivity.

  rewrite IHla.
  do 2 rewrite rng_add_assoc.
  apply rng_add_compat_r.
  rewrite rng_add_shuffle0.
  rewrite rng_mul_add_distr_r; reflexivity.
Qed.

Theorem apply_lap_single : ∀ α (r : ring α) a lb x,
  (apply_lap (lap_mul [a] lb) x = a * apply_lap lb x)%K.
Proof.
intros α r a lb x.
induction lb as [| b].
 simpl; rewrite rng_mul_0_r; reflexivity.

 rewrite lap_mul_cons_r; simpl.
 rewrite summation_only_one, rng_add_0_r, IHlb.
 rewrite rng_mul_add_distr_l, rng_mul_assoc; reflexivity.
Qed.

Theorem apply_lap_mul : ∀ α (r : ring α) la lb x,
  (apply_lap (lap_mul la lb) x =
   apply_lap la x * apply_lap lb x)%K.
Proof.
intros α r la lb x.
revert lb x.
induction la as [| a]; intros; simpl.
 rewrite lap_mul_nil_l, rng_mul_0_l; reflexivity.

 destruct lb as [| b]; simpl.
  rewrite lap_mul_nil_r, rng_mul_0_r; reflexivity.

  rewrite lap_mul_cons; simpl.
  rewrite apply_lap_add; simpl.
  rewrite rng_add_0_r.
  rewrite apply_lap_add.
  rewrite IHla.
  rewrite IHla.
  simpl.
  rewrite rng_mul_0_l, rng_add_0_l.
  do 3 rewrite rng_mul_add_distr_r.
  do 2 rewrite rng_mul_add_distr_l.
  do 2 rewrite rng_mul_assoc.
  rewrite rng_add_assoc.
  apply rng_add_compat_r.
  rewrite rng_add_comm, rng_add_assoc.
  do 2 rewrite <- rng_add_assoc.
  apply rng_add_compat.
   apply rng_mul_compat_r.
   apply rng_mul_shuffle0.

   apply rng_add_compat.
    apply rng_mul_shuffle0.

    apply rng_mul_compat_r.
    apply apply_lap_single.
Qed.

Theorem apply_lap_compose : ∀ α (r : ring α) la lb x,
  (apply_lap (lap_compose la lb) x =
   apply_lap la (apply_lap lb x))%K.
Proof.
intros α r la lb x.
unfold lap_compose.
revert lb x.
induction la as [| a]; intros; [ reflexivity | simpl ].
rewrite <- IHla; clear.
rewrite apply_lap_add; simpl.
rewrite rng_mul_0_l, rng_add_0_l.
apply rng_add_compat_r.
apply apply_lap_mul.
Qed.

Theorem list_seq_app : ∀ j dj len,
  (dj ≤ len)%nat
  → List.seq j len = List.seq j dj ++ List.seq (j + dj) (len - dj).
Proof.
intros j dj len Hjlen.
revert j dj Hjlen.
induction len; intros.
 simpl.
 apply Nat.le_0_r in Hjlen; subst dj; reflexivity.

 destruct dj; simpl.
  rewrite Nat.add_0_r.
  reflexivity.

  f_equal.
  rewrite Nat.add_succ_r, <- Nat.add_succ_l.
  apply le_S_n in Hjlen.
  erewrite IHlen; [ reflexivity | eassumption ].
Qed.

Theorem lap_mul_const_l : ∀ α (r : ring α) a lb,
  lap_eq (lap_mul [a] lb) (List.map (rng_mul a) lb).
Proof.
intros α r a lb.
unfold lap_mul; simpl.
induction lb as [| b]; [ reflexivity | simpl ].
rewrite summation_only_one.
constructor; [ reflexivity | idtac ].
rewrite lap_convol_mul_cons_succ; assumption.
Qed.

Theorem poly_compose_compose2 : ∀ α (r : ring α) P Q,
  (P ∘ Q = poly_compose2 P Q)%pol.
Proof.
intros α r P Q.
apply lap_compose_compose2.
Qed.

Theorem nth_mul_deg_1 : ∀ α (r : ring α) a lb k,
  (List.nth (S k) (lap_mul [a; 1 … []] lb) 0 =
   a * List.nth (S k) lb 0 + List.nth k lb 0)%K.
Proof.
intros α r a lb k.
unfold lap_mul.
rewrite list_nth_lap_convol_mul; [ idtac | reflexivity ].
rewrite summation_split_first; [ idtac | apply Nat.le_0_l ].
rewrite summation_split_first; [ simpl | apply le_n_S, Nat.le_0_l ].
rewrite all_0_summation_0.
 rewrite rng_mul_1_l, Nat.sub_0_r, rng_add_0_r; reflexivity.

 intros i (Hi, Hik).
 destruct i; [ exfalso; revert Hi; apply Nat.nle_succ_0 | idtac ].
 apply Nat.succ_le_mono in Hi.
 destruct i; [ exfalso; revert Hi; apply Nat.nle_succ_0 | idtac ].
 rewrite match_id, rng_mul_0_l; reflexivity.
Qed.

Theorem rng_mul_nat_mul_swap : ∀ α (r : ring α) n a b,
  (rng_mul_nat r n (a * b) = a * rng_mul_nat r n b)%K.
Proof.
intros α r n a b.
induction n; simpl.
 rewrite rng_mul_0_r; reflexivity.

 rewrite IHn, rng_mul_add_distr_l; reflexivity.
Qed.

(* *)

Fixpoint degree_plus_1_of_list α {R : ring α}
    (zerop : ∀ a, {(a = 0)%K} + {(a ≠ 0)%K}) (l : list α) :=
  match l with
  | [] => O
  | [x … l₁] =>
      match degree_plus_1_of_list zerop l₁ with
      | O => if zerop x then O else 1%nat
      | S n => S (S n)
      end
  end.

Definition degree α {R : ring α} zerop (f : polynomial α) :=
  pred (degree_plus_1_of_list zerop (al f)).

(* actually, field which is:
   - with characteristic 0 or 1
   - algebraically closed *)
Class algeb_closed_field α (ac_ring : ring α) (ac_field : field ac_ring) :=
  { ac_charac_01 : ∀ n, (rng_mul_nat ac_ring (S (S n)) 1 ≠ 0)%K;
    ac_root : polynomial α → α;
    ac_prop_root : ∀ f, degree fld_zerop f ≥ 1
      → (apply_poly f (ac_root f) = 0)%K }.

Definition ac_is_zero α {R : ring α} {K : field R}
  {acf : algeb_closed_field K} (x : α) := if fld_zerop x then True else False.

Fixpoint list_root_multiplicity
    α {r : ring α} {K : field r} (acf : algeb_closed_field K) c la d :=
  match d with
  | O => O
  | S d₁ =>
      if fld_zerop (lap_mod_deg_1 la c) then
        S (list_root_multiplicity acf c (lap_div_deg_1 la c) d₁)
      else O
  end.

Definition root_multiplicity α {r : ring α} {K : field r}
  (acf : algeb_closed_field K) c
    f :=
  list_root_multiplicity acf c (al f) (List.length (al f)).

Fixpoint list_quotient_phi_x_sub_c_pow_r α (R : ring α) la c₁ r :=
  match r with
  | O => la
  | S r₁ => list_quotient_phi_x_sub_c_pow_r R (lap_div_deg_1 la c₁) c₁ r₁
  end.

Definition quotient_phi_x_sub_c_pow_r α {R : ring α} f c₁ r :=
  (POL (list_quotient_phi_x_sub_c_pow_r R (al f) c₁ r))%pol.

Section theorems.

Variable α : Type.
Variable R : ring α.
Variable K : field R.
Variable acf : algeb_closed_field K.

Theorem list_nth_mod_div_deg_1 : ∀ la c i,
  (List.nth i (lap_mod_div_deg_1 R la c) 0 =
   apply_lap (List.skipn i la) c)%K.
Proof.
intros la c i; revert i.
induction la as [| a]; intros; simpl.
 rewrite match_id, list_skipn_nil; reflexivity.

 destruct i; [ reflexivity | apply IHla ].
Qed.

Theorem length_lap_mod_div_deg_1 : ∀ l c,
  length (lap_mod_div_deg_1 R l c) = length l.
Proof.
intros l c.
induction l; [ reflexivity | simpl ].
rewrite IHl; reflexivity.
Qed.

Theorem length_list_quotient_phi_x_sub_c_pow_r : ∀ l c r,
  length (list_quotient_phi_x_sub_c_pow_r R l c r) = (length l - r)%nat.
Proof.
intros l c r.
revert l c.
induction r; intros; simpl.
 rewrite Nat.sub_0_r; reflexivity.

 destruct l as [| x]; simpl.
  unfold lap_div_deg_1; simpl.
  rewrite IHr; reflexivity.

  unfold lap_div_deg_1; simpl.
  rewrite IHr.
  rewrite length_lap_mod_div_deg_1; reflexivity.
Qed.

Theorem root_formula : ∀ la c,
  (apply_lap la c = 0)%K
  → (la = [(- c)%K; 1%K … []] * lap_div_deg_1 la c)%lap.
Proof.
intros la c Hc.
unfold lap_div_deg_1.
remember (lap_mod_div_deg_1 R la c) as md eqn:Hmd .
symmetry in Hmd.
destruct md as [| r d].
 rewrite lap_mul_nil_r.
 destruct la as [| a]; [ reflexivity | discriminate Hmd ].

 destruct la as [| a]; [ discriminate Hmd | simpl ].
 simpl in Hmd.
 simpl in Hc.
 injection Hmd; clear Hmd; intros Hd Hr.
 subst d; clear r Hr.
 rename a into a₀.
 apply list_nth_lap_eq; intros i.
 destruct i.
  simpl.
  rewrite summation_only_one.
  destruct la as [| a₁].
   simpl.
   rewrite rng_mul_0_r.
   simpl in Hc.
   rewrite rng_mul_0_l, rng_add_0_l in Hc; assumption.

   simpl in Hc; simpl.
   remember (apply_lap la c * c + a₁)%K as v eqn:Hv .
   rewrite rng_mul_comm in Hc.
   apply rng_add_compat_r with (c := (- c * v)%K) in Hc.
   rewrite rng_add_0_l in Hc.
   rewrite rng_add_comm, rng_add_assoc in Hc.
   rewrite rng_mul_opp_l in Hc.
   rewrite rng_add_opp_l in Hc.
   rewrite rng_add_0_l in Hc.
   rewrite rng_mul_opp_l.
   assumption.

  rewrite nth_mul_deg_1; simpl.
  clear a₀ Hc.
  do 2 rewrite list_nth_mod_div_deg_1.
  revert i.
  induction la as [| a]; intros; simpl.
   rewrite match_id, list_skipn_nil; simpl.
   rewrite rng_mul_0_r, rng_add_0_l; reflexivity.

   destruct i; [ simpl | apply IHla ].
   rewrite rng_add_assoc.
   rewrite rng_mul_opp_l, rng_mul_comm.
   rewrite rng_add_opp_l, rng_add_0_l; reflexivity.
Qed.

Theorem list_root_mult_succ_if : ∀ la d c md n,
  list_root_multiplicity acf c la d = S n
  → lap_mod_div_deg_1 R la c = md
    → d ≠ O ∧ ac_is_zero (lap_mod_deg_1 la c) ∧
      list_root_multiplicity acf c (lap_div_deg_1 la c) (pred d) = n.
Proof.
intros la d c md n Hn Hmd.
destruct d; [ discriminate Hn | simpl in Hn ].
split; [ intros H; discriminate H | idtac ].
unfold ac_is_zero.
destruct (fld_zerop (lap_mod_deg_1 la c)) as [Hz| Hnz].
 split; [ constructor | idtac ].
 apply eq_add_S; assumption.

 discriminate Hn.
Qed.

Theorem list_length_shrink_le : ∀ k (l : list α),
  length (list_shrink k l) ≤ length l.
Proof.
intros k l.
unfold list_shrink.
assert (∀ cnt k₁, length (list_shrink_aux cnt k₁ l) ≤ length l) as H.
 intros cnt k₁.
 revert cnt.
 induction l as [| x]; intros; [ reflexivity | simpl ].
 destruct cnt; simpl.
  apply le_n_S, IHl.

  etransitivity; [ apply IHl | idtac ].
  apply Nat.le_succ_r; left; reflexivity.

 apply H.
Qed.

Theorem degree_plus_1_is_0 : ∀ la,
  degree_plus_1_of_list fld_zerop la = 0%nat
  → lap_eq la [].
Proof.
intros la H.
induction la as [| a]; [ reflexivity | idtac ].
simpl in H.
remember (degree_plus_1_of_list fld_zerop la) as d eqn:Hd .
symmetry in Hd.
destruct d; [ idtac | discriminate H ].
constructor; [ idtac | apply IHla; reflexivity ].
destruct (fld_zerop a); [ assumption | discriminate H ].
Qed.

Theorem lap_eq_nil_nth : ∀ la,
  lap_eq la []
  → ∀ n, (List.nth n la 0 = 0)%K.
Proof.
intros la H n.
revert n.
induction la as [| a]; intros; simpl.
 rewrite match_id; reflexivity.

 apply lap_eq_cons_nil_inv in H.
 destruct H as (Ha, Hla).
 destruct n; [ assumption | idtac ].
 apply IHla; assumption.
Qed.

Theorem all_0_shrink_0 : ∀ la cnt k,
  (∀ n, (List.nth n la 0 = 0)%K)
  → (∀ n, (List.nth n (list_shrink_aux cnt k la) 0 = 0)%K).
Proof.
intros la cnt k H n.
revert cnt k n.
induction la as [| a]; intros; [ destruct n; reflexivity | simpl ].
destruct cnt; simpl.
 destruct n; simpl.
  pose proof (H O); assumption.

  apply IHla; clear n; intros n.
  pose proof (H (S n)); assumption.

 apply IHla; clear n; intros n.
 pose proof (H (S n)); assumption.
Qed.

Theorem cpol_degree_ge_1 : ∀ f L m,
  newton_segments f = Some L
  → pol_in_K_1_m f m
  → degree fld_zerop (Φq f L) ≥ 1.
Proof.
intros f L m HL Hm.
remember (Pos.to_nat (q_of_m m (γ L))) as q eqn:Hq .
remember (ini_pt L) as jj eqn:Hj .
destruct jj as (jq, αj); simpl.
remember HL as H; clear HeqH.
apply exists_ini_pt_nat in H.
destruct H as (j, (x, Hx)).
rewrite <- Hj in Hx; injection Hx; clear Hx; intros; subst jq x.
remember HL as Hk; clear HeqHk.
apply exists_fin_pt_nat in Hk.
destruct Hk as (k, (αk, Hk)).
symmetry in Hk.
remember HL as Hdeg; clear HeqHdeg.
eapply phi_degree_is_k_sub_j_div_q in Hdeg; try eassumption.
unfold has_degree in Hdeg.
destruct Hdeg as (Hshr, (Hdeg, Hcnz)).
remember HL as Hqkj; clear HeqHqkj.
eapply q_is_factor_of_h_minus_j with (h := k) in Hqkj; try eassumption.
 destruct Hqkj as (n, Hqkj).
 destruct n.
  simpl in Hqkj.
  exfalso.
  remember HL as H; clear HeqH.
  apply j_lt_k with (j := j) (k := k) in H.
   apply Nat.sub_gt in H; contradiction.

   rewrite <- Hj; simpl.
   rewrite nat_num_Qnat; reflexivity.

   rewrite <- Hk; simpl.
   rewrite nat_num_Qnat; reflexivity.

  rewrite Hqkj in Hdeg, Hcnz.
  rewrite Nat.div_mul in Hdeg; [ idtac | subst q; apply Pos2Nat_ne_0 ].
  rewrite Nat.div_mul in Hcnz; [ idtac | subst q; apply Pos2Nat_ne_0 ].
  unfold pseudo_degree in Hdeg.
  unfold degree.
  remember (al (Φs q f L)) as la eqn:Hla .
  unfold Φs in Hla; simpl in Hla.
  rewrite Nat.sub_diag in Hla; simpl in Hla.
  rewrite <- Hj in Hla; simpl in Hla.
  rewrite nat_num_Qnat in Hla; simpl.
  rewrite Nat.sub_diag, list_pad_0.
  rewrite <- Hj; unfold fst.
  rewrite nat_num_Qnat.
  remember (order_coeff (List.nth j (al f) 0%ps)) as v eqn:Hv .
  remember (oth_pts L ++ [fin_pt L]) as pts eqn:Hpts .
  remember (List.map (term_of_point f) pts) as tl eqn:Htl .
  subst la; simpl.
  remember (make_char_pol R (S j) tl) as cf eqn:Hcf .
  remember (degree_plus_1_of_list fld_zerop cf) as d eqn:Hd .
  symmetry in Hd.
  destruct d; [ exfalso | apply le_n_S, Nat.le_0_l ].
  subst cf.
  remember (Pos.to_nat (q_of_m m (γ L))) as nq.
  remember (make_char_pol R (S j) tl) as cf.
  pose proof (list_length_shrink_le nq [v … cf]) as Hlen.
  remember [v … cf] as vcf.
  rewrite Heqvcf in Hlen at 2.
  simpl in Hlen.
  subst vcf.
  apply degree_plus_1_is_0 in Hd.
  simpl in Hcnz.
  simpl in Hdeg.
  simpl in Hlen.
  apply le_S_n in Hlen.
  apply Hcnz.
  apply all_0_shrink_0; intros p.
  apply lap_eq_nil_nth; assumption.

 apply List.in_or_app; right; left; symmetry; eassumption.
Qed.

Theorem lap_mod_deg_1_apply : ∀ la c,
  (lap_mod_deg_1 la c = 0)%K
  → (apply_lap la c = 0)%K.
Proof.
intros la c Hmod.
destruct la as [| a]; [ reflexivity | assumption ].
Qed.

Theorem list_root_mul_power_quotient : ∀ la c r len,
  list_root_multiplicity acf c la len = r
  → (la =
     [(- c)%K; 1%K … []] ^ r * list_quotient_phi_x_sub_c_pow_r R la c r)%lap.
Proof.
intros la c r len Hmult.
revert la len Hmult.
induction r; intros; simpl.
 rewrite lap_mul_1_l; reflexivity.

 rewrite <- lap_mul_assoc.
 eapply list_root_mult_succ_if in Hmult; [ idtac | reflexivity ].
 destruct Hmult as (_, (Hz, Hmult)).
 rewrite <- IHr; [ idtac | eassumption ].
 apply root_formula.
 apply lap_mod_deg_1_apply.
 unfold ac_is_zero in Hz.
 destruct (fld_zerop (lap_mod_deg_1 la c)) as [H| H].
  rewrite H; reflexivity.

  contradiction.
Qed.

Theorem list_div_x_sub_c_ne_0 : ∀ la c r len,
  not (lap_eq la [])
  → list_root_multiplicity acf c la len = r
    → length la ≤ len
      → (apply_lap (list_quotient_phi_x_sub_c_pow_r R la c r) c ≠ 0)%K.
Proof.
intros la c r len Hla Hmult Hlen.
revert la len Hla Hmult Hlen.
induction r; intros; simpl.
 intros Happ; apply Hla; clear Hla.
 revert la Hmult Hlen Happ.
 induction len; intros.
  destruct la; [ idtac | exfalso; revert Hlen; apply Nat.nle_succ_0 ].
  reflexivity.

  destruct la as [| a]; [ reflexivity | idtac ].
  simpl in Hmult.
  unfold lap_mod_deg_1 in Hmult; simpl in Hmult.
  simpl in Hlen.
  apply le_S_n in Hlen.
  simpl in Happ.
  destruct (fld_zerop (apply_lap la c * c + a)%K).
   discriminate Hmult.

   contradiction.

 destruct len.
  destruct la; [ idtac | exfalso; revert Hlen; apply Nat.nle_succ_0 ].
  exfalso; apply Hla; reflexivity.

  simpl in Hmult.
  destruct (fld_zerop (lap_mod_deg_1 la c)) as [Hz| Hnz].
   apply eq_add_S in Hmult.
   destruct la as [| a]; [ exfalso; apply Hla; reflexivity | idtac ].
   simpl in Hlen.
   apply le_S_n in Hlen.
   eapply IHr.
    intros H; apply Hla; clear Hla.
    unfold lap_div_deg_1 in H; simpl in H.
    unfold lap_mod_deg_1 in Hz; simpl in Hz.
    remember (lap_mod_div_deg_1 R la c) as md eqn:Hmd .
    symmetry in Hmd.
    assert (apply_lap la c = 0)%K as Happ.
     apply lap_mod_deg_1_apply.
     unfold lap_mod_deg_1; simpl.
     rewrite Hmd.
     destruct md as [| d]; [ reflexivity | idtac ].
     apply lap_eq_cons_nil_inv in H.
     destruct H; assumption.

     rewrite Happ in Hz.
     rewrite rng_mul_0_l, rng_add_0_l in Hz.
     constructor; [ assumption | idtac ].
     destruct len.
      destruct la; [ idtac | exfalso; revert Hlen; apply Nat.nle_succ_0 ].
      reflexivity.

      simpl in Hmult.
      unfold lap_div_deg_1 in Hmult; simpl in Hmult.
      revert Hmd H; clear; intros.
      revert md Hmd H.
      induction la as [| a]; intros; [ reflexivity | simpl ].
      constructor.
       simpl in Hmd.
       subst md.
       apply lap_eq_cons_nil_inv in H.
       destruct H as (Happ, H).
       assert (apply_lap la c = 0)%K as Haz.
        apply lap_mod_deg_1_apply.
        unfold lap_mod_deg_1.
        remember (lap_mod_div_deg_1 R la c) as md eqn:Hmd .
        symmetry in Hmd.
        destruct md as [| m]; [ reflexivity | idtac ].
        apply lap_eq_cons_nil_inv in H.
        destruct H; assumption.

        rewrite Haz, rng_mul_0_l, rng_add_0_l in Happ.
        assumption.

       simpl in Hmd.
       subst md.
       apply lap_eq_cons_nil_inv in H.
       destruct H as (Happ, H).
       eapply IHla; [ reflexivity | eassumption ].

    eassumption.

    unfold lap_div_deg_1; simpl.
    revert Hlen; clear; intros.
    revert len Hlen.
    induction la as [| a]; intros; [ apply Nat.le_0_l | simpl ].
    destruct len; [ exfalso; revert Hlen; apply Nat.nle_succ_0 | simpl ].
    simpl in Hlen.
    apply le_S_n in Hlen.
    apply le_n_S, IHla; assumption.

   discriminate Hmult.
Qed.

(* [Walker, p. 100] « If c₁ ≠ 0 is an r-fold root, r ≥ 1, of Φ(z^q) = 0,
   we have:
      Φ(z^q) = (z - c₁)^r Ψ(z), [...] » *)
Theorem phi_zq_eq_z_sub_c₁_psi : ∀ f L c₁ r Ψ,
  r = root_multiplicity acf c₁ (Φq f L)
  → Ψ = quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r
    → (Φq f L = POL [(- c₁)%K; 1%K … []] ^ r * Ψ)%pol.
Proof.
intros f L c r Ψ Hr HΨ.
subst Ψ; simpl.
eapply list_root_mul_power_quotient.
symmetry; eassumption.
Qed.

(* [Walker, p. 100] « If c₁ ≠ 0 is an r-fold root, r ≥ 1, of Φ(z^q) = 0,
   we have:
      Φ(z^q) = (z - c₁)^r Ψ(z), Ψ(c₁) ≠ 0 » *)
Theorem psi_c₁_ne_0 : ∀ f L c₁ r Ψ,
  newton_segments f = Some L
  → r = root_multiplicity acf c₁ (Φq f L)
    → Ψ = quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r
      → (apply_poly Ψ c₁ ≠ 0)%K.
Proof.
intros f L c r Ψ HL Hr HΨ.
remember (Φq f L) as phi eqn:Hphi .
subst Ψ; simpl.
unfold apply_poly; simpl.
unfold root_multiplicity in Hr.
remember (al phi) as la eqn:Hla .
subst phi; rewrite al_Φq in Hla.
symmetry in Hr.
eapply list_div_x_sub_c_ne_0; [ idtac | eassumption | reflexivity ].
rewrite Hla; intros H.
simpl in H.
rewrite Nat.sub_diag in H; simpl in H.
apply lap_eq_cons_nil_inv in H.
destruct H as (H, _).
remember (ini_pt L) as jj eqn:Hj .
destruct jj as (jq, αj); simpl.
remember HL as HH; clear HeqHH.
apply exists_ini_pt_nat in HH.
destruct HH as (j, (x, Hx)).
rewrite <- Hj in Hx; injection Hx; clear Hx; intros; subst jq x.
simpl in H.
revert H.
eapply ord_coeff_non_zero_in_newt_segm; [ eassumption | idtac | idtac ].
 symmetry in Hj.
 left; eassumption.

 rewrite nat_num_Qnat; reflexivity.
Qed.

End theorems.


Require Export Iron.Language.Simple.Exp.

(* Typing judgement assigns a type to an expression. *)
Inductive TYPE (te: tyenv) : exp -> ty -> Prop :=
 | TYVar
   :  forall i t
   ,  get i te = Some t
   -> TYPE te (XVar i) t

 | TYLam
   :  forall x t1 t2
   ,  TYPE (te :> t1) x t2
   -> TYPE te (XLam t1 x) (TFun t1 t2)

 | TYApp
   :  forall x1 x2 t1 t2
   ,  TYPE te x1 (TFun t1 t2)
   -> TYPE te x2 t1
   -> TYPE te (XApp x1 x2) t2.

Hint Constructors TYPE.

(* Invert all hypothesis that are compound typing statements. *)
Ltac inverts_type :=
 repeat
  (match goal with
   | [ H: TYPE _ (XVar _)   _ |- _ ] => inverts H
   | [ H: TYPE _ (XLam _ _) _ |- _ ] => inverts H
   | [ H: TYPE _ (XApp _ _) _ |- _ ] => inverts H
   end).

(* Induction over structure of expression,
   inverting compound typing judgements along the way.
   This gets common cases in proofs about TYPE judgements. *)
Tactic Notation "induction_type" ident(X) :=
 induction X; norm; inverts_type; burn.

(*******************************************************************)
(* Forms of values.
   If we know the type of a value then we know the
   form of that value. *)

Lemma value_lam
 :  forall xx te t1 t2
 ,  value xx
 -> TYPE te xx (TFun t1 t2)
 -> (exists t x, xx = XLam t x).
Proof.
 destruct xx; burn.
Qed.
Hint Resolve value_lam.

(********************************************************************)
(* A well typed expression is well formed. *)
Theorem type_wfX
 :  forall te x t
 ,  TYPE te x t
 -> wfX  te x.
Proof.
 intros. gen te t.
 induction_type x.
Qed.
Hint Resolve type_wfX.

(* Weakening the type environment of a typing judgement.
   We can insert a new type into the type environment, provided we
   lift existing references to types higher in the stack across
   the new one. *)
Lemma type_tyenv_insert
 :  forall te ix x t1 t2
 ,  TYPE te x t1
 -> TYPE (insert ix t2 te) (liftX ix x) t1.
Proof.
 intros. gen ix te t1.
 induction_type x.

 Case "XVar".
  lift_cases; burn.

 Case "XLam".
  apply TYLam.
  rewrite insert_rewind; auto.
Qed.
Hint Resolve type_tyenv_insert.

Lemma type_tyenv_weaken
 :  forall te x t1 t2
 ,  TYPE  te         x          t1
 -> TYPE (te :> t2) (liftX 0 x) t1.
Proof.
 rip. rrwrite (te :> t2 = insert 0 t2 te). burn.
Qed.
Hint Resolve type_tyenv_weaken.