Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task prosa.classic.model.priority prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.global.basic.schedule.
Require Import prosa.classic.model.schedule.apa.interference prosa.classic.model.schedule.apa.affinity prosa.classic.model.schedule.apa.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module ConstrainedDeadlines.

  Import Job SporadicTaskset ScheduleOfSporadicTask SporadicTaskset
         TaskArrival Interference Priority Affinity Platform.

  Section Lemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

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

    (* Assume any job arrival sequence ... *)
    Variable arr_seq: arrival_sequence Job.

    (* ... and any schedule of this arrival sequence. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq.

    (* Assume that every task has a processor affinity alpha. *)
    Variable alpha: task_affinity sporadic_task num_cpus.

    (* Assume all jobs have valid parameters, ...*)
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* In this section we prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed.  *)
    Section NoMultipleJobs.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: JLDP_policy Job.
      Hypothesis H_work_conserving:
        apa_work_conserving job_arrival job_cost job_task arr_seq sched alpha.
      Hypothesis H_respects_JLDP_policy:
        respects_JLDP_policy_under_weak_APA job_arrival job_cost job_task arr_seq
                                            sched alpha higher_eq_priority.

      (* Consider task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j, arrives_in arr_seq j -> job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs only execute after they arrive, ... *)
      Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute job_arrival sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute job_cost sched.

      (* Assume that the schedule satisfies the sporadic task model ...*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Hypothesis H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_arrival job_cost sched j t.

      (* Assume that any previous jobs of tsk have completed by the period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall j_other tsk_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          job_arrival j_other + task_period tsk_other <= t ->
          completed job_cost sched j_other (job_arrival j_other + task_period (job_task j_other)).

      Let scheduled_task_other_than (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t && (tsk_other != tsk).

      (* Then, there can be at most one pending job of each task at time t. *)
      Lemma platform_at_most_one_pending_job_of_each_task :
        forall j1 j2,
          arrives_in arr_seq j1 ->
          arrives_in arr_seq j2 ->
          pending job_arrival job_cost sched j1 t ->
          pending job_arrival job_cost sched j2 t ->
          job_task j1 = job_task j2 ->
          j1 = j2.
      Proof.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_completed into PREV.
        intros j1 j2 ARR1 ARR2 PENDING1 PENDING2 SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF ARR1 ARR2 SAMEtsk BEFORE1).
          assert (LEt: job_arrival j1 + task_period (job_task j1) <= t).
          {
            by apply leq_trans with (n := job_arrival j2); first by done.
          }
          exploit (PREV j1 (job_task j1)); try (by done).
          intros COMP1; apply NOTCOMP1.
          by apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1)).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); try (by done); [by red; ins; subst | intro SPO'].
          assert (LEt: job_arrival j2 + task_period (job_task j2) <= t).
          {
            by apply leq_trans with (n := job_arrival j1); first by done.
          }
          exploit (PREV j2 (job_task j2)); try (by done).
          intros COMP2; apply NOTCOMP2.
          by apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2)).
        }
      Qed.

    End NoMultipleJobs.

    (* In this section we also prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed, but in the specific case
       of fixed-priority scheduling.  *)
    Section NoMultipleJobsFP.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: FP_policy sporadic_task.
      Hypothesis H_work_conserving: apa_work_conserving job_arrival job_cost job_task
                                                        arr_seq sched alpha.
      Hypothesis H_respects_JLDP_policy:
        respects_FP_policy_under_weak_APA job_arrival job_cost job_task arr_seq
                                          sched alpha higher_eq_priority.

      (* Consider any task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j, arrives_in arr_seq j -> job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs only execute after the jitter, ... *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute job_arrival sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.

      (* Assume that the schedule satisfies the sporadic task model ...*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Variable H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t <= job_arrival j + task_period tsk. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_arrival job_cost sched j t.
      Hypothesis H_t_before_period: t < job_arrival j + task_period tsk.

      (* Recall the definition of a higher-priority task in affinity (alpha' tsk). *)
      Let hp_task_in alpha' := higher_priority_task_in alpha higher_eq_priority tsk alpha'.

      (* Assume that any jobs of higher-priority tasks complete by their period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall j_other tsk_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          hp_task_in (alpha tsk) tsk_other ->
          completed job_cost sched j_other (job_arrival j_other + task_period tsk_other).

      (* Assume that any jobs of tsk prior to j complete by their period. *)
      Hypothesis H_all_previous_jobs_of_tsk_completed :
        forall j0,
          arrives_in arr_seq j0 ->
          job_task j0 = tsk ->
          job_arrival j0 < job_arrival j ->
          completed job_cost sched j0 (job_arrival j0 + task_period tsk).

      Definition scheduled_task_with_higher_eq_priority (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t &&
        hp_task_in (alpha tsk) tsk_other.

      (* Then, there can be at most one pending job of higher-priority tasks at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_interfering_tasks :
          forall j1 j2,
            arrives_in arr_seq j1 ->
            arrives_in arr_seq j2 ->
            pending job_arrival job_cost sched j1 t ->
            pending job_arrival job_cost sched j2 t ->
            job_task j1 = job_task j2 ->
            hp_task_in (alpha tsk) (job_task j1) ->
            j1 = j2.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV.
        intros j1 j2 ARR1 ARR2 PENDING1 PENDING2 SAMEtsk INTERF.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF ARR1 ARR2 SAMEtsk BEFORE1).
          assert (LEt: job_arrival j1 + task_period (job_task j1) <= t).
            by apply leq_trans with (n := job_arrival j2).
          exploit (PREV j1 (job_task j1) ARR1); [by done | by apply INTERF | intros COMP1].
          apply NOTCOMP1.
          by apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1)).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); try (by done); [by red; ins; subst j2 | intro SPO'].
          assert (LEt: job_arrival j2 + task_period (job_task j2) <= t).
            by apply leq_trans with (n := job_arrival j1).
          exploit (PREV j2 (job_task j2) ARR2);
            [by done | by rewrite -SAMEtsk | intro COMP2 ].
          apply NOTCOMP2.
          by apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2)).
        }
      Qed.

      (* Also, there can be at most one pending job of tsk at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_tsk :
        forall j',
          arrives_in arr_seq j' ->
          pending job_arrival job_cost sched j' t ->
          job_task j' = tsk ->
          j' = j.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO,
               H_valid_task into PARAMS,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk.
        intros j' ARR' PENDING' SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: BACK PENDING' => /andP [/andP [ARRIVED /negP NOTCOMP] NOTSCHED]
                               /andP [ARRIVED' /negP NOTCOMP'].
        destruct (leqP (job_arrival j') (job_arrival j)) as [BEFORE | BEFORE'].
        {
          exploit (SPO j' j DIFF ARR' H_j_arrives); [by rewrite JOBtsk | by done | intro SPO'].
          assert (LEt: job_arrival j' + task_period tsk <= t).
            by apply leq_trans with (n := job_arrival j); first by rewrite -SAMEtsk.
          apply NOTCOMP'.
          apply completion_monotonic with (t0 := job_arrival j' + task_period tsk); [by done |].
          apply PREVtsk; try (by done).
          apply leq_trans with (n := job_arrival j' + task_period tsk); last by rewrite -SAMEtsk.
          rewrite -addn1; apply leq_add; first by done.
          by unfold is_valid_sporadic_task in *; des.
        }
        {
          unfold has_arrived in *.
          rewrite leqNgt in ARRIVED'; move: ARRIVED' => /negP BUG; apply BUG.
          apply leq_trans with (n := job_arrival j + task_period tsk); first by done.
          by rewrite -JOBtsk; apply SPO; try (by done);
            [by red; ins; subst j' | by rewrite SAMEtsk | by apply ltnW].
        }
      Qed.

    End NoMultipleJobsFP.

  End Lemmas.

End ConstrainedDeadlines.


Structure Hatcsucsu : Type := make_Hatcsucsu
{
  n :> nat;

  E'' :> nat -> nat -> bool ;

  hatcsucsu : n = 6;
  undirected'' : forall (a : nat) (b : nat), (a < 6 /\ b < 6) -> implb (E'' a b) (E'' b a) = true;
  noloop'' : forall (a : nat), (a < 6) -> negb (E'' a a) = true;
}.
Require Import Bool.
Require Import Notations Logic Datatypes.
Require Decimal Hexadecimal Number.
Local Open Scope nat_scope.
Require Import Arith.
Print Arith.
Fixpoint sum_to (n:nat) : nat :=
  match n with
  | 0 => 0
  | S k => n + sum_to k
  end.
Eval compute in sum_to 6.

Definition elek1 (a:nat)(b:nat):bool:=
  match a,b with
    | 0,1 => true
    | 1,0 => true
    | 0,2 => true
    | 2,0 => true
    | 0,3 => true
    | 0,5 => true
    | 3,0 => true
    | 5,0 => true
    | _,_ => false
    end.

Definition rossz:Hatcsucsu.
  apply (make_Hatcsucsu 6 elek1).
  auto.
  compute.
  induction a;compute;auto;auto.
  induction b.
  auto.
  induction b.
  auto.
  induction b;auto.
  auto.
  induction b;auto;auto.
  induction b;auto;auto.
  induction b;auto;auto.
  induction b;auto;auto.
  induction a;auto.
  auto.
  induction a;auto.
  induction a;auto.
  induction a;auto.
  induction a;auto.
  induction a;auto.
  induction a;auto.
  induction a,b;auto;auto.
  induction a;auto;auto.
  induction a;auto;auto.
  induction a;auto;auto.
  induction a;auto;auto.
  induction a;auto.
  induction a;auto.
  induction a;auto.
  induction a;auto.
  induction a;auto.
  induction a;auto.
Defined.

Definition sajatif (b:bool)(n:nat)(k:nat):=
  match b with
  | true => n
  | false => k
  end.

Eval compute in sajatif true 1 6.

Definition nkval (G:Hatcsucsu)(n:nat)(k:nat) :=
  sajatif(E'' G n k) (1)(0).

Eval compute in nkval rossz 0 5.

Definition fokszam (G:Hatcsucsu)(a:nat):nat:=
  (nkval G a 0)+(nkval G a 1)+(nkval G a 2)+(nkval G a 3)+(nkval G a 4)+(nkval G a 5).

Eval compute in fokszam rossz 4.

Theorem egyenlo(a:bool)(b:bool): ((implb(a)(b)=true) /\ (implb(b)(a))=true)-> a=b.
  intros.
  induction a,b;auto.
  destruct H.
  discriminate.
  destruct H.
  discriminate.
Qed.

Theorem elekodavissza: forall (G1:Hatcsucsu),forall (a:nat) (b:nat), (a < 6 /\ b < 6) ->E'' G1 a b = E'' G1 b a.
  intros.
  enough (implb (E'' G1 a b) (E'' G1 b a) = true).
  enough (implb(E'' G1 b a) (E'' G1 a b) = true).
  apply (egyenlo (E'' G1 a b)(E'' G1 b a)).
  rewrite H0.
  rewrite H1.
  auto.
  rewrite undirected''.
  auto.
  destruct H.
  split.
  apply H1.
  apply H.
  rewrite undirected''.
  auto.
  apply H.
Defined.

Definition fokszamossz (G:Hatcsucsu):=
   nkval G 0 0 + (nkval G 0 1 + nkval G 1 0) + (nkval G 0 2 + nkval G 2 0) +
   (nkval G 0 3 + nkval G 3 0) + (nkval G 0 4 + nkval G 4 0) + (nkval G 0 5 + nkval G 5 0) +
    nkval G 1 1 +
   (nkval G 1 2 + nkval G 2 1) + (nkval G 1 3 + nkval G 3 1) + (nkval G 1 4 +
    nkval G 4 1) +
   (nkval G 1 5 + nkval G 5 1) + nkval G 2 2 + (nkval G 2 3 + nkval G 3 2) +
    (nkval G 2 4 +
   nkval G 4 2) + (nkval G 2 5 + nkval G 5 2) + nkval G 3 3 + (nkval G 3 4 +
    nkval G 4 3) + (nkval G 3 5 + nkval G 5 3) + nkval G 4 4 + (nkval G 4 5 + nkval G 5 4) +
    nkval G 5 5.

Eval compute in fokszamossz rossz.

Fixpoint paros n : bool :=
  match n with
    | 0 => true
    | S n' => negb(paros n')
  end.

Theorem S_1: forall n:nat, n+1=S n.
  intros.
  induction n0.
  auto.
  simpl.
  rewrite IHn0.
  auto.
Defined.
Require Import Coq.Bool.Bool.

Lemma paros_ad m n :
  paros (m + n) = negb (xorb (paros m) (paros n)).
  Proof.
  induction m.
  simpl.
  -destruct (paros n);compute;auto.
  -simpl. rewrite IHm. now destruct (paros m); destruct (paros n).
Qed.

Lemma parosszorz m n:
  paros(m*n)=paros m || paros n.
Proof.
  induction m;auto;simpl.
  rewrite paros_ad.
  rewrite IHm.
  now destruct (paros m); destruct (paros n).
Qed.

Theorem ketszervalamiazparos: forall n:nat, paros(2*n)=true.
Proof.
  intros.
  rewrite parosszorz.
  auto.
Qed.

Definition elszam (G:Hatcsucsu):=
  fokszamossz G/2.

Eval compute in elszam rossz.

Require Import Omega.

Theorem szer2_egymegegy(n:nat): n+n = 2 * n.
  induction n;auto.
  simpl.

  omega.
Qed.

Theorem nullmegval: forall n:nat, n+0=n.
  auto.
Qed.

Theorem valmegnull: forall n:nat, 0+n=n.
  auto.
Qed.

Theorem nullmegnull: 0=0+0.
  auto.
Qed.

Theorem egyrend: forall a b c:nat, a+b=c+b -> a=c.
Proof.
  intros.
  induction a,b,c;compute;auto.
  rewrite nullmegnull.
  rewrite H.
  auto with arith.
  Require Import Omega.
  omega.
  omega.
  omega.
  omega.
  omega.
Defined.

Theorem egyetatir(k:nat):forall F:Hatcsucsu,forall b:nat,(k < 6 /\ b < 6) -> E'' F k b = E'' F b k.
  intros.
  rewrite elekodavissza.
  auto.
  apply H.
Qed.

Theorem nkvalokra(a:nat): forall G:Hatcsucsu, forall b:nat, (a < 6 /\ b < 6) -> nkval G a b = nkval G b a.
  intros.
  unfold nkval.
  unfold sajatif.
  rewrite elekodavissza.
  auto.
  apply H.
Qed.

Require Import PeanoNat.

Check PeanoNat.Nat.add_assoc.

Theorem osszegbolketszer(n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15:nat):
0 + 2 * n1 + 2 * n2 + 2 * n3 + 2 * n4 + 2 * n5 +
  0 + 2 * n6 + 2 * n7 + 2 * n7 + 2 * n9 + 0 +
  2 * n10 + 2 * n11 + 2 * n12 + 2 * n13 +
  2 * n14 + 0 + 2 * n15 + 0 = 2 * (n1 + n2 + n3 + n4 + n5 + n6 + n7 + n8 + n9 +n10 + n11 + n12 + n13 + n14 + n15).
Proof.
  Require Import Lia.
  rewrite nullmegval.
  repeat rewrite nullmegval.
  rewrite valmegnull.
  simpl.
  repeat rewrite nullmegval.
  lia.
  auto.

  auto.
  lia.
  omega.

  lia.
  enough
  compute.
  rewrite szer2_egymegegy.
  omega.
  simpl.
  auto with arith.
  reflexivity.
  induction n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11, n12, n13, n14, n15.
  compute.

Theorem nk:forall G:Hatcsucsu, exists k:nat, fokszamossz G=2*k.
intros.
unfold fokszamossz.
  unfold fokszam.
  enough (nkval G 0 1 + nkval G 1 0 = 2*nkval G 0 1).
  rewrite H.
  enough (nkval G 0 2 + nkval G 2 0 = 2*nkval G 0 2).
  enough (nkval G 0 3 + nkval G 3 0 = 2*nkval G 0 3).
  enough (nkval G 0 4 + nkval G 4 0 = 2*nkval G 0 4).
  enough (nkval G 0 5 + nkval G 5 0 = 2*nkval G 0 5).
  enough (nkval G 1 2 + nkval G 2 1 = 2*nkval G 1 2).
  enough (nkval G 1 3 + nkval G 3 1 = 2*nkval G 1 3).
  enough (nkval G 1 4 + nkval G 4 1 = 2*nkval G 1 4).
  enough (nkval G 1 5 + nkval G 5 1 = 2*nkval G 1 5).
  enough (nkval G 2 3 + nkval G 3 2 = 2*nkval G 2 3).
  enough (nkval G 2 4 + nkval G 4 2 = 2*nkval G 2 4).
  enough (nkval G 2 5 + nkval G 5 2 = 2*nkval G 2 5).
  enough (nkval G 3 4 + nkval G 4 3 = 2*nkval G 3 4).
  enough (nkval G 3 5 + nkval G 5 3 = 2*nkval G 3 5).
  enough (nkval G 4 5 + nkval G 5 4 = 2*nkval G 4 5).
  rewrite H0.
  rewrite H4.
  rewrite H5.
  rewrite H6.
  rewrite H7.
  rewrite H8.
  rewrite H9.
  rewrite H10.
  rewrite H11.
  rewrite H12.
  rewrite H13.
  rewrite H1.
  rewrite H2.
  rewrite H3.
  enough (nkval G 0 0 = 0).
  rewrite H14.
  enough (nkval G 1 1 = 0).
  enough (nkval G 2 2 = 0).
  enough (nkval G 3 3 = 0).
  enough (nkval G 4 4 = 0).
  enough (nkval G 5 5 = 0).
  rewrite H15.
  rewrite H16.
  rewrite H17.
  rewrite H18.
  rewrite H19.

  apply (szer2_egymegegy (nkval G 0 1)).
  unfold paros.

Theorem fokszamosszparos: forall G:Hatcsucsu, paros(fokszamossz G)=true.
Proof.
  intros.
  unfold fokszamossz.
  unfold fokszam.
  rewrite (nkvalokra 5).
  rewrite (nkvalokra 4).
  rewrite (nkvalokra 3).
  unfold paros.

  rewrite (szer2_egymegegy (nkval G 0 1)).

Theorem fokok_ketszer:forall G:Hatcsucsu, fokszamossz G=elszam G*2.
  intros.
  unfold elszam.
  Require Import Omega.
  rewrite nkval_ugyanaz.

Theorem fokszamosszegparos:forall G:Hatcsucsu, paros (fokszamossz G)=true.
Proof.
  enough (~ exists G0:Hatcsucsu, paros (fokszamossz G0) = false).
  enough (forall G:Hatcsucsu, paros (fokszamossz G)=true).
  contradiction.
  induction (fokszamossz G).
  auto.

  contradiction.

  compute;auto.


From discprob.basic Require Import base order nify seq_ext.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad Require Import monad monad_par_hoare monad_par par_quicksort par_quicksort_correct.
From discprob.monad Require  quicksort_cost.
From discprob.monad Require Import max_triangle.
From discprob.rec Require Import rec_convert quicksort_rec.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From mathcomp Require Import path.
Require Import Reals Fourier Psatz Omega.

Definition h (l: seq nat) :=
  match l with
  | [::] => mret ([::], [::])
  | [::a] => mret ([::], [::])
  | a :: l =>
      p ← draw_pivot a l;
      spl ← dist_ret _ (partition' (sval p) (a :: l));
      mret (lower (sval spl), upper (sval spl))
  end.
Definition rsize (l: seq nat) := INR (size l).

Definition m x :=
  match (Rlt_dec x (4/3)) with
  | left _ => 0
  | _ => x * (3 / 4)
  end.

Lemma uniq_unif n:
  uniq (outcomes (unif n)).
Proof.
  rewrite /unif//=.
  rewrite map_inj_uniq.
  - apply enum_uniq.
  - intros (?&?) (?&?). inversion 1; auto.
    subst; f_equal. apply bool_irrelevance.
Qed.

Lemma uniq_unif2 n:
  uniq ([seq i.2 | i <- outcomes (unif n)]).
Proof.
  rewrite /unif//=.
  rewrite map_inj_in_uniq.
  - apply uniq_unif.
  - intros (?&?) (?&?).
    move /mapP => [? ? Heq1]. inversion Heq1; subst.
    move /mapP => [? ? Heq2]. inversion Heq2; subst.
    rewrite //=. inversion 1. repeat f_equal.
    apply val_inj => //=.
Qed.

Lemma unif_all n x (Hle: (x <= n)%nat):
  {| work := O; span := O; result := exist _ x Hle|} \in [seq i.2 | i <- outcomes (unif n)].
Proof.
  apply /mapP.
  set (a := exist _ x Hle).
  replace {| work := 0; span := 0; result := a|} with
          (1/INR (S n), {| work := 0; span :=0; result := a|}).2; last done.
  do 2 apply /mapP; eexists; eauto.
  rewrite /unif => //=.
  apply /mapP => //=.
  assert (Hlt: (x < S n)%nat) by auto.
  exists (Ordinal Hlt).
  - apply mem_enum.
  - rewrite /a; repeat f_equal. apply bool_irrelevance.
Qed.

Lemma unif_all2 n x (Hle: (x <= n)%nat):
  exist _ x Hle \in [seq (result (i.2)) | i <- outcomes (unif n)].
Proof.
  apply /mapP.
  set (a := exist _ x Hle).
  replace a with
          (result (1/INR (S n), {| work := 0; span :=0; result := a|}).2); last done.
  do 2 apply /mapP; eexists; eauto.
  rewrite /unif => //=.
  apply /mapP => //=.
  assert (Hlt: (x < S n)%nat) by auto.
  exists (Ordinal Hlt).
  - apply mem_enum.
  - rewrite /a; repeat f_equal. apply bool_irrelevance.
Qed.

Lemma unif_cost n a w s :
  {| work := w; span := s; result := a|} \in [seq i.2 | i <- outcomes (unif n)] →
  w = O ∧ s = O.
Proof.
  replace {| work := w; span := s; result := a|} with
          (1/INR (S n), {| work := w; span := s; result := a|}).2; last done.
  move /mapP => [[r' [w' s' a']] Hin].
  move: Hin. rewrite /unif//=.
  move /mapP => [[w'' s'' a''] Hin] [] => ???. subst. inversion Hin. done.
Qed.

Lemma unif_cost2 n:
  [seq {| work := O; span := O; result := result (i.2) |} | i <- unif n] =
  [seq i.2 | i <- unif n].
Proof.
  rewrite -eq_in_map.
  intros (r, a) Hin.
  edestruct (unif_cost n (result a) (work a) (span a)) as [Heq1 Heq2].
  apply /mapP. exists (r, a); destruct a; eauto.
  destruct a as [w s a] => //=. rewrite //= in Heq1 Heq2. subst.
  done.
Qed.

Lemma unif_cost3 n:
  [seq {| work := O; span := O; result := i|}
  | i <- [seq result (i.2) | i <- unif n]] = [seq i.2 | i <- unif n].
Proof.
  rewrite -map_comp -unif_cost2 => //=.
Qed.

Lemma unif_pr n a :
  a \in [seq i.2 | i <- outcomes (unif n)] →
  pr_eq (rvar_of_ldist (unif n)) a = 1 / INR (S n).
Proof.
  intros Hin. rewrite pr_rvar_ldist /unif//=.
  rewrite big_map -big_filter //=.
  destruct a as [w s (x&Hle)] => //=.
  assert (w = O ∧ s = O) as (?&?); last subst.
  { eapply unif_cost. apply Hin. }
  assert (Hlt: (x < S n)%nat) by auto.
  rewrite (bigD1_seq (Ordinal Hlt)) => //=.
  - rewrite -[a in _ = a]Rplus_0_r; f_equal.
    rewrite -big_filter -filter_predI big_filter. apply big_pred0.
    intros i => //=. apply negbTE. apply /andP => [] []. move /eqP => Heq.
    move /eqP => []. intros. subst. apply Heq.
    destruct i. f_equal. apply bool_irrelevance.
  - rewrite mem_filter. apply /andP; split; auto.
    * apply /eqP; f_equal; auto. f_equal. apply bool_irrelevance.
    * apply mem_enum.
  - apply /filter_uniq/enum_uniq.
Qed.

Lemma partition_split l pv:
  let x := partition' pv l in
  lower (sval (result x)) = [ seq n <- l | ltn n pv] ∧
  middle (sval (result x)) = [ seq n <- l | n == pv] ∧
  upper (sval (result x)) = [ seq n <- l | ltn pv n].
Proof.
      induction l as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
Qed.

Lemma Ex_max_partition_sum l:
  Ex (rvar_comp (rvar_of_ldist (h l)) (λ x, Rmax (rsize (result x).1) (rsize (result x).2))) <=
  match (size l) with
     | O => 0
     | _ => \big[Rplus/0]_(i < size l) (/INR (size l) * (Rmax (INR i) (INR (size l - i - 1))))
  end.
Proof.
  destruct l as [| a l].
  - rewrite Ex_fin_comp.
    rewrite -(big_map _ (λ x, true) (λ a, pr_eq _ a * _ (_ (fst (result a))) (_ (snd (result a))))).
    rewrite img_rvar_of_ldist//=/img/undup//= !big_cons ?big_nil.
    rewrite pr_mret_simpl //= /m/rsize//=.
    rewrite Rmax_left //; last (fourier).
    rewrite /INR. ring_simplify. fourier.
  - destruct l as [| b0 l0].
    {
      rewrite Ex_fin_comp.
      rewrite -(big_map _ (λ x, true) (λ a, pr_eq _ a * _ (_ (fst (result a))) (_ (snd (result a))))).
      rewrite img_rvar_of_ldist//=/img/undup//= !big_cons ?big_nil.
      rewrite pr_mret_simpl //= /m/rsize//=.
      rewrite Rmax_left //; last (fourier).
      replace (INR 0) with 0 by auto. ring_simplify.
      apply Rle_big0 => i _ //=.
      destruct i as (i&Hlt) => //=. assert (i = O) as -> by (nify; omega).
      replace (1 - 0 - 1)%nat with O by (nify; omega).
      replace (INR 0) with 0 by auto. rewrite Rmax_left; last fourier.
      replace (INR 1) with 1 by auto. fourier.
    }
    remember (b0 :: l0) as l eqn:Heql0.

    replace (size (a :: l)) with (S (size l)) by auto.
    rewrite -(Ex_mbind_mret (h (a :: l))).
    rewrite /h Heql0. rewrite -Heql0. clear l0 Heql0.

    rewrite ldist_assoc. rewrite ldist_assoc.
    rewrite Ex_mbind_ldist2.
    rewrite undup_id; last first.
    { apply uniq_unif2. }
    rewrite -unif_cost3 big_map.
    edestruct (quicksort_cost.perm_eq_bij O) as (f&Hfspec&Hfsize&Hinv&Hinj).
    { rewrite perm_eq_sym. apply (perm_eqlE (perm_sort leq (a :: l))). }
    eapply sum_reidx_map_le with
        (h := (λ (H : {x : nat | (x <= size l)%nat}),
               let (x, i) := H in
                (Ordinal (n:=(size l).+1) (m:=f x) (Hfsize x i)))).
    * intros (x, Hle) Hin.
      rewrite unif_pr. rewrite /Rdiv Rmult_1_l. apply Rmult_le_compat_l.
      ** left. apply Rinv_0_lt_compat. apply lt_0_INR. rewrite //=. omega.
      ** rewrite -ldist_assoc. rewrite Ex_mbind_mret.
         apply Ex_bound.
         rewrite (ldist_cost_bind_fold (λ x, spl ← dist_ret _ (partition' (sval x) (a :: l));
                                             mret (lower (sval spl), upper (sval spl)))).
         rewrite ?ldist_left_id.
         assert (Hlt: (x < size (a :: l))%nat) by auto.
         rewrite //= in Hlt.
         eapply (@cspec_mspec _ _ (λ x0 : (seq nat * seq nat),
                                      Rmax (rsize x0.1) (rsize x0.2)
                                      <= Rmax (INR (f (Ordinal (n:= S (size l)) Hle)))
                                              (INR (S (size l) - (f (Ordinal (n := S (size l)) Hle))
                                                    - 1)))).
         tbind (λ y, nth 0%nat (a :: l) x = sval y).
         { apply mspec_mret => //=. }
         intros (pv&Hin') Heq.
         tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                     middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                     upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
         { apply mspec_mret. apply partition_split. }
         remember (a :: l) as l0 eqn:Heql0.
         assert (Hsize: S (size l) = (size l0)) by (rewrite Heql0; auto).
         intros (spl&Hin'') => //=. intros (Hl&Hm&Hu).
         apply mspec_mret => //=.
         rewrite /rsize.
         rewrite !Rmax_INR. apply le_INR.
         rewrite Hl Hu.
         apply Nat.max_le_compat.
         *** rewrite //= in Heq. rewrite -Heq.
             apply /leP. rewrite Hfspec.
             specialize (perm_eqlE (perm_sort leq l0)) => Hperm.
             rewrite -(perm_eq_size (quicksort_cost.perm_filter _ _ Hperm)).
             apply quicksort_cost.lower_split_size_sorted_nth; auto.
             **** apply sort_sorted => ??. apply leq_total.
             **** rewrite (perm_eq_size (perm_eqlE (perm_sort leq l0))) /=.
                  apply Hfsize. rewrite Heql0. done.
             **** rewrite Heql0 //=.
         *** rewrite //= in Heq. rewrite -Heq.
             apply /leP. rewrite Hfspec.
             assert (Hsize': (size l).+1 = size l0) by rewrite Heql0 //.
             rewrite Hsize'.
             specialize (perm_eqlE (perm_sort leq l0)) => Hperm.
             rewrite -(perm_eq_size (perm_eqlE (perm_sort leq l0))).
             rewrite -(perm_eq_size (quicksort_cost.perm_filter _ _ Hperm)).
             apply quicksort_cost.upper_split_size_sorted_nth; auto.
             **** apply sort_sorted => ??. apply leq_total.
             **** rewrite (perm_eq_size (perm_eqlE (perm_sort leq l0))) /=.
                  apply Hfsize. rewrite Heql0. done.
             **** rewrite Heql0 //=.
      ** rewrite -unif_cost3 //. apply /mapP. eexists; eauto.
    * intros (?&?) Hin; split; auto.
      rewrite /index_enum. rewrite -enumT. rewrite mem_enum => //=.
    * intros b Hin _ Hfalse. contradiction Hfalse.
      destruct b as (m, Hle).
      destruct (Hinv m Hle) as (x'&Hle'&Heq).
      exists (exist _ x' Hle'); repeat split; auto.
      ** apply unif_all2.
      ** apply ord_inj => //=.
    * eapply map_uniq with (f := λ x, {| work := O; span := 0; result := x|}).
      rewrite unif_cost3. eapply uniq_unif2.
    * rewrite /index_enum. rewrite -enumT. apply enum_uniq.
    * intros (?&?) (?&?) _ => //=. inversion 1; subst. apply /val_inj/Hinj => //=.
Qed.

Lemma Ex_max_partition l:
  Ex (rvar_comp (rvar_of_ldist (h l)) (λ x, Rmax (rsize (result x).1) (rsize (result x).2))) <=
   m (rsize l).
Proof.
  eapply Rle_trans; [ apply Ex_max_partition_sum | apply quicksort_cost.sum_le_m ].
Qed.

Definition T := λ x, rvar_comp (rvar_of_ldist (qs x)) (λ x, INR (span x)).
  Definition a x :=
    match Rle_dec x 1 with
      | left _ => 0
      | _ =>
        match Rlt_dec x 2 with
        | left _ => (x - 1)
        | _ => 1
        end
    end.
Definition h' x := rvar_comp (rvar_of_ldist (h x)) result.

Lemma Trec:
    ∀ x r,  pr_eq (T x) r =
            \big[Rplus/0]_(x' : imgT (h' x))
                        (pr_eq (h' x) (sval x') *
                         pr_eq (rvar_comp (rvar_pair (T (fst (sval x'))) (T (snd (sval x'))))
                                         (fun xy => Rmax (fst xy) (snd xy))) (r - a (rsize x))).
Proof.
  intros ls r.
  induction ls as [| a0 ls].
  - rewrite /T. rewrite -pr_mbind_mret.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' [::]) x' *
      pr_eq (rvar_comp
               (rvar_pair
                  (rvar_comp (rvar_of_ldist (qs x'.1)) (λ x, INR (span x)))
                  (rvar_comp (rvar_of_ldist (qs x'.2)) (λ x, INR (span x))))
               (λ xy : prod_eqType R_eqType R_eqType, Rmax xy.1 xy.2)) (r - a (rsize [::]))))).
    rewrite img_rvar_comp map_comp.
    rewrite img_rvar_of_ldist /h.
    rewrite big_cons big_nil Rplus_0_r.
    rewrite /a/rsize/size.
    replace (INR 0) with 0 by auto.
    destruct (Rlt_dec); last nra.
    specialize (pr_rvar_ldist ((x ← qs [::]; mret (INR (span x))))) => -> //=.
    rewrite big_cons big_nil /=.
    rewrite /pr_eq; rewrite 2!pr_eq_alt_comp.
    destruct (Rle_dec); last nra.

    rewrite -(big_map _ (λ x, true) (λ v, if result v == _ then
                                            pr_eq _ v
                                          else
                                            0)).
    rewrite -(big_map _ (λ x, true) (λ v, if Rmax (fst v) (snd v) == r - 0 then
                                            pr_eq _ v
                                          else
                                            0)).
    rewrite (eq_big_perm _ (img_pair_rv _ _ _ _)).
    rewrite allpairs_comp.
    rewrite img_rvar_comp map_comp (map_comp span).
    specialize (img_rvar_of_ldist (qs [::])) => ->.
    specialize (img_rvar_of_ldist (h [::])) => ->.
    rewrite ?big_cons ?big_nil ?Rplus_0_r //= ?Rminus_0_r.
    rewrite Rmax_left; last reflexivity.
    case: ifP; last (intros; field).
    rewrite pr_mret_simpl //=. intros. ring_simplify. rewrite pr_eq_rvar_pair //=.
    rewrite /pr_eq pr_eq_alt_comp.
    rewrite -(big_map _ (λ x, true) (λ v, if INR (span (v)) == 0 then pr_eq _ v else 0)).
    rewrite -(big_map _ (λ x, true) (λ v, if INR (span (v)) == 0 then pr_eq _ v else 0)).
    specialize (img_rvar_of_ldist (qs [::])) => -> //=.
    rewrite ?big_cons ?big_nil //= eq_refl.
    rewrite pr_mret_simpl //=. field.
  - destruct ls as [| b0 ls0].
    { rewrite /T. rewrite -pr_mbind_mret.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' _) x' *
      pr_eq (rvar_comp
               (rvar_pair
                  (rvar_comp (rvar_of_ldist (qs x'.1)) (λ x, INR (span x)))
                  (rvar_comp (rvar_of_ldist (qs x'.2)) (λ x, INR (span x))))
               (λ xy : prod_eqType R_eqType R_eqType, Rmax xy.1 xy.2)) (r - a (rsize _))))).
    rewrite img_rvar_comp map_comp.
    rewrite img_rvar_of_ldist /h.
    rewrite big_cons big_nil Rplus_0_r.
    rewrite /a/rsize/size.
    replace (INR 1) with 1 by auto.
    destruct (Rlt_dec); last nra.
    specialize (pr_rvar_ldist ((x ← qs [:: a0]; mret (INR (span x))))) => -> //=.
    rewrite big_cons big_nil /=.
    rewrite /h'/h.
    rewrite {1}/pr_eq. rewrite 1!pr_eq_alt_comp.
    rewrite -(big_map _ (λ x, true) (λ v, if (result v) == _ then
                                            pr_eq _ v
                                          else
                                            0)).
    specialize (img_rvar_of_ldist (h [::a0])) => ->. rewrite /h.
    rewrite ?big_cons ?big_nil ?Rplus_0_r //= ?Rminus_0_r.
    rewrite pr_mret_simpl //=. ring_simplify.
    rewrite {1}/pr_eq. rewrite 1!pr_eq_alt_comp.
    destruct (Rle_dec); last nra.
    rewrite /Rminus Ropp_0 Rplus_0_r.
    rewrite -(big_map _ (λ x, true) (λ v, if Rmax (fst v) (snd v) == r then
                                            pr_eq _ v
                                          else
                                            0)).
    rewrite (eq_big_perm _ (img_pair_rv _ _ _ _)).
    rewrite allpairs_comp.
    rewrite img_rvar_comp map_comp (map_comp span).
    specialize (img_rvar_of_ldist (qs [::])) => -> //=.
    rewrite ?big_cons ?big_nil //=. replace (INR 0) with 0 by auto.
    rewrite ?Rplus_0_r.
    rewrite Rmax_left; last reflexivity.
    case: ifP; intros; last field.
    rewrite pr_eq_rvar_pair.
    f_equal.
    * rewrite /pr_eq pr_eq_alt_comp.
      rewrite -(big_map _ (λ x, true) (λ v, if INR (span (v)) == 0 then pr_eq _ v else 0)).
      specialize (img_rvar_of_ldist (qs [::])) => -> //=.
      rewrite ?big_cons ?big_nil //= eq_refl.
      rewrite pr_mret_simpl //=. field.
    * rewrite /pr_eq pr_eq_alt_comp.
      rewrite -(big_map _ (λ x, true) (λ v, if INR (span (v)) == 0 then pr_eq _ v else 0)).
      specialize (img_rvar_of_ldist (qs [::])) => -> //=.
      rewrite ?big_cons ?big_nil //= eq_refl.
      rewrite pr_mret_simpl //=. field.
    }
    remember (b0 :: ls0) as ls eqn:Heql0.
   rewrite /T.
    rewrite qs_unfold.
    transitivity
  (pr_eq (rvar_comp (rvar_of_ldist
         ('(ll, lu) ← h (a0 :: ls);
            rpar2 (qs ll) (qs lu)
            )) (λ x, INR (span x)))  r); last first.
    {
      rewrite /h'.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' _) x' *
      pr_eq (rvar_comp
               (rvar_pair
                  (rvar_comp (rvar_of_ldist (qs x'.1)) (λ x, INR (span x)))
                  (rvar_comp (rvar_of_ldist (qs x'.2)) (λ x, INR (span x))))
               (λ xy : prod_eqType R_eqType R_eqType, Rmax xy.1 xy.2)) (r - a (rsize _))))).

    rewrite img_rvar_comp map_comp.
    rewrite img_rvar_of_ldist.
    rewrite (cost_bind_const (3 * (size (a0 :: ls)))%nat (S O)).
      * rewrite -undup_map. rewrite -map_comp.
        eapply eq_bigr. intros (ll&lu) _.
        f_equal.
        specialize (ldist_cost_rpair_span (qs ll) (qs lu)
                                    (λ x, INR (x + 1))) => ->.
        rewrite !rvar_pair_comp !rvar_comp_comp.
          rewrite {1}/pr_eq {1}[a in _ = a]/pr_eq.
          rewrite ?pr_eq_alt_comp /=. eapply eq_bigr => x ?.
          apply if_case_match. rewrite ?plus_INR ?Rmax_INR /rsize//=/a//=.
          rewrite Heql0 //=. specialize (S_INR (size ls0)) => /= => ->.
          destruct (Rlt_dec).
          {specialize (pos_INR (size ls0)). intros. nra. }
          destruct (Rle_dec); first nra.
          apply /eqP; apply /eqP. case: ifP; first by (move /eqP => ->; nra).
          move /eqP. intros. nra.
      * intros d'. rewrite map_comp. move /mapP. intros [? Hin Heq]. rewrite Heq.
        cut (cspec (h (a0 :: ls )) (λ x, work x = 3 * size (a0 :: ls)))%nat; first by auto.
        rewrite /h. rewrite Heql0. rewrite -Heql0.
        cbind (λ x, work x = O).
        {
          rewrite /draw_pivot.
          cbind (λ x, work x = O).
          { rewrite /cspec/coutput. destruct y as [w s a].
            rewrite /work. eapply unif_cost; auto. }
          intros ? => /= ->.
          apply cspec_mret => //=.
        }
        intros pv ->.
        cbind (λ x, work x = 3 * size (a0 :: ls))%nat.
        {
         eapply cspec_dist_ret.
         clear. rewrite /result. destruct pv as [w0 s0 (pv&?)]. rewrite /sval.
         apply (partition_work (a0 :: ls) pv).
        }
        intros ? ->.
        apply cspec_mret => //=. nify. omega.
      (* Should re-work the lemma, because much of this is tedious and the same,
         it's just the final application of work/span of partition calculation *)
      * intros d'. rewrite map_comp. move /mapP. intros [? Hin Heq]. rewrite Heq.
        cut (cspec (h (a0 :: ls )) (λ x, span x = 1))%nat; first by auto.
        rewrite /h. rewrite Heql0. rewrite -Heql0.
        cbind (λ x, span x = O).
        {
          rewrite /draw_pivot.
          cbind (λ x, span x = O).
          { rewrite /cspec/coutput. destruct y as [w s a].
            rewrite /work. eapply unif_cost; auto. }
          intros ? => /= ->.
          apply cspec_mret => //=.
        }
        intros pv ->.
        cbind (λ x, span x = 1)%nat.
        {
         eapply cspec_dist_ret.
         clear. rewrite /result. destruct pv as [w0 s0 (pv&?)]. rewrite /sval.
         apply (partition_span a0 ls pv).
        }
        intros ? ->.
        apply cspec_mret => //=.
    }
    (* TODO TODO: a good deal of this could be automated *)
    rewrite Heql0.
    rewrite /h.
    rewrite -?pr_mbind_mret.
    f_equal.
    apply outcomes_eq_dist.
    rewrite ?ldist_assoc.
    f_equal; eapply ldist_bind_ext.
    intros ?.
    eapply ldist_bind_ext.
    intros ?.
    rewrite ?ldist_assoc.
    eapply ldist_bind_ext.
    intros ?.
    rewrite ?ldist_assoc.
    rewrite ?ldist_left_id ?ldist_right_id.
    rewrite ?ldist_assoc.
    eapply ldist_bind_ext.
    intros ?.
    rewrite ?ldist_assoc.
    eapply ldist_bind_ext.
    intros ?.
    rewrite ?ldist_left_id ?ldist_right_id.
    f_equal => //=. f_equal. nify. omega.
Qed.

Definition k := -/ ln(3/4).

Theorem bound x w:
    rsize x > 1 →
    pr_gt (T x) ((k * ln (rsize x) + 1) + INR w)
       ≤ (rsize x) * (3/4)^w.
Proof.
  specialize (quicksort_rec.recurrence_span2.qs_span_bound _ _ _ _ T h' (λ x, true)).
  rewrite /size/rsize => Hrec. eapply Hrec; clear; try done.
  - intros l ?. rewrite //=.
    rewrite /quicksort_rec.recurrence_span2.size //=.
    cut (∀ n, INR (length (fst (result (rvar_of_ldist (h l) n)))) +
              INR (length (snd (result (rvar_of_ldist (h l) n)))) <=
                   INR (length l)); first by rewrite //=.
    intros n'. apply fun_to_cspec.
    rewrite /h.
    destruct l as [| a l].
    { apply cspec_mret => //=. replace (INR 0) with 0 by auto. nra. }
    destruct l as [| b l0].
    { apply cspec_mret => //=. replace (INR 0) with 0 by auto. replace (INR 1) with 1 by auto. nra. }
    remember (b::l0) as l eqn:Heql0.
    clear b l0 Heql0.
    eapply (cspec_mspec _ (λ x, INR (length (fst x)) + INR (length (snd x)) <= INR (length _))).
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin') => //= ?. apply mspec_mret.
    move /andP in Hin'.
    destruct Hin' as (pf1&pf2); move /implyP in pf2.
    replace (length l0) with (size l0) by auto.
    rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE //.
    assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
    rewrite -plus_INR. apply le_INR. rewrite //=.
    assert (length (lower spl) = size (lower spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    assert (length (upper spl) = size (upper spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    clear -Hlt. rewrite //=. omega.
  - rewrite /quicksort_rec.recurrence_span2.size //=.
    intros l ? Hgt. rewrite //=.
    cut (∀ n, INR (length (fst (result (rvar_of_ldist (h l) n)))) +
              INR (length (snd (result (rvar_of_ldist (h l) n)))) <=
                   INR (length l) - 1); first by rewrite //=.
    intros n'. apply fun_to_cspec.
    rewrite /h.
    destruct l as [| a l].
    { move : Hgt. rewrite //=. replace (INR 0) with 0 by auto. nra. }
    destruct l as [| b l0].
    { move : Hgt. rewrite //=. replace (INR 1) with 1 by auto. nra. }
    remember (b::l0) as l eqn:Heql0.
    clear b l0 Heql0.
    eapply (cspec_mspec _ (λ x, INR (length (fst x)) + INR (length (snd x)) <= INR (length _) - 1)).
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin') => //= ?. apply mspec_mret.
    move /andP in Hin'.
    destruct Hin' as (pf1&pf2); move /implyP in pf2.
    replace (length l0) with (size l0) by auto.
    rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE //.
    assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
    rewrite ?plus_INR.
    assert (length (lower spl) = size (lower spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    assert (length (upper spl) = size (upper spl)) as Heq by auto.
    rewrite Heq. clear Heq.
    specialize (pos_INR (size (lower (spl)))).
    specialize (pos_INR (size (upper (spl)))).
    rewrite //=. intros.
    assert (Hge1: 1 <= INR (size (middle spl))).
    { replace 1 with (INR 1) by auto. apply le_INR. omega. }
    rewrite //= in Hge1. nra.
  - rewrite /quicksort_rec.recurrence_span2.size/quicksort_rec.recurrence_span2.rec_solution.d //=.
    intros x n Hle.
    replace 1 with (INR 1) in Hle by auto. apply INR_le in Hle.
    cut (INR (span (rvar_of_ldist (qs x) n)) = 0); first by rewrite //=.
    apply fun_to_cspec.
    destruct x; [| destruct x].
    * rewrite qs_unfold.
      apply cspec_mret => //=.
    * rewrite qs_unfold.
      apply cspec_mret => //=.
    * rewrite //= in Hle. omega.
  - intros. eapply (rec_pr_rec_gt _ rsize _ _ _ _ T h' (λ x, true) (λ xy, Rmax (fst xy) (snd xy)));
              auto; intros; apply Trec.
  - intros x.
    rewrite /quicksort_rec.recurrence_span2.size/quicksort_rec.recurrence_span2.rec_solution.d
            /quicksort_rec.recurrence_span2.rec_solution.m
            /quicksort_rec.recurrence_span2.qs_factor.alpha.
    etransitivity; first eapply Ex_max_partition.
    rewrite /m/rsize/size/length. do 2 destruct Rlt_dec; try nra.
Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.global.schedulability.
Require Import prosa.classic.model.schedule.global.basic.schedule prosa.classic.model.schedule.global.basic.platform.
Require Import prosa.classic.analysis.global.basic.workload_bound
               prosa.classic.analysis.global.basic.interference_bound_fp
               prosa.classic.analysis.global.basic.bertogna_fp_comp.
Require Import prosa.classic.implementation.job prosa.classic.implementation.task
               prosa.classic.implementation.arrival_sequence.
Require Import prosa.classic.implementation.global.basic.schedule.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq bigop div.

Module ResponseTimeAnalysisFP.

  Import Job Schedule SporadicTaskset Priority Schedulability Platform InterferenceBoundFP WorkloadBound ResponseTimeIterationFP.
  Import ConcreteJob ConcreteTask ConcreteArrivalSequence ConcreteScheduler.

  (* In this section, we instantiate a simple example to show that the theorems
     contain no contradictory assumptions. *)
  Section ExampleRTA.

    Let tsk1 := {| task_id := 1; task_cost := 2; task_period := 5; task_deadline := 3|}.
    Let tsk2 := {| task_id := 2; task_cost := 4; task_period := 6; task_deadline := 5|}.
    Let tsk3 := {| task_id := 3; task_cost := 3; task_period := 12; task_deadline := 11|}.

    (* Let ts be a task set containing these three tasks (sorted by rate-monotonic priority). *)
    Program Let ts := Build_set [:: tsk1; tsk2; tsk3] _.

    Section FactsAboutTaskset.

      Fact ts_has_valid_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline ts.
      Proof.
        intros tsk IN.
        repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
      Qed.

      Fact ts_has_constrained_deadlines:
        forall tsk,
          tsk \in ts ->
          task_deadline tsk <= task_period tsk.
      Proof.
        intros tsk IN.
        repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
      Qed.

    End FactsAboutTaskset.

    (* Assume there are two processors. *)
    Let num_cpus := 2.

    (* Recall the FP RTA schedulability test. *)
    Let schedulability_test :=
      fp_schedulable task_cost task_period task_deadline num_cpus.

    (* Now we show that the schedulability test returns true. *)
    Fact schedulability_test_succeeds :
      schedulability_test ts = true.
    Proof.
      unfold schedulability_test, fp_schedulable, fp_claimed_bounds; simpl.
      unfold total_interference_bound_fp, div_floor.
      rewrite big_nil div0n addn0 /=.
      unfold div_floor; simpl.
      set I2 := total_interference_bound_fp task_cost task_period tsk2
                                            [:: (tsk1, 2)].
      assert (H1: I2 4 = 1).
      {
        by unfold I2, total_interference_bound_fp; rewrite big_cons big_nil; compute.
      }
      rewrite H1.
      have H2: 4 + 1 %/ num_cpus = 4 by compute.
      rewrite H2 H1 H2.
      have H3: 3 < 5 by compute.
      rewrite H3.
      unfold fp_bound_of_task.
      have H4: per_task_rta task_cost task_period num_cpus tsk3 [:: (tsk1, 2); (tsk2, 4)]
                            (max_steps task_cost task_deadline tsk3) = 5.
      {
        unfold per_task_rta; simpl.
        unfold total_interference_bound_fp at 9.
        rewrite !big_cons big_nil /=.
        unfold total_interference_bound_fp at 8.
        rewrite !big_cons big_nil /=.
        unfold total_interference_bound_fp at 7.
        rewrite !big_cons big_nil /=.
        unfold total_interference_bound_fp at 6.
        rewrite !big_cons big_nil /=.
        unfold total_interference_bound_fp at 5.
        rewrite !big_cons big_nil /=.
        unfold total_interference_bound_fp at 4.
        rewrite !big_cons big_nil /=.
        unfold total_interference_bound_fp at 3.
        rewrite !big_cons big_nil /=.
        unfold total_interference_bound_fp at 2.
        rewrite !big_cons big_nil /=.
        unfold total_interference_bound_fp at 1.
        by rewrite !big_cons big_nil /=; compute.
      }
      by rewrite H4.
    Qed.

    (* Let arr_seq be the periodic arrival sequence from ts. *)
    Let arr_seq := periodic_arrival_sequence ts.

    (* Assume rate-monotonic priorities. *)
    Let higher_priority := FP_to_JLDP job_task (RM task_period).

    Section FactsAboutPriorityOrder.

      Lemma ts_has_unique_priorities :
        FP_is_antisymmetric_over_task_set (RM task_period) ts.
      Proof.
        unfold RM; intros tsk tsk' IN IN' HP HP'.
        have EQ: task_period tsk = task_period tsk' by apply/eqP; rewrite eqn_leq HP HP'.
        clear HP HP'.
        rewrite !in_cons 2!in_nil 2!orbF in IN IN'; des; rewrite IN IN'; try (by done);
        subst tsk tsk'; simpl in *; by done.
      Qed.

      Lemma priority_is_total :
        FP_is_total_over_task_set (RM task_period) ts.
      Proof.
        unfold RM; intros tsk tsk' IN IN'.
        destruct (leqP (task_period tsk) (task_period tsk'));
          [by left | by right; apply ltnW].
      Qed.

    End FactsAboutPriorityOrder.

    (* Let sched be the work-conserving RM scheduler. *)
    Let sched := scheduler job_arrival job_cost num_cpus arr_seq higher_priority.

    (* Recall the definition of deadline miss. *)
    Let no_deadline_missed_by :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.

    (* Next, we prove that ts is schedulable with the result of the test. *)
    Corollary ts_is_schedulable:
      forall tsk,
        tsk \in ts ->
        no_deadline_missed_by tsk.
    Proof.
      intros tsk IN.
      have VALID := periodic_arrivals_valid_job_parameters ts ts_has_valid_parameters.
      have TSVALID := ts_has_valid_parameters.
      unfold valid_sporadic_job, valid_realtime_job in *; des.
      apply taskset_schedulable_by_fp_rta with (task_cost := task_cost)
       (task_period := task_period) (task_deadline := task_deadline)
       (ts0 := ts) (higher_priority0 := RM task_period); try (by done).
      - by apply ts_has_constrained_deadlines.
      - by apply ts_has_unique_priorities.
      - by apply priority_is_total.
      - by apply RM_is_transitive.
      - by apply periodic_arrivals_all_jobs_from_taskset.
      - by apply periodic_arrivals_are_sporadic.
      - by apply scheduler_jobs_come_from_arrival_sequence.
      - by apply scheduler_jobs_must_arrive_to_execute.
      - apply scheduler_completed_jobs_dont_execute.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
      - apply scheduler_sequential_jobs.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
      - by apply scheduler_work_conserving, periodic_arrivals_are_consistent.
      - apply scheduler_respects_policy.
        -- by apply periodic_arrivals_are_consistent.
        -- by intros t; apply RM_is_transitive.
        -- by intros t x y; apply leq_total.
      - by apply schedulability_test_succeeds.
    Qed.

  End ExampleRTA.

End ResponseTimeAnalysisFP.


Require Import Rel.Definitions.
Require Import Rel.BasicFacts.
Require Import Util.Subset.
Require Import Lang.Static.
Require Import Lang.StaticFacts.
Set Implicit Arguments.

Section section_compat_tm_app.

Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (Γ : V → ty EV HV ∅).
Context (P : HV → F).
Context (T : ty EV HV ∅).
Context (𝓔 : eff EV HV ∅).
Context (v₁ v₂ : val EV HV V ∅).

Hint Resolve subset_trans subset_refl.

Lemma compat_tm_val n :
n ⊨ ⟦ Ξ P Γ ⊢ v₁ ≼ˡᵒᵍᵥ v₂ : T ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ v₁ ≼ˡᵒᵍ v₂ : T # 𝓔 ⟧.
Proof.
intro Ht.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂ ;
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hρ ; iintro Hγ.
simpl.
apply 𝓥_in_𝓣.

iespecialize Ht.
repeat (ispecialize Ht ; [ eassumption | ]).
exact Ht.
Qed.

End section_compat_tm_app.


(* Set Implicit Arguments. *)

(* Require Import Coq.Program.Basics. *)
(* Require Import Coq.QArith.QArith. *)

(* Require Import order. *)
(* Require Import set. *)
(* Open Scope program_scope. *)
(* Open Scope set_scope. *)

(* Class MeasurableSpace (A : Type) (sigma : pow A) : Prop := *)
(*   { sigma_A : @full A ∈ sigma *)
(*   ; sigma_complement : forall U, U ∈ sigma -> ! U ∈ sigma *)
(*   ; sigma_union : forall seq : sequence (set A), *)
(*       (forall i, seq i ∈ sigma) -> *)
(*       countable_union seq ∈ sigma *)
(*   }. *)

(* Lemma sigma_empty (A : Type) `{meas : MeasurableSpace A} : *)
(*   ∅ A ∈ sigma. *)
(* Proof. *)
(*   destruct meas as [sigma_A sigma_comp ?]. *)
(*   rewrite <- complement_full_empty; firstorder. *)
(* Qed. *)

(* Lemma sigma_intersection (A : Type) *)
(*       `{meas : MeasurableSpace A} (seq : sequence (set A)) : *)
(*   (forall i, seq i ∈ sigma) -> *)
(*   countable_intersection seq ∈ sigma. *)
(* Admitted. *)

(* Class MeasureSpace (A : Type) `{MeasurableSpace A} (mu : set A -> Q) : Prop := *)
(*   { mu_empty : mu (∅ A) == 0 *)
(*     ; mu_add : forall seq : sequence (set A), *)
(*         (forall i j, i <> j -> disjoint (seq i) (seq j)) -> *)
(*         supremum (mu (countable_union seq)) (mu ∘ seq) *)
(*   }. *)

(* Definition is_measurable {A : Type} `{MeasurableSpace A} (U : set A) := U ∈ sigma. *)

(* Definition is_measurable_fun {A B : Type} *)
(*            `{MeasurableSpace A} `{MeasurableSpace B} (f : A -> B) := *)
(*   forall V, is_measurable V -> is_measurable (preimage f V). *)

(* (** Lifting a sigma-algebra to the option type. *) *)
(* Definition option_sigma {A : Type} (sigma : pow A) (U : option A -> Prop) : Prop := *)
(*   (fun x => Some x ∈ U) ∈ sigma. *)

(* Program Instance OptionMeasurableSpace {A : Type} `{MeasurableSpace A} *)
(*   : MeasurableSpace (option_sigma sigma). *)
(* Solve Obligations with firstorder. *)
(* Next Obligation. destruct H as [? ? Hunion]; apply Hunion, H0. Qed. *)

(* Definition discrete_sigma {A : Type} : pow A := const True. *)

(* Program Instance DiscreteMeasurableSpace {A : Type} *)
(*   : MeasurableSpace (@discrete_sigma A). *)
(* Solve Obligations with firstorder. *)

(* Definition partial_fun (A B : Type) : Type := A -> option B. *)


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.theory.rationals
               HoTT.Classes.theory.premetric
               HoTT.Classes.orders.orders
               HoTT.Classes.orders.semirings
               HoTT.Classes.implementations.assume_rationals
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe
               TruncType Types.Sigma
               HIT.quotient.

Require Import HoTTClasses.sierpinsky partiality dedekind.

Require Export Rlow Opens Functions D_op.

(** * OpenFun : operator which take an open and return
the characteristic function of this open *)

(** such a construction is possible because of the way
we have defined the lower reals as maps from Q to Sier.
We define the OpenFun by induction on the Sierpinski sets
*)

Section S_to_RlP.

(** Map from Sier to RlowPos *)
Definition S_to_RlP : forall s : Sier, RlowPos.
Proof.
apply (partial_rec Unit _ le).
simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _ _);simpl.
+ intros _. exact RlP_1.
+ exact RlP_0.
+ intros f Hn.
  exact (RllubPos f).
+ reflexivity.
+ intros x.
  apply RlowPos_pos.
+ intros s Hp x Hi n.
  assert (Rlle (s n) ((fun (f0 : nat -> RlowPos)
       (_ : forall n : nat, Rlle (f0 n) (f0 (S n))) =>
       RllubPos f0) s Hp)).
  simpl.
  apply RllubPos_lub.
  unfold Rlle in *; red in Hi; auto.
  red; unfold Rllepos, Rlle in *.
  auto.
+ intros s Hi x Hn q Hh.
  assert (Hx : (elt (Rllub s) q)).
  trivial.
  assert (H2 : Rlle (RllubPos s) x).
  apply RllubPos_le. trivial.
  apply Rlow_mon with (Rllub s) q.
  reflexivity.
  trivial.
  trivial.
Defined.

(** Monotonicity of the map from Sier to RlowPos *)
Lemma S_to_RlP_mon : forall s1 s2, SierLe s1 s2
                        -> Rlle (S_to_RlP s1) (S_to_RlP s2).
Proof.
apply (partialLe_ind0 _ _).
+ unfold Rlle; auto.
+ assert (X : S_to_RlP (bot Unit) = RlP_0).
  auto; rewrite X.
  intros. apply RlowPos_pos.
+ intros f x H1 H2 n.
  assert (H : Rlle (S_to_RlP (f n)) (S_to_RlP (sup Unit f))).
  assert (Hr : S_to_RlP (sup Unit f) = RllubPos
                        (fun n => S_to_RlP (f n))).
  auto. rewrite Hr.
  apply (Rllub_lub (fun n => S_to_RlP (f n))); trivial.
  unfold Rlle in *; auto.
+ intros f x H1 H2.
  assert (Hr : S_to_RlP (sup Unit f) = RllubPos
                        (fun n => S_to_RlP (f n))).
  auto. rewrite Hr.
  apply Rllub_le.
  intros n;
  apply H2.
Qed.

(** S_to_RlP preserves meets *)
Lemma meet_pres_S_to_RlP :
          MeetPreserving (fun (s: Sier) => S_to_RlP s).
Proof.
intros x y;
unfold sg_op, meet_is_sg_op, S_to_RlP.
revert x.
apply (partial_ind0 _ (fun a => _)).
+ intros x.
  assert (H1 : SierMeet (eta Unit x) y = y).
  generalize (SierMeet_top y).
  intros Hst;
  destruct x;
  fold SierTop;
  unfold meet in Hst; trivial.
  rewrite H1.
  assert (H2 : forall x:RlowPos, Rlle x RlP_1 ->
                    RlPMeet RlP_1 x = x).
  intros rr Hrr.
  apply (antisymmetry le).
  - intros s Hs.
    simpl in Hs.
    destruct (dec (s < 1)%mc).
    unfold meet in Hs.
    apply top_le_meet in Hs.
    apply (snd Hs).
    apply top_le_meet in Hs.
    apply (snd Hs).
  - intros s Hs.
    simpl.
    apply top_le_meet.
    split.
    unfold semi_decide, Rllt_semi_dec, decidable_semi_decide.
    destruct (dec (s < Qone)%mc).
    apply top_greatest.
    case n.
    red in Hrr;
    unfold Rlle in Hrr.
    specialize (Hrr s Hs).
    simpl in Hrr.
    unfold semi_decide, Rllt_semi_dec, decidable_semi_decide in *.
    destruct (dec (s < Qone)).
    case (n l).
    apply not_bot in Hrr;
    case Hrr.
    trivial.
  - rewrite H2.
    reflexivity.
    assert (H : Rlle (S_to_RlP SierTop) RlP_1).
    unfold Rlle; auto.
    unfold Rlle in *; intros q Hq.
    apply H.
    revert Hq.
    apply S_to_RlP_mon.
    apply top_greatest.
+ assert (HsB : SierMeet (bot Unit) y  = bot Unit).
  apply (antisymmetry le).
  - apply imply_le.
    intros Hz; apply top_le_meet in Hz.
    apply (fst Hz).
  - apply imply_le.
    intros Hz;
    apply not_bot in Hz;
    case Hz.
  - assert (HrB : forall r, RlPMeet RlP_0 r = RlP_0).
    intros r.
    apply (antisymmetry le).
    -- intros s Hs.
       simpl in Hs.
       apply top_le_meet in Hs.
       unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qzero)).
       destruct Hs as (_,Hs).
       simpl.
       unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qzero)).
       apply top_greatest.
       case (n l).
       destruct Hs as (Hs,_).
       apply not_bot in Hs; case Hs.
    -- intros s Hs; simpl in Hs.
       destruct (RlPMeet RlP_0 r) as (rr,Hprr); simpl.
       unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qzero)).
       apply Hprr; trivial.
       apply not_bot in Hs; case Hs.
    -- rewrite HsB.
       transitivity RlP_0.
       reflexivity.
       rewrite HrB.
       reflexivity.
+ intros f Hn.
  apply (antisymmetry le).
  - intros q Hn'.
    assert (H2 : SierMeet (sup Unit f) y =
                 sup _ (SierMeet_seq_l f y)).
    apply SierMeet_sup.
    rewrite H2 in Hn'.
    assert (Hn'2 : elt (Rllub
                  (fun n => S_to_RlP ((SierMeet_seq_l f y) n))) q).
    trivial.
    clear Hn'.
    apply top_le_enumerable_sup in Hn'2.
    revert Hn'2; apply (Trunc_ind _).
    intros (n,Hn'2).
    specialize (Hn n).
    simpl in Hn'2.
    assert (H3 : elt (rl (S_to_RlP y)) q).
    revert Hn'2.
    apply Rlow_mon.
    reflexivity.
    apply S_to_RlP_mon.
    apply SierMeet_is_meet.
    trivial.
    assert (Ho : elt
                     (RlMeet (RllubPos (fun n => S_to_RlP (f n)))
                              (S_to_RlP y)) q).
    unfold RlPMeet.
    simpl.
    apply top_le_meet.
    split.
    -- apply top_le_enumerable_sup.
       apply tr.
       unfold semi_decide.
       exists n.
       revert Hn'2.
       apply Rlow_mon.
       reflexivity.
       apply S_to_RlP_mon.
       apply SierMeet_is_meet.
    -- apply H3.
    -- trivial.
  - intros q Hn'.
    unfold RlPMeet in Hn'.
    apply top_le_meet in Hn'.
    destruct Hn' as (Hna,Hnb).
    assert (Hna2 : elt (Rllub
                   (fun n => S_to_RlP (f n))) q).
    trivial. clear Hna.
    apply top_le_enumerable_sup in Hna2.
    revert Hna2; apply (Trunc_ind _).
    intros (m,Hm).
    assert (H2 : SierMeet (sup Unit f) y =
                 sup _ (SierMeet_seq_l f y)).
    apply SierMeet_sup.
    rewrite H2.
    assert (H3 : elt (Rllub
                 (fun n => S_to_RlP ((SierMeet_seq_l f y) n))) q).
    apply top_le_enumerable_sup.
    apply tr.
    exists m.
    simpl; specialize (Hn m).
    unfold S_to_RlP.
    rewrite Hn.
    unfold RlPMeet.
    simpl.
    apply top_le_meet.
    split; trivial.
    trivial.
Qed.

(** S_to_RlP preserves joins *)
Lemma join_pres_S_to_RlP :
          JoinPreserving (fun (s: Sier) => S_to_RlP s).
Proof.
intros x y;
unfold sg_op, join_is_sg_op, S_to_RlP.
revert x.
apply (partial_ind0 _ (fun a => _)).
+ intros x.
  assert (H1 : SierJoin (eta Unit x) y = eta Unit x).
  generalize (SierJoin_top y).
  intros Hst;
  destruct x;
  trivial.
  rewrite H1.
  assert (H2 : forall x:RlowPos, Rlle x RlP_1 ->
                    RlPJoin RlP_1 x = RlP_1).
  intros rr Hrr.
  apply (antisymmetry le).
  - intros s Hs.
    simpl in Hs.
    unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
    destruct (dec (s < Qone)).
    apply top_le_join in Hs.
    revert Hs; (apply (Trunc_ind _)).
    intros Hs.
    destruct Hs;
    simpl; unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
    destruct (dec (s < Qone)); try trivial.
    case (n l).
    destruct (dec (s < Qone)); try trivial.
    apply top_greatest.
    case (n l).
    apply top_le_join in Hs.
    unfold hor in Hs.
    revert Hs; (apply (Trunc_ind _)).
    intros []. intros i.
    -- apply not_bot in i; case i.
    -- simpl; intros i.
       unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qone)); try trivial.
       apply top_greatest.
       red in Hrr.
       apply Hrr in i.
       simpl in i; unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qone)); try trivial.
       case (n0 l).

  - intros s Hs.
    apply top_le_join.
    apply tr.
    simpl in Hs; simpl.
    unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
    destruct (dec (s < Qone)).
    left; trivial.
    left; trivial.
  - simpl.
    rewrite H2.
    reflexivity.
    clear H1.
    revert y.
    assert (H3 : forall y, Rlle (S_to_RlP y)
                        (S_to_RlP (eta Unit tt))).
    intros y; apply S_to_RlP_mon.
    apply top_greatest.
    trivial.
+ assert (HsB : SierJoin (bot Unit) y  = y).
  reflexivity.
  assert (HrB : forall r, RlPJoin RlP_0 r = r).
  intros r.
  apply (antisymmetry le).
  -- intros s Hs.
     unfold RlPJoin in Hs; simpl in Hs.
     apply top_le_join in Hs.
     unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
     destruct (dec (s < Qzero)).
     * apply rlpos; trivial.
     * revert Hs; apply (Trunc_ind _).
       intros Hs.
       case Hs; intros Ho.
       ** apply not_bot in Ho; case Ho.
       ** trivial.
  -- intros s Hs;
     simpl in Hs.
     simpl.
     unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
     destruct (dec (s < Qzero)).
     apply top_le_join.
     unfold hor; apply tr.
     left; apply top_greatest.
     apply top_le_join.
     unfold hor; apply tr.
     right; trivial.
  -- rewrite HrB, HsB.
     reflexivity.
+ intros f Hn.
  apply (antisymmetry le).
  - intros q Hn'.
    assert (H2 : SierJoin (sup Unit f) y =
                 sup _ (SierJoin_seq_l f y)).
    rewrite <- SierJoin_sup.
    reflexivity.
    rewrite H2 in Hn'.
    assert (Hn'2 : elt (Rllub
         (fun n => S_to_RlP ((SierJoin_seq_l f y) n))) q).
    trivial.
    clear Hn'.
    apply top_le_enumerable_sup in Hn'2.
    revert Hn'2; apply (Trunc_ind _).
    intros (n,Hn'2).
    specialize (Hn n).
    simpl in Hn'2.
    unfold join in Hn'2.
    apply top_le_join.
    assert (Hn'3 : elt (rl (RlPJoin
                 (S_to_RlP (f n)) (S_to_RlP y))) q).
    rewrite <- Hn;
    trivial.
    simpl in Hn'3.
    apply top_le_join in Hn'3.
    revert Hn'3;
    apply (Trunc_ind _);
    intros Hn'3.
    apply tr.
    case Hn'3; intros Hh.
    -- left.
       assert (H1 : elt (Rllub
                               (fun n => S_to_RlP (f n))) q).
       apply top_le_enumerable_sup.
       apply tr; exists n; trivial.
       trivial.
    -- right;
       trivial.
  - intros q Hn'.
    unfold RlPJoin in Hn'.
    apply top_le_join in Hn'.
    revert Hn';
    apply (Trunc_ind _);
    intros Hn'.
    assert (H2 : SierJoin (sup Unit f) y =
                     sup _ (SierJoin_seq_l f y)).
    rewrite <- SierJoin_sup.
    reflexivity.
    rewrite H2.
    assert (H3 : elt (Rllub
                     (fun n => S_to_RlP
                     ((SierJoin_seq_l f y) n))) q).
    apply top_le_enumerable_sup.
    case Hn'; intros H;
    unfold semi_decide, semi_decide_sier in H.
    -- assert (H' : elt (Rllub (fun n => S_to_RlP
                                   (f n))) q).
       trivial. clear H.
       apply top_le_enumerable_sup in H'.
       revert H'; apply (Trunc_ind _).
       intros (n,H').
       apply tr.
       exists n.
       simpl.
       revert H'.
       apply Rlow_mon.
       reflexivity.
       apply S_to_RlP_mon,
             SierJoin_is_join.
    -- apply tr.
       exists O.
       simpl.
       revert H.
       apply Rlow_mon.
       reflexivity.
       apply S_to_RlP_mon,
             SierJoin_is_join.
    -- trivial.
Qed.

Coercion S_to_RlP : Sier >-> RlowPos.

End S_to_RlP.

Section OpenFun.

(** Map from Opens to characteristic function *)
Definition OpenFun {A : hSet} : forall (U : A -> Sier),
                                       (A -> RlowPos).
Proof.
intros s z.
exact (let sz := s z in (S_to_RlP sz)).
Defined.

(** OpenFun is definite *)
Lemma OpenFun_def {A} : forall U:OS A, U = OS_empty
                               -> OpenFun U = fun x => RlP_0.
Proof.
intros U HU;
apply path_forall;
intros x; rewrite HU; auto.
Qed.

(** OpenFun is sub-probabilistic*)
Lemma OpenFun_prob {A} : forall U:OS A, U = OS_full
                               -> ffle (OpenFun U) (fun x => RlP_1).
Proof.
intros U HU x;
rewrite HU; unfold Rlle; auto.
Qed.

(** OpenFun is monotonic *)
Lemma OpenFun_mon {A} : forall U V:OS A, Osle U V -> fle (OpenFun U) (OpenFun V).
Proof.
intros U V H1 s;
unfold OpenFun;
apply S_to_RlP_mon; trivial.
Qed.

Lemma Toto : forall p, p = 0%mc -> elt RlP_1 p.
Proof.
intros p Hp.
unfold RlP_1.
simpl.
unfold semi_decide, Rllt_semi_dec,
       decidable_semi_decide in *.
destruct (dec (p < Qone)).
apply top_greatest.
rewrite Hp in n.
assert (X : 0%mc < Qone).
apply lt_0_1.
case (n X).
Qed.

(** 1_U (x) = 1 iff 1_U (x) > 0 *)
Lemma OpenFun_0_1 {A  : hSet}: forall (U : OS A) z,
    OpenFun U z = RlP_1 <-> RlP_0 < OpenFun U z.
Proof.
intros U z.
split; intros H1.
+ rewrite H1.
  red; unfold Rlltpos, Rllt.
  apply tr.
  exists Qzero.
  split.
  - assert (Hh : forall p, p = 0%mc -> elt RlP_1 p).
    intros p Hp; unfold RlP_1.
    simpl.
    unfold semi_decide, Rllt_semi_dec,
       decidable_semi_decide in *.
    destruct (dec (p < Qone)).
    apply top_greatest.
    rewrite Hp in n.
    assert (X : 0%mc < Qone).
    apply lt_0_1.
    case (n X).
    apply Hh.
    reflexivity.
  - intros HF.
    assert (Hh : forall p, p = 0%mc -> ~ elt RlP_0 p).
    intros p Hp H.
    simpl in H.
    unfold semi_decide, Rllt_semi_dec,
       decidable_semi_decide in *.
    destruct (dec (p < Qzero)).
    rewrite Hp in l.
    assert (Hl : ~ 0%mc < Qzero).
    apply le_not_lt_flip.
    reflexivity.
    case (Hl l).
    apply not_bot in H; case H.
    specialize (Hh Qzero).
    assert (Hj : Qzero = 0%mc).
    reflexivity.
    apply Hh in Hj.
    case (Hj HF).
+ revert H1; unfold OpenFun, S_to_RlP.
  generalize (U z).
  apply (partial_ind0 _ (fun a => _ -> _)).
  - intros t H.
    assert (H1 : RlP_0 < RlP_1) by trivial.
    trivial.
  - intros H.
    assert (H1 : RlP_0 < RlP_0).
    trivial.
    apply Rllt_strict_order in H1.
    case H1.
  - intros f Hn' Hsup'.
    assert (Hn : forall n, RlP_0 < S_to_RlP (f n) ->
            S_to_RlP (f n) = RlP_1).
    trivial.
    clear Hn'.
    assert (Hsup : RlP_0 < (RllubPos (fun n =>
                           (S_to_RlP (f n)))));
    trivial; clear Hsup'.
    assert (H : (RllubPos (fun n => (S_to_RlP (f n))))
               = RlP_1).
    apply (antisymmetry le).
    * intros q Hql.
      apply top_le_enumerable_sup in Hql.
      unfold semi_decide, toRlseq in Hql.
      revert Hql; apply (Trunc_ind _).
      intros (x,Hx).
      destruct (Qle_total Qzero q).
      ** assert (H1 : S_to_RlP (f x) = RlP_1).
         apply Hn.
         red; unfold Rlltpos, Rllt;
         apply tr; exists q.
         split; trivial.
         intros Hf; simpl in Hf;
         unfold semi_decide, Rllt_semi_dec,
            decidable_semi_decide in *;
         destruct (dec (q < Qzero)).
         apply orders.lt_not_le_flip in l0.
         case (l0 l).
         apply not_bot in Hf; case Hf.
         rewrite H1 in Hx; trivial.
      ** simpl; unfold semi_decide, Rllt_semi_dec,
                decidable_semi_decide;
         destruct (dec (q < Qone)).
         apply top_greatest.
         assert (n' : q < Qone).
         apply orders.le_lt_trans with Qzero; trivial.
         apply semirings.lt_0_1.
         case (n n').
    * intros q Hq1.
      apply top_le_enumerable_sup.
      unfold semi_decide, toRlseq.
      assert (Hm : hexists
               (fun m => RlP_0 < S_to_RlP (f m))).
      red in Hsup; unfold Rlltpos,
                   Rllt in Hsup.
      revert Hsup; apply (Trunc_ind _);
      intros (r,(Hr1,Hr2)).
      apply top_le_enumerable_sup in Hr1.
      revert Hr1; apply (Trunc_ind _);
      intros (m,Hm);
      unfold semi_decide, toRlseq in *.
      apply tr; exists m.
      red; unfold Rlltpos, Rllt.
      apply tr.
      exists r; split;  trivial.
      revert Hm; apply (Trunc_ind _);
      intros (m,Hm).
      apply Hn in Hm.
      apply tr; exists m.
      rewrite Hm; trivial.
    * trivial.
Qed.

(** 1_U (x) = 1 iff x ∈ U *)
Lemma OpenFun_correct {A : hSet} : forall (x:A) U,
               OpenFun U x = RlP_1 <-> (U x) = SierTop.
Proof.
intros x U.
split; intros Hu.
apply OpenFun_0_1 in Hu.
+ unfold OpenFun, S_to_RlP in *.
  revert Hu.
  generalize (U x).
  apply (partial_ind0 _ (fun a => _->_)).
  - simpl; intros v Hv.
    unfold SierTop.
    destruct v.
    reflexivity.
  - simpl; intros Hv.
    assert (Hf : RlP_0 < RlP_0); trivial.
    red in Hf;
    unfold Rllt in Hf.
    revert Hf; apply (Trunc_ind _).
    intros (q,(E1,E2)).
    case (E2 E1).
  - intros f Hn Hn'.
    assert (Hn'2 : RlP_0 < RllubPos
           (fun n => S_to_RlP (f n))).
    trivial.
    clear Hn'.
    assert (Ha: merely (exists n : nat,
              RlP_0 < S_to_RlP (f n))).
    red in Hn'2;
    unfold Rlltpos, Rllt in Hn'2.
    revert Hn'2; apply (Trunc_ind _).
    intros (p,(Hp1,Hp2)).
    apply top_le_enumerable_sup in Hp1.
    revert Hp1; apply (Trunc_ind _).
    intros (m,Hm).
    apply tr.
    exists m.
    red;unfold Rlltpos, Rllt.
    apply tr.
    exists p.
    split; trivial.
    revert Ha; apply (Trunc_ind _).
    intros (w,Hw).
    specialize (Hn w Hw).
    apply top_le_eq.
    apply top_le_sup.
    apply tr; exists w;
    rewrite Hn;
    apply top_greatest.
+ unfold OpenFun, S_to_RlP;
  rewrite Hu; simpl.
  reflexivity.
Qed.

(** 1_(U /\ V) = (1_U) /\ (1_V) *)
Lemma Meet_pres_openfun {A:hSet}: forall z s,
          MeetPreserving (fun (U: OS A) => elt (OpenFun U z) s).
Proof.
intros z s x y;
unfold OpenFun, sg_op, meet_is_sg_op.
assert (H1 : (x ⋂ y) z = meet (x z) (y z)).
unfold OS_meet, meet.
apply (antisymmetry le);
apply imply_le;
intros Hs;
apply top_le_meet in Hs;
apply top_le_meet; trivial.
rewrite H1.
rewrite meet_pres_S_to_RlP.
reflexivity.
Qed.

(** 1_(U \/ V) = (1_U) \/ (1_V) *)
Lemma Join_pres_openfun {A:hSet}: forall z s,
          JoinPreserving (fun (U: OS A) => elt (OpenFun U z) s).
Proof.
intros z s x y;
unfold OpenFun, sg_op, join_is_sg_op.
assert (H1 : (x ∪ y) z = join (x z) (y z)).
unfold OS_join, join.
apply (antisymmetry le);
apply imply_le; intros Hs;
apply top_le_join in Hs;
apply top_le_join; trivial.
rewrite H1.
rewrite join_pres_S_to_RlP.
reflexivity.
Qed.

(** 1_U + 1_V = 1_(U \/ V) + 1_(U /\ V)*)
Lemma OpenFun_mod {A}: forall (U V : OS A), fplus (OpenFun U) (OpenFun V) =
                                fplus (OpenFun (OS_meet U V))
                                      (OpenFun (OS_join U V)).
Proof.
intros U V.
apply path_forall; intros z.
apply (antisymmetry le).
+ intros q Hs.
  simpl in *.
  apply RlPlus_eq_pr in Hs.
  apply RlPlus_eq_pr.
  revert Hs; apply (Trunc_ind _).
  intros Hs; apply tr.
  destruct Hs as (r,(r',(Hr,(Hr',Hq1)))).
  destruct (Qle_total r r') as [E|E].
  - generalize (SierMeet_is_meet).
    intros Hsm; destruct Hsm.
    exists r, r'.
    repeat split; try trivial.
    -- red.
       rewrite Meet_pres_openfun.
       apply meet_glb.
       * trivial.
       * revert Hr'.
         apply Rlow_mon; trivial.
         intros s Hs; trivial.
    -- apply Rlow_mon with (rl (OpenFun V z)) r'; trivial.
       reflexivity.
       apply OpenFun_mon.
       intros s; apply SierJoin_is_join; apply Hr'.
  - exists r', r.
    repeat split; try trivial.
    -- red.
       rewrite Meet_pres_openfun.
       apply SierMeet_is_meet.
       * revert Hr.
         apply Rlow_mon; trivial.
         intros s Hs;trivial.
       * trivial.
    -- apply Rlow_mon with (rl (OpenFun U z)) r; trivial.
       reflexivity.
       apply OpenFun_mon.
       intros s; apply SierJoin_is_join; apply Hr.
    -- rewrite rings.plus_comm; trivial.
+ intros q Hs. simpl in *.
  apply RlPlus_eq_pr in Hs.
  apply RlPlus_eq_pr.
  revert Hs; apply (Trunc_ind _).
  intros Hs.
  destruct Hs as (r,(r',(Hr,(Hr',Hq1)))).
  destruct (Qle_total r r') as [E|E].
  - rewrite Join_pres_openfun in Hr'.
    apply top_le_join in Hr'.
    unfold hor in Hr'.
    revert Hr'; apply (Trunc_ind _); intros Hr'.
    apply tr.
    destruct Hr'.
    -- exists r', r.
       repeat split; try trivial.
       * rewrite Meet_pres_openfun in Hr.
         revert Hr.
         apply SierLe_imply.
         apply SierMeet_is_meet.
       * rewrite rings.plus_comm; trivial.
    -- exists r, r'.
       repeat split; try trivial.
       * rewrite Meet_pres_openfun in Hr.
         revert Hr.
         apply SierLe_imply.
         apply SierMeet_is_meet.
  - apply tr. exists r', r.
    repeat split; try trivial.
    -- rewrite Meet_pres_openfun in Hr.
       assert (Hr1 : elt (rl (OpenFun U z)) r).
       revert Hr.
       apply SierLe_imply.
       apply SierMeet_is_meet.
       revert Hr1.
       apply Rlow_mon; try trivial.
       intros s Hs; trivial.
    -- revert Hr; apply OpenFun_mon.
       intros s; apply SierMeet_is_meet.
    -- rewrite rings.plus_comm; trivial.
Qed.

(* D_op 0 1_U = U *)
Lemma D_op_OpenFun {A  : hSet}: forall (U : OS A),
           (D_op Qzero (OpenFun U)) = U.
Proof.
intros U.
pose (Hdp := D_op_correct (OpenFun U) Qzero).
apply path_forall.
intros z.
apply (antisymmetry le).
+ apply imply_le.
  intros Hz.
  apply Hdp in Hz.
  apply OpenFun_0_1 in Hz.
  apply OpenFun_correct in Hz.
  rewrite Hz; apply top_greatest.
+ apply imply_le.
  intros Hz.
  apply Hdp.
  apply OpenFun_0_1.
  apply OpenFun_correct.
  apply top_le_eq; trivial.
Qed.

(** 1_U preserves lub *)
Lemma OpenFun_lub {A : hSet} :
    forall (U : IncreasingSequence (OS A)) x,
         OpenFun (Cpo.lub U) x =
                RllubPos (fun n => (OpenFun (U n)) x).
Proof.
intros U x.
unfold OpenFun; simpl.
apply (antisymmetry le).
+ intros s Hs.
  apply top_le_enumerable_sup in Hs.
  unfold semi_decide, toRlseq in Hs.
  revert Hs; apply (Trunc_ind _).
  intros (m,Hm).
  apply top_le_enumerable_sup.
  apply tr; exists m.
  revert Hm; apply S_to_RlP_mon.
  apply imply_le.
  intros Hv.
  apply top_le_joined_seq_n' in Hv.
  revert Hv; apply (Trunc_ind _).
  intros (p,Hp).
  destruct Hp as (Hpm,HUp).
  revert HUp.
  apply SierLe_imply.
  assert (H' : Osle (U p) (U m)).
  apply seq_increasing_le; trivial.
  apply H'.
+ intros s Hs.
  apply top_le_enumerable_sup in Hs.
  unfold semi_decide, toRlseq in Hs.
  revert Hs; apply (Trunc_ind _).
  intros (m,Hm).
  revert Hm; apply S_to_RlP_mon.
  apply imply_le.
  intros H.
  apply top_le_countable_sup.
  apply tr; exists m; trivial.
Qed.

(** fun n => U n ---> fun n => 1_(U n) *)
Definition OpenFun_increasing_sequence {A : hSet} :
   IncreasingSequence (OS A) -> IncreasingSequence (mf A).
Proof.
intros U.
exists (fun n => OpenFun (U n)).
intros n x.
apply OpenFun_mon.
apply U.
Defined.

Definition OpenFun_meet_fun {A : hSet} (U : OS A) (f : mf A) :=
             fun x => RlPMeet (f x) (OpenFun U x).

End OpenFun.


Require Export Crypto.Util.FixCoqMistakes.

Section tower_nd.
  Context (A : Type).
  Section with_B.
    Context (B : Type).
    Fixpoint tower_nd (n : nat)
      := match n with
         | 0 => B
         | S n' => A -> tower_nd n'
         end.
  End with_B.

  Section with_B2.
    Context (B B' : Type) (f : B -> B').
    Fixpoint impl_under_tower_nd (n : nat)
      : tower_nd B n -> tower_nd B' n
      := match n with
         | 0 => f
         | S n' => fun t x => impl_under_tower_nd n' (t x)
         end.
  End with_B2.
End tower_nd.

Definition apply4 {AK BK PA PB ARR}
           (F : forall (A : AK) (B : BK), (PA A -> PB B) -> PB (ARR A B))
           {A0 A1 A2 A3 : AK} {B : BK}
           (f : PA A0 -> PA A1 -> PA A2 -> PA A3 -> PB B)
  : PB (ARR A0 (ARR A1 (ARR A2 (ARR A3 B)))).
Proof.
  repeat (apply F; intro); apply f; assumption.
Defined.

Definition apply4_nd {BK PA PB ARR}
           (F : forall (B : BK), (PA -> PB B) -> PB (ARR B))
           {B : BK}
           (f : tower_nd PA (PB B) 4)
  : PB (ARR (ARR (ARR (ARR B))))
  := @apply4 unit BK (fun _ => PA) PB (fun _ => ARR) (fun _ => F)
             tt tt tt tt B f.

Definition apply9 {AK BK PA PB ARR}
           (F : forall (A : AK) (B : BK), (PA A -> PB B) -> PB (ARR A B))
           {A0 A1 A2 A3 A4 A5 A6 A7 A8 : AK} {B : BK}
           (f : PA A0 -> PA A1 -> PA A2 -> PA A3 -> PA A4 -> PA A5 -> PA A6 -> PA A7 -> PA A8 -> PB B)
  : PB (ARR A0 (ARR A1 (ARR A2 (ARR A3 (ARR A4 (ARR A5 (ARR A6 (ARR A7 (ARR A8 B))))))))).
Proof.
  repeat (apply F; intro); apply f; assumption.
Defined.

Definition apply9_nd {BK PA PB ARR}
           (F : forall (B : BK), (PA -> PB B) -> PB (ARR B))
           {B : BK}
           (f : tower_nd PA (PB B) 9)
  : PB (ARR (ARR (ARR (ARR (ARR (ARR (ARR (ARR (ARR B)))))))))
  := @apply9 unit BK (fun _ => PA) PB (fun _ => ARR) (fun _ => F)
             tt tt tt tt tt tt tt tt tt B f.


Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Compare_dec.
Import List.ListNotations.

Require Import Leapfrog.P4automaton.
Require Import Leapfrog.FinType.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.Relations.
Require Leapfrog.Bisimulations.Semantic.
Module BS := Leapfrog.Bisimulations.Semantic.

Section Upto.
  Variable (a: p4automaton).
  Notation conf := (configuration a).
  Definition bisimulation_upto
             (f: rel conf -> rel conf)
             (R: rel conf)
    :=
      forall c1 c2,
        R c1 c2 ->
        (accepting c1 <-> accepting c2) /\
        forall b, f R (step c1 b) (step c2 b)
  .

  Definition bisimilar_upto
             (f: rel conf -> rel conf)
             (c1 c2: conf)
    :=
      exists R, bisimulation_upto f R /\ R c1 c2
  .

  Definition closure_extends
             (close: rel conf -> rel conf)
    :=
      forall (R: rel conf) c1 c2,
        R c1 c2 -> close R c1 c2
  .

  Definition closure_preserves_accept
             (close: rel conf -> rel conf)
    :=
      forall (R: rel conf),
        (forall c1 c2, R c1 c2 -> accepting c1 <-> accepting c2) ->
        (forall c1 c2, close R c1 c2 -> accepting c1 <-> accepting c2)
  .

  Definition closure_preserves_transition
             (close: rel conf -> rel conf)
    :=
      forall (R: rel conf),
        (forall c1 c2, R c1 c2 ->
                  forall b, close R (step c1 b) (step c2 b)) ->
        (forall c1 c2, close R c1 c2 ->
                  forall b, close R (step c1 b) (step c2 b))
  .

  Definition closure_mono
             (close: rel conf -> rel conf)
    :=
      forall (R R': rel conf),
        (forall c1 c2, R c1 c2 -> R' c1 c2) ->
        (forall c1 c2, close R c1 c2 -> close R' c1 c2)
  .

  Class SoundClosure
        (f: rel conf -> rel conf)
    := {
    closure_sound_extends: closure_extends f;
    closure_sound_preserves_accept: closure_preserves_accept f;
    closure_sound_preserves_transition: closure_preserves_transition f;
    closure_sound_mono: closure_mono f;
      }.
End Upto.


Require Import Crypto.Algebra.Field.
Require Import Crypto.Spec.MontgomeryCurve Crypto.Curves.Montgomery.Affine.
Require Import Crypto.Spec.WeierstrassCurve Crypto.Curves.Weierstrass.Affine.
Require Import Crypto.Curves.Weierstrass.AffineProofs.
Require Import Crypto.Curves.Montgomery.AffineProofs.
Require Import Coq.Classes.RelationClasses.

Module M.
  Section MontgomeryCurve.
    Import BinNat.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Feq_dec:Decidable.DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "- x" := (Fopp x).
    Local Notation "x ^ 2" := (x*x) (at level 30).
    Local Notation "0" := Fzero.
    Local Notation "1" := Fone.
    Local Notation "4" := (1+1+1+1).

    Global Instance MontgomeryWeierstrassIsomorphism
           {a b: F}
           (b_nonzero : b <> 0)
           (discriminant_nonzero: a^2 - 4 <> 0)
           {char_ge_3:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 3}
           {char_ge_12:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 12}
           {char_ge_28:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 28} (* XXX: this is a workaround for nsatz assuming arbitrary characteristic *)
      :
      @Group.isomorphic_commutative_groups
        (@W.point F Feq Fadd Fmul _ _)
        W.eq
        (@W.add F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv field _ char_ge_3 _ _)
        W.zero
        (@W.opp F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv _ _ field _)

        (@M.point F Feq Fadd Fmul a b)
        M.eq
        (M.add(char_ge_3:=char_ge_3)(b_nonzero:=b_nonzero))
        M.zero
        (M.opp(b_nonzero:=b_nonzero))

        (M.of_Weierstrass(Haw:=reflexivity _)(Hbw:=reflexivity _)(b_nonzero:=b_nonzero))
        (M.to_Weierstrass(Haw:=reflexivity _)(Hbw:=reflexivity _)(b_nonzero:=b_nonzero)).
    Proof.
      eapply @AffineProofs.M.MontgomeryWeierstrassIsomorphism; try assumption; cbv [id]; fsatz.
    Qed.
  End MontgomeryCurve.
End M.


(* this file is just for experiments, and is not part of the development *)

(*
Goal forall (T:UU) (X : T -> T -> UU) (t t':T) (e:t==t') , X t t'.
  intros.
  destruct (!e).                (* doesn't work *)
  destruct e.                   (* replaces t' by t and eliminates e *)
  rewrite -> e.                 (* replaces t by t' *)
  rewrite    e.                 (* replaces t by t' *)
  rewrite <- e.                 (* replaces t' by t *)
*)

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel2.stnfsets.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations. Import PathNotations.
Require Import RezkCompletion.precategories.

Require Import Ktheory.Utilities.
        Import Ktheory.Utilities.Notations.

Module A.

  Module Type TU.
    Variable T:UU.
    Variable U:T->UU.
  End TU.

  Module Rec2 ( Import tu : TU ).
    Record F := newF { t:T; u:U t }.
    Lemma Feq (f f':F) (et : paths (t f) (t f')) (eu : paths (et # u f) (u f')) : paths f f'.
      destruct f as [a b].
      destruct f' as [a' b'].
      unfold t in et.
      unfold u in eu.
      destruct eu.
      destruct et.
      apply idpath.
    Defined.
    (* Check Feq. *)
  End Rec2.

  (* Print Module Rec2. *)

  Module nat_nat : TU.
    Definition T := nat.
    Definition U := (fun t:T => nat).
  End nat_nat.

  Module bool_bool : TU.
    Definition T := bool.
    Definition U := (fun t:T => bool).
  End bool_bool.

  Module prod_nat_nat := Rec2 nat_nat.
  Module prod_bool_bool := Rec2 bool_bool.

End A.

Module B.

  Require Import Foundations.Proof_of_Extensionality.funextfun.

  Add LoadPath "." as Ktheory.
  Require Import Ktheory.Utilities.

  Variable T:UU.
  Variable U:T->UU.
  Variable i:isofhlevel 2 T.
  Variable j:forall t, isofhlevel 2 (U t).

  Record F := newF { t:T; u:U t }.
  Definition G := total2 U.

  Lemma G2: isofhlevel 2 G.
    apply isofhleveltotal2.
    apply i. apply j. Defined.

  Lemma FG: G == F.
   apply univalenceaxiom.
   set (n := (fun g => newF (pr1 g) (pr2 g)) : G -> F).
   set (m := (fun f => tpair U (t f) (u f)) : F -> G).
   exists n.
   apply (gradth n m).
     intro. destruct x. apply idpath.
     intro. destruct y. apply idpath.
   Defined.

  Lemma F2: isofhlevel 2 F.
    destruct FG.  apply G2.
  Qed.

End B.


Require Import List.

Require Import bigstep.
Require Import datatypes.
Require Import smallstep.

(****************** Big -> Small *********************)

Lemma if_bf_then_sf: forall T s p t q,
                     bf T s p t q ->
                     sf T s p t q /\ is_value T t q.
induction 1.

split; auto. apply sf0; assumption.

split.
apply sfI with i (pair (Cons (hd r) l) (tl r)). apply s1R; assumption.
tauto. tauto.

split.
apply sfI with i (pair (tl l) (Cons (hd l) r)). apply s1L; assumption.
tauto. tauto.

split.
apply sfI with i (pair l (Cons a (tl r))). apply s1W; assumption.
tauto. tauto.
Qed.

(****************** Small -> Big *********************)

Lemma s1_to_bf: forall T s p t q u i,
                s1 T s p u i -> bf T u i t q ->
                bf T s p t q.
intros. inversion_clear H in H0.

apply bfR with i; assumption; assumption.
apply bfL with i; assumption; assumption.
apply bfW with i a; assumption; assumption.
Qed.

Lemma if_sf_then_bf: forall T s p t q,
                     sf T s p t q -> is_value T t q ->
                     bf T s p t q.
induction 1; intros.

apply bfH; assumption.

assert (bf T u i t q).
apply IHsf; assumption. clear H0 H1 IHsf.
apply s1_to_bf with u i; assumption; assumption.
Qed.

(****************** Big_oo -> Small_oo *********************)

Lemma if_bi_then_si: forall T s p,
                     bi T s p -> si T s p.
cofix cohp. intros.
inversion_clear H.

apply siC with q (pair (Cons (hd r) l) (tl r)).
apply s1R; assumption.
apply cohp; assumption.

apply siC with q (pair (tl l) (Cons (hd l) r)).
apply s1L; assumption.
apply cohp; assumption.

apply siC with q (pair l (Cons a (tl r))).
apply s1W; assumption.
apply cohp; assumption.
Qed.

(****************** Small_oo -> Big_oo *********************)

Lemma if_si_then_bi: forall T s p,
                     si T s p -> bi T s p.
cofix cohp. intros.
inversion_clear H. inversion_clear H0 in H1.

apply biR with q.
assumption.
apply cohp; assumption.

apply biL with q.
assumption.
apply cohp; assumption.

apply biW with q a.
assumption.
apply cohp; assumption.
Qed.

(****************** Extra tools (for later use) *************)

Lemma sf_to_bf: forall T s p t q u i,
                sf T s p u i -> bf T u i t q ->
                bf T s p t q.
induction 1; intros.

assumption.

assert (bf T u i t q). apply IHsf; assumption.
apply s1_to_bf with u i; assumption; assumption.
Qed.

Lemma sf_trans: forall T s p t q u i,
                sf T s p u i -> sf T u i t q ->
                sf T s p t q.
induction 1; intros.

assumption.

assert (sf T u i t q). apply IHsf; assumption.
apply sfI with i u; assumption; assumption.
Qed.


Require Import stack.
Require Import patterns.

Fixpoint rep_seg lst (tailp p : Z) : MapPattern Z Z :=
 match lst with
    | nil => constraint (p = tailp)
    | x :: xs => constraint (p <> 0) :* existsP p',
        p |-> x :* (p + 1) |-> p' :* rep_seg xs tailp p'
  end%pattern.
Notation rep_list l := (rep_seg l 0).


Inductive light : Set :=
  | Blue   : light
  | Yellow : light
  | Red    : light.

Definition next x :=
  match x with
    | Blue   => Yellow
    | Yellow => Red
    | Red    => Blue
  end.

Check next Yellow.
Eval compute in next Yellow.