Require Import prosa.classic.util.all.
Require Import prosa.classic.model.priority prosa.classic.model.suspension.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task
               prosa.classic.model.arrival.basic.arrival_sequence.
Require Import prosa.classic.model.arrival.jitter.job.
Require Import prosa.classic.model.schedule.uni.schedulability prosa.classic.model.schedule.uni.service
               prosa.classic.model.schedule.uni.workload
               prosa.classic.model.schedule.uni.response_time.
Require Import prosa.classic.model.schedule.uni.jitter.schedule
               prosa.classic.model.schedule.uni.jitter.valid_schedule
               prosa.classic.model.schedule.uni.jitter.platform.
Require Import prosa.classic.model.schedule.uni.susp.suspension_intervals
               prosa.classic.model.schedule.uni.susp.schedule
               prosa.classic.model.schedule.uni.susp.valid_schedule
               prosa.classic.model.schedule.uni.susp.platform.
Require Import prosa.classic.analysis.uni.susp.dynamic.jitter.jitter_schedule.
Require Import prosa.classic.model.schedule.uni.transformation.construction.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop path.

(* In this file, we prove several properties about the constructed jitter-aware schedule. *)
Module JitterScheduleProperties.

  Import Job SporadicTaskset Suspension Priority SuspensionIntervals Workload Service
         UniprocessorScheduleWithJitter Schedulability ResponseTime
         ScheduleConstruction ValidSuspensionAwareSchedule ValidJitterAwareSchedule.

  Module basic := schedule.UniprocessorSchedule.
  Module susp := ScheduleWithSuspensions.
  Module jitter_aware := Platform.
  Module susp_aware := PlatformWithSuspensions.
  Module job_jitter := JobWithJitter.
  Module reduction := JitterScheduleConstruction.

  Section ProvingScheduleProperties.

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

    (** Basic Setup & Setting *)

    (* Let ts be any task set to be analyzed. *)
    Variable ts: seq Task.

    (* Next, consider any consistent job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent:
      arrival_times_are_consistent job_arrival arr_seq.

    (* ...whose jobs come from task set ts. *)
    Hypothesis H_jobs_from_taskset:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* Consider any FP policy that is reflexive, transitive and total. *)
    Variable higher_eq_priority: FP_policy Task.
    Hypothesis H_priority_is_reflexive: FP_is_reflexive higher_eq_priority.
    Hypothesis H_priority_is_transitive: FP_is_transitive higher_eq_priority.
    Hypothesis H_priority_is_total: FP_is_total_over_task_set higher_eq_priority ts.
    Let job_higher_eq_priority := FP_to_JLDP job_task higher_eq_priority.

    (* Consider the original job and task costs from the suspension-aware schedule. *)
    Variable job_cost: Job -> time.
    Variable task_cost: Task -> time.

    (* Assume that jobs have associated suspension times. *)
    Variable job_suspension_duration: job_suspension Job.

    (* Next, consider any valid suspension-aware schedule of this arrival sequence.
       (Note: see prosa.classic.model.schedule.uni.susp.valid_schedule.v for details) *)
    Variable sched_susp: schedule Job.
    Hypothesis H_valid_schedule:
      valid_suspension_aware_schedule job_arrival arr_seq job_higher_eq_priority
                                      job_suspension_duration job_cost sched_susp.

    (* Finally, recall the definition of a job response-time bound in sched_susp. *)
    Let job_response_time_in_sched_susp_bounded_by :=
      is_response_time_bound_of_job job_arrival job_cost sched_susp.

    (** Analysis Setup *)

    (* Now we proceed with the reduction. Let j be the job to be analyzed. *)
    Variable j: Job.
    Hypothesis H_from_arrival_sequence: arrives_in arr_seq j.

    (* For simplicity, let's give some local names for the parameters of this job... *)
    Let arr_j := job_arrival j.
    Let task_of_j := job_task j.

    (* ...and recall the definition of other higher-or-equal-priority tasks. *)
    Let other_hep_task tsk_other :=
      higher_eq_priority tsk_other task_of_j && (tsk_other != task_of_j).

    (* Moreover, assume that each job is associated a response-time bound R. *)
    Variable R: Job -> time.

    (** Instantiation of the Reduction *)

    (* Next, recall the jitter-aware schedule from the reduction. *)
    Let sched_jitter := reduction.sched_jitter job_arrival job_task arr_seq higher_eq_priority
                                               job_cost job_suspension_duration j R.
    Let inflated_job_cost := reduction.inflated_job_cost job_cost job_suspension_duration j.
    Let job_jitter := reduction.job_jitter job_arrival job_task higher_eq_priority job_cost j R.

    (** Schedule Construction *)

    (* In this section, we prove that the jitter-aware schedule uses its construction function. *)
    Section PropertiesOfScheduleConstruction.

      Let build_schedule := reduction.build_schedule job_arrival job_task arr_seq higher_eq_priority
                                                     job_cost job_suspension_duration j R.

      (* Then, by showing that the construction function depends only on the previous service, ... *)
      Lemma sched_jitter_depends_only_on_service:
        forall sched1 sched2 t,
          (forall j, service sched1 j t = service sched2 j t) ->
          build_schedule sched1 t = build_schedule sched2 t.
      Proof.
        intros sched1 sched2 t ALL.
        rewrite /build_schedule /reduction.build_schedule /reduction.highest_priority_job_other_than_j.
        set pend1 := pending _ _ _ sched1.
        set pend2 := pending _ _ _ sched2.
        have SAME': forall j, pend1 j t = pend2 j t.
        {
          intros j0; rewrite /pend1 /pend2 /pending.
          case: jitter_has_passed => //=.
          by rewrite /completed_by ALL.
        }
        set pendjobs := reduction.pending_jobs_other_than_j _ _ _ _ _ _ _ _.
        have SAME: pendjobs sched1 t = pendjobs sched2 t.
        {
          apply eq_in_filter; intros j0 IN.
          rewrite /pending; case: jitter_has_passed => //=.
          by rewrite /completed_by ALL.
        }
        rewrite SAME SAME'; by done.
      Qed.

      (* ...we infer that the generated schedule is indeed based on the construction function. *)
      Corollary sched_jitter_uses_construction_function:
        forall t,
          sched_jitter t = build_schedule sched_jitter t.
      Proof.
        by ins; apply service_dependent_schedule_construction, sched_jitter_depends_only_on_service.
      Qed.

    End PropertiesOfScheduleConstruction.

    (** Valid Schedule Properties *)

    (* In this section, we prove that sched_jitter is a valid jitter-aware schedule. *)
    Section ScheduleIsValid.

      (* For simplicity, let's recall some definitions from the schedule construction. *)
      Let pending_jobs_other_than_j :=
        reduction.pending_jobs_other_than_j job_arrival job_task arr_seq higher_eq_priority
                                            job_cost job_suspension_duration j R sched_jitter.
      Let hp_job_other_than_j :=
        reduction.highest_priority_job_other_than_j job_arrival job_task arr_seq higher_eq_priority
                                                    job_cost job_suspension_duration j R sched_jitter.

      (* Also recall the definition of a valid jitter-aware schedule. *)
      Let is_valid_jitter_aware_schedule :=
        valid_jitter_aware_schedule job_arrival arr_seq job_higher_eq_priority
                                    inflated_job_cost job_jitter.

      (* First, we show that scheduled jobs come from the arrival sequence. *)
      Lemma sched_jitter_jobs_come_from_arrival_sequence:
        jobs_come_from_arrival_sequence sched_jitter arr_seq.
      Proof.
        move: H_valid_schedule => [FROM _].
        move => j0 t /eqP SCHED.
        rewrite sched_jitter_uses_construction_function /reduction.build_schedule
                -/hp_job_other_than_j in SCHED.
        set pending_in_jitter := pending _ _ _ _ in SCHED.
        destruct (hp_job_other_than_j t) as [j_hp|] eqn:HP; last first.
        {
          case PENDj: (pending_in_jitter j t); rewrite PENDj in SCHED; last by done.
          by case: SCHED => SAME; subst j0.
        }
        {
          have IN: arrives_in arr_seq j_hp.
          {
            have IN: j_hp \in pending_jobs_other_than_j t.
            {
              rewrite /hp_job_other_than_j /reduction.highest_priority_job_other_than_j in HP.
              by apply seq_min_in_seq in HP.
            }
            rewrite mem_filter in IN; move: IN => /andP [/andP _ IN].
            rewrite /actual_arrivals_up_to in IN.
            by apply in_actual_arrivals_between_implies_arrived in IN.
          }
          case PENDj: (pending_in_jitter j t); rewrite PENDj in SCHED;
            first by move: SCHED; case: (~~ _); case => SAME; subst.
          by case: SCHED => SAME; subst j0.
        }
      Qed.

      (* Next, we show that jobs do not execute before their arrival times... *)
      Lemma sched_jitter_jobs_execute_after_jitter:
        jobs_execute_after_jitter job_arrival job_jitter sched_jitter.
      Proof.
        move => j0 t /eqP SCHED.
        rewrite sched_jitter_uses_construction_function /reduction.build_schedule
                -/hp_job_other_than_j in SCHED.
        set pending_in_jitter := pending _ _ _ _ in SCHED.
        destruct (hp_job_other_than_j t) as [j_hp|] eqn:HP; last first.
        {
          case PENDj: (pending_in_jitter j t); rewrite PENDj in SCHED; last by done.
          by case: SCHED => SAME; subst j0; move: PENDj => /andP [ARR _].
        }
        {
          have ARR: jitter_has_passed job_arrival job_jitter j_hp t.
          {
            have IN: j_hp \in pending_jobs_other_than_j t.
            {
              rewrite /hp_job_other_than_j /reduction.highest_priority_job_other_than_j in HP.
              by apply seq_min_in_seq in HP.
            }
            by rewrite mem_filter in IN; move: IN => /andP [/andP [/andP [ARR _] _] _].
          }
          case PENDj: (pending_in_jitter j t); rewrite PENDj in SCHED;
            last by case: SCHED => SAME; subst j0.
          move: SCHED; case: (~~ _); case => SAME; subst; last by done.
          by move: PENDj => /andP [ARRj _].
        }
      Qed.

      (* ...nor longer than their execution costs. *)
      Lemma sched_jitter_completed_jobs_dont_execute:
        completed_jobs_dont_execute inflated_job_cost sched_jitter.
      Proof.
        intros j0 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 -[inflated_job_cost _]addn0; apply leq_add; first by rewrite -EQ.
        rewrite leqn0 eqb0 /scheduled_at.
        rewrite sched_jitter_uses_construction_function /reduction.build_schedule
                -/hp_job_other_than_j.
        destruct (hp_job_other_than_j t) as [j_hp|] eqn:HP; last first.
        { case PENDj: pending; last by done.
          apply/eqP; case => SAME; subst j0; move: PENDj => /andP [_ NOTCOMPj].
            by rewrite /completed_by EQ leqnn in NOTCOMPj.
        }
        rewrite /hp_job_other_than_j /reduction.highest_priority_job_other_than_j in HP.
        apply seq_min_in_seq in HP; rewrite mem_filter /pending /completed_by in HP.
        move: HP => /andP [/andP [/andP [_ NOTCOMPhp] _] _].
        case PENDj: pending.
        {
          move: PENDj => /andP [_ NOTCOMPj].
          case: (~~ higher_eq_priority _ _); apply/eqP; case => SAME; subst j0;
            first by rewrite /completed_by EQ leqnn in NOTCOMPj.
          by rewrite EQ leqnn in NOTCOMPhp.
        }
        {
          apply/eqP; case => SAME; subst j0.
          by rewrite EQ leqnn in NOTCOMPhp.
        }
      Qed.

      (* In addition, we prove that the schedule is (jitter-aware) work-conserving... *)
      Lemma sched_jitter_work_conserving:
        jitter_aware.work_conserving job_arrival inflated_job_cost job_jitter arr_seq sched_jitter.
      Proof.
        intros j0 t IN BACK.
        move: BACK => /andP [PEND NOTSCHED].
        rewrite /scheduled_at sched_jitter_uses_construction_function
                /reduction.build_schedule -/hp_job_other_than_j in NOTSCHED *.
        destruct (hp_job_other_than_j t) as [j_hp|] eqn:HP.
        {
          case PENDj: pending; rewrite PENDj in NOTSCHED; last by exists j_hp.
          by case: (~~ _); [by exists j | by exists j_hp].
        }
        {
          case PENDj: pending; rewrite PENDj in NOTSCHED; first by exists j.
          rewrite /hp_job_other_than_j /reduction.highest_priority_job_other_than_j in HP.
          case: (boolP (j0 == j)) => [EQ | NEQ];
            first by move: EQ => /eqP EQ; subst j0; rewrite PEND in PENDj.
          have IN0: j0 \in pending_jobs_other_than_j t.
          {
            rewrite mem_filter PEND NEQ /=.
            apply arrived_between_implies_in_actual_arrivals; try (by done).
            by move: PEND => /andP [ARR _].
          }
          move: HP => /eqP HP; rewrite -[_ == _]negbK in HP.
          exfalso; move: HP => /negP BUG; apply: BUG.
          by apply seq_min_exists with (x := j0).
        }
      Qed.

      (* ...and respects task priorities. *)
      Lemma sched_jitter_respects_policy:
        jitter_aware.respects_FP_policy job_arrival inflated_job_cost job_jitter
                                        job_task arr_seq sched_jitter higher_eq_priority.
      Proof.
        rename H_priority_is_transitive into TRANS, H_priority_is_total into TOTAL,
               H_priority_is_reflexive into REFL, H_jobs_from_taskset into FROMTS.
        move => j1 j2 t IN BACK /eqP SCHED.
        move: BACK => /andP [PEND NOTSCHED].
        rewrite /scheduled_at sched_jitter_uses_construction_function /reduction.build_schedule
                -/hp_job_other_than_j in SCHED NOTSCHED *.
        set pend := pending _ _ _ _ in SCHED NOTSCHED.
        have ALL: forall j_hi j_lo, hp_job_other_than_j t = Some j_hi ->
                                    j_lo \in pending_jobs_other_than_j t ->
                                    higher_eq_priority (job_task j_hi) (job_task j_lo).
        {
          intros j_hi j_lo SOME INlo; move: SCHED => MIN.
          rewrite /hp_job_other_than_j /reduction.highest_priority_job_other_than_j in SOME.
          apply seq_min_computes_min with (y := j_lo) in SOME; try (by done);
            first by intros x y z; apply TRANS.
          intros x y; rewrite mem_filter [y \in _]mem_filter /actual_arrivals_up_to.
          move => /andP [_ INx] /andP [_ INy].
          rewrite /FP_is_total_over_task_set /total_over_list in TOTAL.
          by apply/orP; apply TOTAL; apply FROMTS;
            eapply in_actual_arrivals_between_implies_arrived; eauto 1.
        }
        case PENDj: (pend j t); rewrite PENDj in SCHED NOTSCHED.
        {
          destruct (hp_job_other_than_j t) as [j_hp|] eqn:HP.
          {
            rewrite /FP_to_JLFP /= in SCHED NOTSCHED.
            case LP: (~~ higher_eq_priority (job_task j_hp) (job_task j));
              rewrite LP in SCHED NOTSCHED.
            {
              case: SCHED => SAME; subst j2.
              case: (boolP (j1 == j)) => [EQ | NEQ]; first by move: EQ => /eqP EQ; subst j1.
              apply (TRANS (job_task j_hp)).
              {
                have INhp: arrives_in arr_seq j_hp.
                {
                  rewrite /hp_job_other_than_j /reduction.highest_priority_job_other_than_j in HP.
                  apply seq_min_in_seq in HP.
                  rewrite mem_filter in HP; move: HP => /andP [_ INhp].
                  rewrite /actual_arrivals_up_to in INhp.
                  by apply in_actual_arrivals_before_implies_arrived in INhp.
                }
                by exploit (TOTAL (job_task j) (job_task j_hp)); try (by apply FROMTS);
                  move => [HPj | HPhp]; last by rewrite HPhp in LP.
              }
              apply ALL; try (by done).
              move: PEND => /andP [ARR NOTCOMP].
              rewrite mem_filter /pending ARR NOTCOMP 2!andTb.
              by apply/andP; split; last by apply arrived_between_implies_in_actual_arrivals.
            }
            {
              case: SCHED => SAME; subst j2.
              case: (boolP (j1 == j)) => [EQ | NEQ];
                first by move: EQ => /eqP EQ; subst j1; apply negbT in LP; rewrite negbK in LP.
              apply ALL; try (by done).
              move: PEND => /andP [ARR NOTCOMP].
              rewrite mem_filter /pending ARR NOTCOMP 2!andTb.
              by apply/andP; split; last by apply arrived_between_implies_in_actual_arrivals.
            }
          }
          {
            case: SCHED => SAME; subst j2.
            case: (boolP (j1 == j)) => [EQ | NEQ]; first by move: EQ => /eqP EQ; subst j1.
            suff NOTNONE: hp_job_other_than_j t != None by rewrite HP in NOTNONE.
            apply seq_min_exists with (x := j1).
            move: PEND => /andP [ARR NOTCOMP].
            rewrite mem_filter /pending ARR NOTCOMP 2!andTb.
            by apply/andP; split; last by apply arrived_between_implies_in_actual_arrivals.
          }
        }
        {
          case: (boolP (j1 == j)) => [EQ | NEQ];
            first by move: EQ => /eqP EQ; subst j1; rewrite -/pend PENDj in PEND.
          apply ALL; first by done.
          move: PEND => /andP [ARR NOTCOMP].
          rewrite mem_filter /pending ARR NOTCOMP 2!andTb.
          by apply/andP; split; last by apply arrived_between_implies_in_actual_arrivals.
        }
      Qed.

      (* From the properties above, we conclude that the generated schedule is valid. *)
      Corollary sched_jitter_is_valid: is_valid_jitter_aware_schedule sched_jitter.
      Proof.
        repeat split.
        - by apply sched_jitter_jobs_come_from_arrival_sequence.
        - by apply sched_jitter_jobs_execute_after_jitter.
        - by apply sched_jitter_completed_jobs_dont_execute.
        - by apply sched_jitter_work_conserving.
        - by apply sched_jitter_respects_policy.
      Qed.

      (* Finally, we show that the generated schedule does not pick job j if
         there are other pending higher-or-equal-priority jobs. *)
      Lemma sched_jitter_does_not_pick_j:
        forall j_hp t,
          arrives_in arr_seq j_hp ->
          j_hp != j ->
          pending job_arrival inflated_job_cost job_jitter sched_jitter j_hp t ->
          higher_eq_priority (job_task j_hp) (job_task j) ->
          ~~ scheduled_at sched_jitter j t.
      Proof.
        rename H_priority_is_transitive into TRANS, H_priority_is_total into TOTAL,
               H_jobs_from_taskset into FROMTS.
        move => j_hp t ARRinhp NEQ PENDhp HP; apply/negP; move => /eqP SCHEDj.
        rewrite sched_jitter_uses_construction_function /reduction.build_schedule
                -/hp_job_other_than_j in SCHEDj.
        set pend := pending _ _ _ _ in SCHEDj.
        have INhp: j_hp \in pending_jobs_other_than_j t.
        {
          rewrite mem_filter PENDhp NEQ /=.
          apply arrived_between_implies_in_actual_arrivals; try (by done).
          rewrite /actual_arrival_between /=.
          by move: PENDhp => /andP [ARRhp _].
        }
        case PENDj: (pend j t); rewrite PENDj in SCHEDj.
        {
          destruct (hp_job_other_than_j t) as [j_hp'|] eqn:HP'.
          {
            have ALL: forall j_lo,  j_lo \in pending_jobs_other_than_j t ->
                                    higher_eq_priority (job_task j_hp') (job_task j_lo).
            {
              intros j_lo INlo; move: HP' => MIN.
              rewrite /hp_job_other_than_j /reduction.highest_priority_job_other_than_j in MIN.
              apply seq_min_computes_min with (y := j_lo) in MIN; try (by done);
                first by intros x y z; apply TRANS.
              intros x y; rewrite mem_filter [y \in _]mem_filter /actual_arrivals_up_to.
              move => /andP [_ INx] /andP [_ INy].
              by apply/orP; apply TOTAL; apply FROMTS;
                eapply in_actual_arrivals_between_implies_arrived; eauto 1.
            }
            case LP: (~~ higher_eq_priority (job_task j_hp') (job_task j)); rewrite LP in SCHEDj.
            {
              move: LP => /negP LP; apply: LP.
              by apply (TRANS (job_task j_hp)); first by apply ALL.
            }
            {
              case: SCHEDj => SAME; subst j_hp'.
              rewrite /hp_job_other_than_j /reduction.highest_priority_job_other_than_j in HP'.
              by apply seq_min_in_seq in HP'; rewrite mem_filter eq_refl andbF /= in HP'.
            }
          }
          {
            suff NOTNONE: hp_job_other_than_j t != None by rewrite HP' in NOTNONE.
            by apply seq_min_exists with (x := j_hp).
          }
        }
        {
          rewrite /hp_job_other_than_j /reduction.highest_priority_job_other_than_j in SCHEDj.
          apply seq_min_in_seq in SCHEDj.
          by rewrite mem_filter eq_refl andbF in SCHEDj.
        }
      Qed.

    End ScheduleIsValid.

  End ProvingScheduleProperties.

End JitterScheduleProperties.


From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import auth gmap frac agree.
From iris.base_logic.lib Require Import gen_heap.
From iris.base_logic.lib Require Export own.
From iris.prelude Require Import options.
Import uPred.

Section definitions.

  Definition gen_heapUR L `{!EqDecision L} `{!Countable L} V :=
    gmapUR L (prodR fracR (agreeR (leibnizO V))).

  Context `{Countable L, hG : !inG Σ (authR (gen_heapUR L V))}.

  Definition to_gen_heap (σ : gmap L V) : gmap L (frac * (agree (leibnizO V))) :=
    (λ v, (1%Qp, to_agree v)) <$> σ.

  Lemma lookup_to_gen_heap_None σ l :
    σ !! l = None → to_gen_heap σ !! l = None.
  Proof. rewrite /to_gen_heap lookup_fmap => ->//. Qed.

  Lemma to_gen_heap_insert σ l v :
    to_gen_heap (<[l := v]>σ) = <[ l := (1%Qp, to_agree v)]>(to_gen_heap σ).
  Proof. rewrite /to_gen_heap fmap_insert //. Qed.

  Lemma to_gen_heap_valid σ : ✓ (to_gen_heap σ).
  Proof. intros i; rewrite lookup_fmap; destruct (σ !! i); done. Qed.

  Lemma gen_heap_singleton_included σ l q v :
    {[ l := (q, to_agree v)]} ≼ to_gen_heap σ → σ !! l = Some v.
  Proof.
    rewrite singleton_included_l; intros (w & Hw1 & Hw2).
    revert Hw2; rewrite -Hw1; clear Hw1.
    rewrite /to_gen_heap lookup_fmap; clear w.
    intros [|(w & w' & Hw1 & Hw2 & Hw3)]%option_included; first done.
    destruct (σ !! l); last by inversion Hw2.
    simplify_eq/=.
    destruct Hw3 as [[_ ->%(@to_agree_inj)%leibniz_equiv]|Hw3]; first done.
    apply prod_included in Hw3 as [_ ->%(@to_agree_included)%leibniz_equiv];
      done.
  Qed.

  Definition gen_heap_light_ctx (γ : gname) (σ : gmap L V) : iProp Σ :=
    @own _ _ hG γ (● (to_gen_heap σ)).

  Definition lmapsto_def (γ : gname) (l : L) (q : Qp) (v: V) : iProp Σ :=
    own γ (◯ {[ l := (q, to_agree (v : leibnizO V)) ]}).
  Definition lmapsto_aux : seal (@lmapsto_def). Proof. by eexists. Qed.
  Definition lmapsto := lmapsto_aux.(unseal).
  Definition lmapsto_eq : @lmapsto = @lmapsto_def := lmapsto_aux.(seal_eq).
End definitions.

Local Notation "l ; γ ↦{ q } v" := (lmapsto γ l q v)
  (at level 20, q at level 50, format "l  ;  γ  ↦{ q }  v") : bi_scope.
Local Notation "l ; γ ↦ v" := (lmapsto γ l 1 v) (at level 20) : bi_scope.

Local Notation "l ; γ ↦{ q } -" := (∃ v, l ; γ ↦{q} v)%I
  (at level 20, q at level 50, format "l  ;  γ  ↦{ q }  -") : bi_scope.
Local Notation "l ; γ ↦ -" := (l ; γ ↦{1} -)%I (at level 20) : bi_scope.

Lemma gen_heap_light_init `{Countable L, !inG Σ (authR (gen_heapUR L V))} σ :
  ⊢ |==> ∃ (γ : gname), gen_heap_light_ctx γ σ.
Proof.
  iMod (own_alloc (● to_gen_heap σ)) as (γ) "Hh".
  { rewrite auth_auth_valid. exact: to_gen_heap_valid. }
  eauto.
Qed.

Section gen_heap_light.
  Context {L V} `{Countable L, !inG Σ (authR (gen_heapUR L V))}.
  Implicit Types σ : gmap L V.
  Implicit Types l : L.
  Implicit Types v : V.

  (** General properties of lmapsto *)
  Global Instance lmapsto_timeless l γ q v : Timeless (l ; γ ↦{q} v).
  Proof. rewrite lmapsto_eq /lmapsto_def. apply _. Qed.
  Global Instance lmapsto_fractional l γ v : Fractional (λ q, l ; γ ↦{q} v)%I.
  Proof.
    intros p q. by rewrite lmapsto_eq /lmapsto_def -own_op -auth_frag_op
      singleton_op -pair_op agree_idemp.
  Qed.
  Global Instance lmapsto_as_fractional l γ q v :
    AsFractional (l ; γ ↦{q} v) (λ q, l ; γ ↦{q} v)%I q.
  Proof. split; [done|]. apply _. Qed.

  Lemma lmapsto_agree l γ q1 q2 v1 v2 :
    l ; γ ↦{q1} v1 -∗ l ; γ ↦{q2} v2 -∗ ⌜v1 = v2⌝.
  Proof.
    apply wand_intro_r.
    rewrite lmapsto_eq /lmapsto_def -own_op -auth_frag_op own_valid discrete_valid.
    f_equiv. rewrite auth_frag_valid singleton_op singleton_valid -pair_op.
    intros [_ ?%to_agree_op_inv_L]; done.
  Qed.

  Lemma lmapsto_combine l γ q1 q2 v1 v2 :
    l ; γ ↦{q1} v1 -∗ l ; γ ↦{q2} v2 -∗ l ; γ ↦{q1 + q2} v1 ∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "Hl1 Hl2". iDestruct (lmapsto_agree with "Hl1 Hl2") as %->.
    iCombine "Hl1 Hl2" as "Hl". eauto with iFrame.
  Qed.

  Global Instance frame_lmapsto p γ l v q1 q2 RES :
    FrameFractionalHyps p (l ; γ ↦{q1} v) (λ q, l ; γ ↦{q} v)%I RES q1 q2 →
    Frame p (l ; γ ↦{q1} v) (l ; γ ↦{q2} v) RES | 5.
  Proof. apply: frame_fractional. Qed.

  Global Instance ex_lmapsto_fractional l γ : Fractional (λ q, l ; γ ↦{q} -)%I.
  Proof.
    intros p q. iSplit.
    - iDestruct 1 as (v) "[H1 H2]". iSplitL "H1"; eauto.
    - iIntros "[H1 H2]". iDestruct "H1" as (v1) "H1". iDestruct "H2" as (v2) "H2".
      iDestruct (lmapsto_agree with "H1 H2") as %->. iExists v2. by iFrame.
  Qed.
  Global Instance ex_lmapsto_as_fractional l γ q :
    AsFractional (l ; γ ↦{q} -) (λ q, l ; γ ↦{q} -)%I q.
  Proof. split; [done|]. apply _. Qed.

  Lemma lmapsto_valid l γ q v : l ; γ ↦{q} v -∗ ✓ q.
  Proof.
    rewrite lmapsto_eq /lmapsto_def own_valid !discrete_valid auth_frag_valid.
    apply pure_mono=> /singleton_valid [??]; done.
  Qed.
  Lemma lmapsto_valid_2 l γ q1 q2 v1 v2 :
    l ; γ ↦{q1} v1 -∗ l ; γ ↦{q2} v2 -∗ ✓ (q1 + q2)%Qp.
  Proof.
    iIntros "H1 H2". iDestruct (lmapsto_agree with "H1 H2") as %->.
    iApply (lmapsto_valid l _ _ v2). by iFrame.
  Qed.

  Lemma lmapsto_lmapsto_ne l1 l2 γ q1 q2 v1 v2 :
    ¬ ✓(q1 + q2)%Qp → l1 ; γ ↦{q1} v1 -∗ l2 ; γ ↦{q2} v2 -∗ ⌜l1 ≠ l2⌝.
  Proof.
    iIntros (?) "Hl1 Hl2"; iIntros (->).
    by iDestruct (lmapsto_valid_2 with "Hl1 Hl2") as %?.
  Qed.

  (** Update lemmas *)
  Lemma gen_heap_light_alloc σ l γ v :
    σ !! l = None →
    gen_heap_light_ctx γ σ ==∗ gen_heap_light_ctx γ (<[l:=v]>σ) ∗ l ; γ ↦ v.
  Proof.
    iIntros (Hσl). rewrite /gen_heap_light_ctx lmapsto_eq /lmapsto_def /=.
    iIntros "Hσ".
    iMod (own_update with "Hσ") as "[Hσ Hl]".
    { eapply auth_update_alloc,
        (alloc_singleton_local_update _ _ (1%Qp, to_agree (v:leibnizO _)))=> //.
      by apply lookup_to_gen_heap_None. }
    iModIntro.
    rewrite to_gen_heap_insert. iFrame.
  Qed.

  Lemma gen_heap_light_alloc_gen σ σ' γ :
    σ' ##ₘ σ →
    gen_heap_light_ctx γ σ ==∗
    gen_heap_light_ctx γ (σ' ∪ σ) ∗ ([∗ map] l ↦ v ∈ σ', l ; γ ↦ v).
  Proof.
    revert σ; induction σ' as [| l v σ' Hl IH] using map_ind; iIntros (σ Hdisj) "Hσ".
    { rewrite left_id_L. auto. }
    iMod (IH with "Hσ") as "[Hσ'σ Hσ']"; first by eapply map_disjoint_insert_l.
    decompose_map_disjoint.
    rewrite !big_opM_insert // -insert_union_l //.
    by iMod (gen_heap_light_alloc with "Hσ'σ") as "($ & $ & $)";
      first by apply lookup_union_None.
  Qed.

  Lemma gen_heap_light_valid σ l γ q v :
    gen_heap_light_ctx γ σ -∗ l ; γ ↦{q} v -∗ ⌜σ !! l = Some v⌝.
  Proof.
    iIntros "Hσ Hl".
    rewrite /gen_heap_light_ctx lmapsto_eq /lmapsto_def.
    iDestruct (own_valid_2 with "Hσ Hl")
      as %[?%gen_heap_singleton_included _]%auth_both_valid_discrete; auto.
  Qed.

  Lemma gen_heap_light_update γ σ l v1 v2 :
    gen_heap_light_ctx γ σ -∗ l ; γ ↦ v1 ==∗
    gen_heap_light_ctx γ (<[l:=v2]>σ) ∗ l ; γ ↦ v2.
  Proof.
    iIntros "Hσ Hl". rewrite /gen_heap_light_ctx lmapsto_eq /lmapsto_def.
    iDestruct (own_valid_2 with "Hσ Hl")
      as %[Hl%gen_heap_singleton_included _]%auth_both_valid_discrete.
    iMod (own_update_2 with "Hσ Hl") as "[Hσ Hl]".
    { eapply auth_update, singleton_local_update,
        (exclusive_local_update _ (1%Qp, to_agree (v2:leibnizO _)))=> //.
      by rewrite /to_gen_heap lookup_fmap Hl. }
    iModIntro. iFrame "Hl". rewrite to_gen_heap_insert. iFrame.
  Qed.
End gen_heap_light.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Export disjoint.
Require Export def_exp.

Definition consistencySpec v1 v2 :=
  forall T v1' v2', typ_reduce v1 T v1' -> typ_reduce v2 T v2' -> v1' = v2'.

Lemma value_lc_expr: forall v,
    value v -> expr v.
Proof with auto.
  intros.
  induction H...
Qed.

Lemma tred_regular_type: forall v A t,
    typ_reduce v A t -> WFS empty A.
Proof with auto.
  intros.
  induction H;try solve [get_well_form;auto]...
Qed.

Lemma typing_chk2inf: forall G v A,
    typing G v Chk A -> exists B, typing G v Inf B /\ Sub G B A.
Proof with auto.
  intros G v A Typ.
  dependent induction Typ...
  exists A...
Qed.

Lemma typing_chk_sub: forall G e A B,
    typing G e Chk A -> Sub G A B -> typing G e Chk B.
Proof with auto.
  intros...
  dependent induction H...
  apply typing_sub with (A:=A)...
  apply Transitivity with (B:=B0)...
Qed.

Lemma wf_typ_from_binds_typ : forall x U E,
  wf_env E ->
  binds x (bind_typ U) E ->
  WFS E U.
Proof with auto.
  induction 1; intros J; analyze_binds J...
  apply IHwf_env in BindsTac.
  rewrite_alist (nil ++ [(X, bind_sub)] ++ E).
  apply WFS_weakening...
  injection BindsTacVal; intros; subst...
  rewrite_alist (nil ++ [(x0, bind_typ T)] ++ E).
  apply WFS_weakening...
  rewrite_alist (nil ++ [(x0, bind_typ T)] ++ E).
  apply WFS_weakening...
Qed.

Lemma typing_regular : forall E e dir T,
  typing E e dir T ->
  wf_env E /\ expr e /\ WFS E T.
Proof with auto.
  intros.
  induction H;destruct_hypos...
  - (* var *)
    repeat split...
    apply wf_typ_from_binds_typ with (x:=x)...
  - (* anno *)
    repeat split...
    constructor...
    get_type...
  - (* arrow *)
    repeat split...
    +
      pick fresh X.
      specialize_x_and_L X L.
      destruct_hypos.
      inversion H0...
    +
      apply lc_abs with (L:=L)...
      intros.
      eapply H0...
      pick fresh X.
      specialize_x_and_L X L.
      destruct_hypos.
      dependent destruction H0...
      get_type...
      pick fresh X.
      specialize_x_and_L X L.
      destruct_hypos.
      get_type...
    +
      pick fresh X.
      specialize_x_and_L X L.
      destruct_hypos.
      constructor...
      dependent destruction H0...
      add_nil.
      apply WFS_strengthening with (X:=X) (m:=bind_typ A)...
  - (* app *)
    dependent destruction H0.
    dependent destruction H7...
    repeat split...
  - (* fix *)
    repeat split...
    +
      pick fresh X.
      specialize_x_and_L X L.
      destruct_hypos.
      dependent destruction H0...
    +
      apply lc_fix with (L:=L)...
      intros.
      eapply H0...
      pick fresh X.
      specialize_x_and_L X L.
      destruct_hypos.
      get_type...
    +
      pick fresh X.
      specialize_x_and_L X L.
      destruct_hypos.
      dependent destruction H0...
  - (* fold *)
    repeat split...
    constructor...
    get_type...
  - (* merge *)
    repeat split...
    rewrite_alist (nil ++ G ++ nil).
    apply WFS_weakening...
  - (* unfold *)
    repeat split...
    constructor...
    get_type...
    dependent destruction H2.
    pick fresh X.
    rewrite subst_tt_intro with (X:=X)...
    add_nil.
    apply subst_tt_wfs3...
    apply H3...
    apply WFS_rec with (L:=L)...
  - (* proj *)
    repeat split...
    dependent destruction H0...
    dependent destruction H3...
  - (* sub *)
    repeat split...
    get_well_form...
Qed.

Lemma tred_regular : forall v1 T v2,
    typ_reduce v1 T v2 -> expr v1 /\ expr v2 /\ WFS empty T.
Proof with auto.
  intros.
  dependent induction H;destruct_hypos...
  -
    get_well_form...
  -
    repeat split;try constructor...
    get_type...
    get_type...
    get_well_form...
  -
    repeat split...
    dependent destruction H.
    apply lc_abs with (L:=L)...
    get_type...
    constructor;get_well_form...
Qed.

Lemma bind_type_notin: forall G,
    wf_env G ->
    forall x m,
      x `notin` dom G ->
      binds x m G -> False.
Proof with auto.
  intros G H.
  induction H;intros...
  -
    analyze_binds H2.
    apply IHwf_env with (x:=x) (m:=m)...
  -
    analyze_binds H3.
    apply IHwf_env with (x:=x0) (m:=m)...
Qed.

Lemma bind_type_uniq: forall G ,
    wf_env G ->
    forall x T S ,
    binds x (bind_typ T) G ->
    binds x (bind_typ S) G ->
    T = S.
Proof with auto.
  intros G H...
  induction H;intros...
  -
    analyze_binds H...
  -
    analyze_binds H1...
    analyze_binds H2...
    apply IHwf_env with (x:=x)...
  -
    analyze_binds H2...
    +
      analyze_binds H3...
      inversion BindsTacVal0...
      inversion BindsTacVal...
      apply bind_type_notin with (x:=x) (m:=bind_typ S) in H...
      destruct H.
    +
      analyze_binds H3...
      apply bind_type_notin with (x:=x) (m:=bind_typ T0) in H...
      destruct H.
      apply IHwf_env with (x:=x0)...
Qed.

Lemma RSub_regular: forall E A B,
    RSub E A B -> WFS E A /\ WFS E B /\ wf_env E.
Proof with auto.
  intros.
  induction H;get_well_form;destruct_hypos...
Qed.

Ltac get_well_form :=
    repeat match goal with
           | [ H : Sub _ _ _ |- _ ] => apply sub_regular in H;destruct_hypos
           | [ H : RSub _ _ _ |- _ ] => apply RSub_regular in H;destruct_hypos
           | [ H : toplike _ _ |- _ ] => apply toplike_regular in H;destruct_hypos                            | [ H : dis _ _ _ |- _ ] => apply dis_regular in H;destruct_hypos
           | [ H : typing _ _ _ _ |- _ ] => apply typing_regular in H;destruct_hypos                          | [ H : typ_reduce _ _ _ |- _ ] => apply tred_regular in H;destruct_hypos
           end.

Lemma typing_weakening: forall G1 G2 G3 e dir A,
    typing (G1 ++ G3) e dir A ->
    wf_env (G1 ++ G2 ++ G3) ->
    WFS (G1 ++ G2 ++ G3) A ->
    typing (G1 ++ G2 ++ G3) e dir A.
Proof with auto.
  intros.
  generalize dependent G2.
  dependent induction H;intros...
  - (* abs *)
    dependent destruction H2.
    apply typing_abs with (L:=L \u dom (G1 ++ G2 ++ G3))...
    intros.
    rewrite_alist (([(x, bind_typ A)] ++ G1) ++ G2 ++ G3).
    apply H0...
    rewrite_alist ([(x, bind_typ A)] ++ G1 ++ G2 ++ G3)...
    rewrite_alist (nil ++ [(x, bind_typ A)] ++ (G1 ++ G2 ++ G3))...
    apply WFS_weakening...
  - (* app *)
    apply typing_app with (C:=C) (T1:=T1)...
    apply IHtyping1...
    dependent destruction H0...
    constructor...
    get_well_form.
    apply WFS_weakening...
    apply IHtyping2...
    get_well_form.
    apply WFS_weakening...
  - (* fix *)
    apply typing_fix with (L:=L \u dom (G1 ++ G2 ++ G3))...
    intros.
    rewrite_alist (([(x, bind_typ A)] ++ G1) ++ G2 ++ G3).
    apply H0...
    rewrite_alist ([(x, bind_typ A)] ++ G1 ++ G2 ++ G3)...
    rewrite_alist (nil ++ [(x, bind_typ A)] ++ (G1 ++ G2 ++ G3))...
    apply WFS_weakening...
  - (* fold *)
    dependent destruction H.
    apply typing_fold with (A:=A)...
    apply IHtyping...
    get_well_form.
    apply WFS_weakening...
  - (* merge *)
    dependent destruction H3.
    apply typing_merge...
    apply dis_weakening...
  - (* unfold *)
    apply typing_unfold...
    apply IHtyping...
    get_well_form...
    apply WFS_weakening...
  - (* rcd *)
    apply typing_rcd...
    apply IHtyping...
    get_well_form...
    apply WFS_weakening...
  - (* proj *)
    apply typing_proj with (A:=A)...
    apply IHtyping...
    get_well_form...
    apply WFS_weakening...
  - (* sub *)
    apply typing_sub with (A:=A)...
    apply IHtyping...
    get_well_form.
    apply WFS_weakening...
    apply Sub_weakening...
Qed.

Lemma appTyp_arrow_unique: forall A B1 B2 C1 C2,
    appTyp A (typ_arrow B1 B2) -> appTyp A (typ_arrow C1 C2) -> B1 = C1 /\ B2 = C2.
Proof with auto.
  intros.
  dependent induction H;dependent induction H0...
Qed.

Lemma appTyp_rcd_unique: forall A l B2 C2,
    appTyp A (typ_rcd l B2) -> appTyp A (typ_rcd l C2) -> B2 = C2.
Proof with auto.
  intros.
  dependent induction H;dependent induction H0...
Qed.

Lemma inference_unique_aux : forall G e A1 A2,
    typing empty e Inf A1 ->
    typing G e Inf A2 ->
    A1 = A2.
Proof with auto.
  intros.
  generalize dependent A2.
  dependent induction H;intros;try solve [dependent destruction H0;auto|dependent destruction H1;auto]...
  - (* var *)
    analyze_binds H0...
  - (* app *)
    dependent destruction H2...
    assert (C = C0).
    apply IHtyping1...
    subst.
    apply appTyp_arrow_unique with (C1:=T3) (C2:=T0) in H0...
    inversion H0...
  - (* merge *)
    dependent destruction H2...
    +
      f_equal...
    +
      f_equal...
      apply IHtyping1...
      rewrite_alist (nil ++ G ++ nil).
      apply typing_weakening...
      rewrite_alist (nil ++ G++empty) in H4...
      get_well_form...
      apply WFS_weakening...
      apply IHtyping2...
      rewrite_alist (nil ++ G ++ nil).
      apply typing_weakening...
      rewrite_alist (nil ++ G++empty) in H4...
      get_well_form...
      apply WFS_weakening...
  - (* mergev *)
    dependent destruction H5...
    +
      f_equal...
    +
      f_equal...
      apply IHtyping1...
      rewrite_alist (nil ++ G ++ nil).
      apply typing_weakening...
      rewrite_alist (nil ++ G++empty) in H7...
      get_well_form...
      apply WFS_weakening...
      apply IHtyping2...
      rewrite_alist (nil ++ G ++ nil).
      apply typing_weakening...
      rewrite_alist (nil ++ G++empty) in H7...
      get_well_form...
      apply WFS_weakening...
  - (* rcd *)
    dependent destruction H0...
    f_equal.
    apply IHtyping...
  - (* proj *)
    dependent destruction H1...
    assert (A=A0).
    apply IHtyping...
    subst.
    apply appTyp_rcd_unique with (C2:=C0) in H0...
Qed.

Lemma inference_unique : forall G e A1 A2,
    typing G e Inf A1 ->
    typing G e Inf A2 ->
    A1 = A2.
Proof with auto.
  intros.
  generalize dependent A2.
  dependent induction H;intros;try solve [dependent destruction H0;auto|dependent destruction H1;auto]...
  - (* var *)
    dependent destruction H1...
    apply bind_type_uniq with (G:=G) (x:=x)...
  - (* app *)
    dependent destruction H2...
    assert (C = C0).
    apply IHtyping1...
    subst.
    apply appTyp_arrow_unique with (C1:= T3) (C2:=T0) in H0...
    inversion H0...
  - (* merge *)
    dependent destruction H2...
    +
      f_equal...
    +
      f_equal...
      apply IHtyping1...
      rewrite_alist (nil ++ G ++ nil).
      apply typing_weakening...
      rewrite_alist (nil ++ G++empty) in H4...
      get_well_form...
      apply WFS_weakening...
      apply IHtyping2...
      rewrite_alist (nil ++ G ++ nil).
      apply typing_weakening...
      rewrite_alist (nil ++ G++empty) in H4...
      get_well_form...
      apply WFS_weakening...
  - (* mergev *)
    dependent destruction H5...
    +
      f_equal...
      apply inference_unique_aux with (G:=G) (e:=e1)...
      apply inference_unique_aux with (G:=G) (e:=e2)...
    +
      f_equal...
  - (* rcd *)
    dependent destruction H0...
    f_equal.
    apply IHtyping...
  - (* proj *)
    dependent destruction H1...
    assert (A=A0).
    apply IHtyping...
    subst.
    apply appTyp_rcd_unique with (C2:=C0) in H0...
Qed.

Lemma typing_inf_chk_sub: forall G e A B,
    typing G e Inf A -> typing G e Chk B -> Sub G A B.
Proof with auto.
  intros G e A B H H0.
  apply typing_chk2inf in H0.
  destruct H0.
  destruct H0.
  apply inference_unique with (A2:=x) in H...
  subst...
Qed.


Require Import List ZArith.
Import ListNotations.

From StructTact Require Import StructTactics Fin.
Require Fin Ascii.

Require Import Cheerios.Core.
Require Import Cheerios.DeserializerMonad.
Require Import Cheerios.Tactics.
Require Import Cheerios.Types.

Import DeserializerNotations.

Lemma byte_serialize_deserialize_id :
  serialize_deserialize_id_spec IOStreamWriter.putByte ByteListReader.getByte.
Proof. cheerios_crush. Qed.

(*#[global]*)
Instance byte_Serializer : Serializer byte :=
  {| serialize := IOStreamWriter.putByte;
     deserialize := ByteListReader.getByte;
     serialize_deserialize_id := byte_serialize_deserialize_id |}.

Lemma byte_unwrap : forall b, IOStreamWriter.unwrap (serialize b) = [b].
Proof.
  cheerios_crush.
Qed.

(*#[global]*)
Hint Rewrite byte_unwrap : cheerios.

Definition bool_serialize (b : bool) : IOStreamWriter.t :=
  if b then serialize x01 else serialize x00.

Definition bool_deserialize :=
  b <- deserialize ;;
    match b with
    | x00 => ByteListReader.ret false
    | x01 => ByteListReader.ret true
    | _ => ByteListReader.error
    end.

Lemma bool_serialize_deserialize_id :
  serialize_deserialize_id_spec bool_serialize bool_deserialize.
Proof.
  intros.
  unfold bool_serialize, bool_deserialize.
  destruct a;
    cheerios_crush; simpl; cheerios_crush.
Qed.

(*#[global]*)
Instance bool_Serializer : Serializer bool.
Proof.
  exact {| serialize := bool_serialize;
           deserialize := bool_deserialize;
           serialize_deserialize_id := bool_serialize_deserialize_id |}.
Qed.

(* this needs to go here because we need the bool_Serializer instance *)
Lemma fold_append_unwrap :
  forall {S A : Type}
         (f : byte -> S -> fold_state S A) (s : S)
         (b : byte) (tail : IOStreamWriter.t) (bin : list byte),
    ByteListReader.unwrap (ByteListReader.fold f s)
                          (IOStreamWriter.unwrap (IOStreamWriter.append
                                                    (fun _ => (serialize b))
                                                    (fun _ => tail)) ++ bin) =
    match f b s with
    | Done a => Some(a, IOStreamWriter.unwrap tail ++ bin)
    | More s => ByteListReader.unwrap (ByteListReader.fold f s)
                                      (IOStreamWriter.unwrap tail ++ bin)
    | Error => None
    end.
Proof.
  cheerios_crush.
Qed.

Lemma fold_append_unwrap' :
  forall {S A : Type}
         (f : byte -> S -> fold_state S A) (s : S)
         (b : byte) (tail : IOStreamWriter.t) (bin : list byte),
    ByteListReader.unwrap (ByteListReader.fold f s)
                          (IOStreamWriter.unwrap (IOStreamWriter.append
                                                    (fun _ => IOStreamWriter.putByte b)
                                                    (fun _ => tail)) ++ bin) =
    match f b s with
    | Done a => Some(a, IOStreamWriter.unwrap tail ++ bin)
    | More s => ByteListReader.unwrap (ByteListReader.fold f s)
                                      (IOStreamWriter.unwrap tail ++ bin)
    | Error => None
    end.
Proof.
  cheerios_crush.
Qed.
(*#[global]*)
Hint Rewrite @fold_append_unwrap @fold_append_unwrap' : cheerios.

Inductive le_pos (p : positive) : positive -> Prop :=
| le_p : le_pos p p
| le_xI : forall p2, le_pos p p2 -> le_pos p (xI p2)
| le_xO : forall p2, le_pos p p2 -> le_pos p (xO p2).

Section PositiveInductionPrinciple.
  Variable P : positive -> Prop.

  Lemma strongind_pos_aux :
    P xH ->
    (forall q, ((forall p, le_pos p q -> P p) -> P (xI q)) /\
               ((forall p, le_pos p q -> P p) -> P (xO q))) ->
    (forall q, (forall p, le_pos p q -> P p)).
  Proof using.
    induction q;
      intros;
      inversion H1;
      auto;
      apply H0;
      apply IHq.
  Qed.

  Lemma weaken_pos :
    (forall q, (forall p, le_pos p q -> P p)) -> forall p, P p.
  Proof using.
    intros.
    apply (H p p).
    constructor.
  Qed.

  Theorem strongind_pos :
    P xH ->
    (forall q, ((forall p, le_pos p q -> P p) -> P (xI q)) /\
               ((forall p, le_pos p q -> P p) -> P (xO q))) ->
    forall p, P p.
  Proof using.
    intros.
    apply weaken_pos.
    now apply strongind_pos_aux.
  Qed.
End PositiveInductionPrinciple.

Local Open Scope char_scope.

Fixpoint positive_serialize p :=
  match p with
  | xI (xI (xI p)) => IOStreamWriter.append (fun _ => serialize x0e)
                                            (fun _ => positive_serialize p)
  | xI (xI (xO p)) => IOStreamWriter.append (fun _ => serialize x0d)
                                            (fun _ => positive_serialize p)
  | xI (xO (xI p)) => IOStreamWriter.append (fun _ => serialize x0c)
                                            (fun _ => positive_serialize p)
  | xI (xO (xO p)) => IOStreamWriter.append (fun _ => serialize x0b)
                                            (fun _ => positive_serialize p)
  | xO (xI (xI p)) => IOStreamWriter.append (fun _ => serialize x0a)
                                            (fun _ => positive_serialize p)
  | xO (xI (xO p)) => IOStreamWriter.append (fun _ => serialize x09)
                                            (fun _ => positive_serialize p)
  | xO (xO (xI p)) => IOStreamWriter.append (fun _ => serialize x08)
                                            (fun _ => positive_serialize p)
  | xO (xO (xO p)) => IOStreamWriter.append (fun _ => serialize x07)
                                            (fun _ => positive_serialize p)
  | xI (xI p) => IOStreamWriter.append (fun _ => serialize x06)
                                       (fun _ => positive_serialize p)
  | xI (xO p) => IOStreamWriter.append (fun _ => serialize x05)
                                       (fun _ => positive_serialize p)
  | xO (xI p) => IOStreamWriter.append (fun _ => serialize x04)
                                       (fun _ => positive_serialize p)
  | xO (xO p) => IOStreamWriter.append (fun _ => serialize x03)
                                       (fun _ => positive_serialize p)
  | xI p => IOStreamWriter.append (fun _ => serialize x02)
                                  (fun _ => positive_serialize p)
  | xO p => IOStreamWriter.append (fun _ => serialize x01)
                                  (fun _ => positive_serialize p)
  | XH => serialize x00
  end.

Definition positive_deserialize_step
           (b : byte)
           (s : positive -> positive) :=
  match b with
  | x0e => More (fun p => s (xI (xI (xI p))))
  | x0d => More (fun p => s (xI (xI (xO p))))
  | x0c => More (fun p => s (xI (xO (xI p))))
  | x0b => More (fun p => s (xI (xO (xO p))))
  | x0a => More (fun p => s (xO (xI (xI p))))
  | x09 => More (fun p => s (xO (xI (xO p))))
  | x08 => More (fun p =>  s (xO (xO (xI p))))
  | x07 => More (fun p => s (xO (xO (xO p))))
  | x06 => More (fun p => s (xI (xI p)))
  | x05 => More (fun p => s (xI (xO p)))
  | x04 => More (fun p => s (xO (xI p)))
  | x03 => More (fun p => s (xO (xO p)))
  | x02 => More (fun p => s (xI p))
  | x01 => More (fun p => s (xO p))
  | x00 => Done (s xH)
  | _ => Error
  end.

Definition positive_step_aux p :=
  forall (k : positive -> positive) (bytes : list byte),
    ByteListReader.unwrap (ByteListReader.fold positive_deserialize_step k)
                          (IOStreamWriter.unwrap (positive_serialize p) ++ bytes)
    = Some(k p, bytes).

Lemma positive_step :
  forall (p : positive), positive_step_aux p.
Proof.
  apply strongind_pos; unfold positive_step_aux.
  - unfold positive_serialize.
    cheerios_crush.
  - split;
      intros;
      try destruct q;
      try destruct q;
      simpl; cheerios_crush; simpl; rewrite H || cheerios_crush;
        try reflexivity;
        repeat constructor.
Qed.

Definition positive_deserialize :=
  ByteListReader.fold positive_deserialize_step (fun p => p).

Theorem positive_serialize_deserialize_id :
  serialize_deserialize_id_spec positive_serialize
                                positive_deserialize.
Proof.
  intros.
  unfold positive_deserialize.
  apply positive_step.
Qed.

(*#[global]*)
Instance positive_Serializer : Serializer positive.
Proof.
  exact ({| serialize := positive_serialize;
            deserialize := positive_deserialize;
            serialize_deserialize_id := positive_serialize_deserialize_id
         |}).
Qed.

(* This is the first example of a "typical" serializer: it combines more
   primitive serializers (in this case, just for byte and positive) together in
   order to serialize a Z. *)
Definition Z_serialize (z : Z) : IOStreamWriter.t :=
  match z with
  | Z0 => serialize x00
  | Zpos p => IOStreamWriter.append (fun _ => serialize x01)
                                    (fun _ => serialize p)
  | Zneg p => IOStreamWriter.append (fun _ => serialize x02)
                                    (fun _ => serialize p)
  end.

Definition Z_deserialize : ByteListReader.t Z :=
  tag <- deserialize ;;
      match tag with
      | x02 => Zneg <$> deserialize
      | x01 => Zpos <$> deserialize
      | x00 => ByteListReader.ret Z0
      | _ => ByteListReader.error
      end.

(* This proof is typical for serializing an algebraic datatype. Unfold the
   serializer and deserializer, then do a case analysis and call
   serialize_deserialize_id_crush. *)
Lemma Z_serialize_deserialize_id :
  serialize_deserialize_id_spec Z_serialize Z_deserialize.
Proof.
  intros.
  unfold Z_serialize, Z_deserialize.
  destruct a;
    repeat (cheerios_crush; simpl).
Qed.

(*#[global]*)
Instance Z_Serializer : Serializer Z :=
  {| serialize := Z_serialize;
     deserialize := Z_deserialize;
     serialize_deserialize_id := Z_serialize_deserialize_id
  |}.

Definition N_serialize n :=
  match n with
  | N0 => serialize false
  | Npos p => IOStreamWriter.append (fun _ => serialize true)
                                    (fun _ => serialize p)
  end.

Definition N_deserialize : ByteListReader.t N :=
  tag <- deserialize ;;
      match tag with
      | false => ByteListReader.ret N0
      | true => Npos <$> deserialize
      end.

Lemma N_serialize_deserialize_id :
  serialize_deserialize_id_spec N_serialize N_deserialize.
Proof.
  intros.
  unfold N_serialize, N_deserialize.
  destruct a;
    repeat (cheerios_crush; simpl).
Qed.

(*#[global]*)
Instance N_Serializer : Serializer N.
Proof.
  exact {| serialize := N_serialize;
           deserialize := N_deserialize;
           serialize_deserialize_id := N_serialize_deserialize_id
        |}.
Qed.

(* The other main way to define a serializer is to use an isomorphism to another
   type that is already serializable. *)
Definition nat_serialize n : IOStreamWriter.t := serialize (N.of_nat n).

Definition nat_deserialize : ByteListReader.t nat := N.to_nat <$> deserialize.

(* This proof is typical for serializers defined by converting to and from a
   type that is already serializable. Unfold the serializer and deserializer,
   call serialize_deserialize_id_crush, and then use the proof that the
   conversion functions are inverses. *)
Lemma nat_serialize_deserialize_id :
  serialize_deserialize_id_spec nat_serialize nat_deserialize.
Proof.
  unfold nat_serialize, nat_deserialize.
  cheerios_crush.
  now rewrite Nnat.Nat2N.id.
Qed.

(*#[global]*)
Instance nat_Serializer : Serializer nat :=
  {| serialize := nat_serialize;
     deserialize := nat_deserialize;
     serialize_deserialize_id := nat_serialize_deserialize_id
  |}.

(* Serializer for the standard library's Fin.t based on converting to nat. *)
Definition Fin_serialize {n} (x : Fin.t n) : IOStreamWriter.t :=
  serialize (proj1_sig (Fin.to_nat x)).

Definition Fin_deserialize {n} : ByteListReader.t (Fin.t n) :=
  m <- deserialize ;;
    match Fin.of_nat m n with
    | inleft x => ByteListReader.ret x
    | inright _ => ByteListReader.error
    end.

Lemma Fin_of_nat_to_nat:
  forall (n : nat) (a : Fin.t n), Fin.of_nat (proj1_sig (Fin.to_nat a)) n = inleft a.
Proof.
  induction a.
  - auto.
  - simpl. break_let. simpl in *.
    now rewrite IHa.
Qed.

Lemma Fin_serialize_deserialize_id n :
  serialize_deserialize_id_spec Fin_serialize (@Fin_deserialize n).
Proof.
  unfold Fin_serialize, Fin_deserialize.
  cheerios_crush.
  rewrite Fin_of_nat_to_nat.
  cheerios_crush.
Qed.

(*#[global]*)
Instance Fin_Serializer n : Serializer (Fin.t n).
Proof.
  exact {| serialize := Fin_serialize;
           deserialize := Fin_deserialize;
           serialize_deserialize_id := Fin_serialize_deserialize_id n
        |}.
Qed.

(* Serializer for StructTact's fin based on converting to nat. *)
Definition fin_serialize {n} (x : fin n) : IOStreamWriter.t :=
  serialize (fin_to_nat x).

Definition fin_deserialize {n} : ByteListReader.t (fin n) :=
  m <- deserialize ;;
    match fin_of_nat m n with
    | inleft x => ByteListReader.ret x
    | inright _ => ByteListReader.error
    end.

Lemma fin_serialize_deserialize_id n :
  serialize_deserialize_id_spec fin_serialize (@fin_deserialize n).
Proof.
  unfold fin_serialize, fin_deserialize.
  cheerios_crush.
  rewrite fin_of_nat_fin_to_nat.
  cheerios_crush.
Qed.

(*#[global]*)
Instance fin_Serializer n : Serializer (fin n).
Proof.
  exact {| serialize := fin_serialize;
           deserialize := fin_deserialize;
           serialize_deserialize_id := fin_serialize_deserialize_id n
        |}.
Qed.

Definition ascii_serialize (a : Ascii.ascii) : IOStreamWriter.t :=
  serialize (Ascii.nat_of_ascii a).

Definition ascii_deserialize : ByteListReader.t Ascii.ascii :=
  Ascii.ascii_of_nat <$> deserialize.

Lemma ascii_serialize_deserialize_id :
  serialize_deserialize_id_spec ascii_serialize ascii_deserialize.
Proof.
  unfold ascii_deserialize, ascii_serialize.
  cheerios_crush.
  now rewrite Ascii.ascii_nat_embedding.
Qed.

(*#[global]*)
Instance ascii_Serializer : Serializer Ascii.ascii.
Proof.
exact  {| serialize := ascii_serialize;
          deserialize := ascii_deserialize;
          serialize_deserialize_id := ascii_serialize_deserialize_id
       |}.
Qed.


From Tealeaves Require Export
     Classes.ListableModule
      Classes.TraversableMonad.

Import Functor.Notations.
Import SetlikeFunctor.Notations.
Import Monoid.Notations.
Import Applicative.Notations.
#[local] Open Scope tealeaves_scope.

(** * Traversable right modules *)
(******************************************************************************)
Section TraversableModule.

  Context
    (F T : Type -> Type)
    `{Fmap T} `{Return T} `{Join T}  `{Dist T}
    `{Fmap F} `{RightAction F T} `{Dist F}.

  Class TraversableModule :=
    { trvmod_module :> RightModule F T;
      trvmod_functor :> TraversableFunctor F;
      trvmod_monad :> TraversableMonad T;
      trvmod_action : forall `{Applicative G},
          `(dist F G ∘ right_action F =
            fmap G (right_action F) ∘ dist (F ∘ T) G (A := A));
    }.

End TraversableModule.

(** ** Traversable monads are traversable modules *)
(******************************************************************************)
Section module_of_monad.

  Context
    (T : Type -> Type).

  Existing Instance RightAction_Join.
  Existing Instance RightModule_Monad.

  Program Instance TraversableModule_Monad `{TraversableMonad T} :
    TraversableModule T T :=
    {| trvmod_action := fun _ _ _ _ _ => trvmon_join T;
    |}.

End module_of_monad.

(** ** Traversable modules are closed under composition with functors *)
(******************************************************************************)
Section TraversableModule_compose.

  Context
    `{TraversableFunctor F2}
    `{TraversableModule F1 T}.

  Instance: RightModule (F2 ∘ F1) T := RightModule_compose.

  #[local] Set Keyed Unification.
  Theorem dist_right_action_compose `{Applicative G} {A} :
    dist (F2 ∘ F1) G ∘ fmap F2 (right_action F1 (A := G A)) =
    fmap G (fmap F2 (right_action F1)) ∘ dist (F2 ∘ F1 ∘ T) G.
  Proof.
    unfold_ops @Dist_compose. unfold dist at 3.
    unfold_ops @Fmap_compose. do 2 reassociate <-.
    reassociate -> on right. rewrite (fun_fmap_fmap F2).
    reassociate -> on left. rewrite (fun_fmap_fmap F2).
    rewrite (trvmod_action F1 T). rewrite <- (fun_fmap_fmap F2).
    reassociate <- on left. unfold_ops @Dist_compose. fequal.
    change (fmap G (fmap F2 ?f)) with (fmap (G ∘ F2) f).
    now rewrite (dist_natural F2).
  Qed.

  Instance TraversableModule_compose : TraversableModule (F2 ∘ F1) T :=
    {| trvmod_action := @dist_right_action_compose; |}.

End TraversableModule_compose.

(** * Kleisli-style presentation of traversable monads *)
(******************************************************************************)

(** ** Operations *)
(******************************************************************************)
Section KleisliTraversableModule_operations.

  Definition subt (F : Type -> Type)
             `{Fmap F} `{RightAction F T} `{Dist F}
             {A B} `{Applicative G} : (A -> G (T B)) -> F A -> G (F B) :=
    fun f => fmap G (right_action F) ∘ dist F G ∘ fmap F f.

End KleisliTraversableModule_operations.

Import TraversableMonad.Notations.

(** ** Specifications for sub-operations *)
(******************************************************************************)
Section KleisliTraversableMonad_suboperations.

  Context
    (F T : Type -> Type)
    `{TraversableModule F T}.

  Lemma sub_to_subt : forall `(f : A -> T B),
      sub F f = subt F (f : A -> (fun A => A) (T B)).
  Proof.
    intros. unfold subt. now rewrite (dist_unit F).
  Qed.

  Lemma traverse_to_subt `{Applicative G} : forall `(f : A -> G B),
      traverse F G f = subt F (fmap G (ret T) ∘ f).
  Proof.
    introv. unfold subt.
    rewrite <- (fun_fmap_fmap F).
    change_right (fmap G (right_action F) ∘
                       (dist F G ∘ fmap (F ∘ G) (ret T)) ∘ fmap F f).
    rewrite <- (dist_natural F (ret T)).
    unfold_ops @Fmap_compose.
    repeat reassociate <-.
    unfold_compose_in_compose.
    rewrite (fun_fmap_fmap G).
    rewrite (rmod_action_fmap_ret F T).
    now rewrite (fun_fmap_id G).
  Qed.

  Lemma fmap_to_sub : forall `(f : A -> B),
      fmap F f = subt F (ret T ∘ f : A -> (fun A => A) (T B)).
  Proof.
    introv. rewrite (fmap_to_traverse F). now rewrite traverse_to_subt.
  Qed.

End KleisliTraversableMonad_suboperations.

(** ** Kleisli laws for [subtm] *)
(******************************************************************************)
Section KleisliTraversableModule_subt.

  Context
    (F : Type -> Type)
    `{TraversableModule F T}.

  Context
    {A B C : Type}
    `{Applicative G1}
    `{Applicative G2}.

  (** *** Identity law *)
  Lemma subt_id :
    `(subt F (G := fun A => A) (ret T) = @id (F A)).
  Proof.
    intros. unfold subt.
    unfold_ops @Fmap_I. rewrite (dist_unit F).
    change (?g ∘ id ∘ ?f) with (g ∘ f).
    now rewrite (rmod_action_fmap_ret F T).
  Qed.

  (** *** Composition law *)
  Lemma subt_subt : forall (g : B -> G2 (T C)) (f : A -> G1 (T B)),
      subt F (G := G1 ∘ G2) (g ⋆tm f) =
      fmap G1 (subt F g) ∘ subt F f.
  Proof.
    intros. unfold subt at 2 3.
    reassociate -> on right. repeat reassociate <-.
    rewrite (fun_fmap_fmap G1).
    reassociate -> near (right_action F). rewrite (natural (ϕ := @right_action F T _)).
    reassociate <-. reassociate -> near (right_action F).
    rewrite (trvmod_action F T). reassociate <-.
    rewrite (fun_fmap_fmap G2).
    rewrite (rmod_action_action F T).
    rewrite <- (fun_fmap_fmap G1).
    reassociate -> near (dist F G1).
    change (fmap G1 (fmap (F ∘ T) g) ∘ dist F G1)
      with (fmap (G1 ∘ F) (fmap T g) ∘ dist F G1).
    rewrite (dist_natural F).
    reassociate <-. rewrite <- (fun_fmap_fmap G1).
    reassociate -> near (dist F G1).
    unfold_ops @Dist_compose.
    rewrite <- (fun_fmap_fmap G1).
    reassociate <-. reassociate -> near (dist F G1).
    change (fmap G1 (fmap F (dist (A:=?A) T G2)))
      with (fmap (G1 ∘ F) (dist (A:=A) T G2)).
    reassociate -> near (dist F G1).
    rewrite (dist_natural F (G:=G1)).
    repeat reassociate <-. reassociate -> near (dist F G1).
    rewrite <- (dist_linear F).
    change (fmap G1 (fmap G2 ?f)) with (fmap (G1 ∘ G2) f).
    rewrite <- (fun_fmap_fmap (G1 ∘ G2)).
    reassociate -> near (dist F (G1 ∘ G2)).
    change (fmap (G1 ∘ G2) (fmap F ?f)) with (fmap ((G1 ∘ G2) ∘ F) f).
    #[local] Set Keyed Unification.
    rewrite (dist_natural F (G := G1 ∘ G2)).
    reassociate <-. reassociate -> near (fmap F f).
    rewrite (fun_fmap_fmap F).
    reassociate ->.
    rewrite (fun_fmap_fmap F).
    reassociate ->.
    rewrite (fun_fmap_fmap F).
    reassociate <-.
    rewrite (fun_fmap_fmap G1).
    reassociate <-. rewrite (fun_fmap_fmap G1).
    #[local] Unset Keyed Unification.
    reflexivity.
  Qed.

End KleisliTraversableModule_subt.

(** ** Respectfulness properties *)
(******************************************************************************)
Section TraversableModule_respectfulness.

  Context
    (F : Type -> Type)
    `{TraversableModule F T}
    `{Applicative G}.

  Corollary subt_respectful {A B} : forall t (f g : A -> G (T B)),
      (forall a, a ∈ t -> f a = g a) -> subt F f t = subt F g t.
  Proof.
    intros. unfold subt, compose. fequal. fequal.
    now apply (fmap_respectful F).
  Qed.

  Corollary subt_respectful_id {A} : forall t (f : A -> G (T A)),
      (forall a, a ∈ t -> f a = pure G (ret T a)) -> subt F f t = pure G t.
  Proof.
    intros. rewrite <- (traverse_id_purity F).
    rewrite (traverse_to_subt F T).
    apply subt_respectful. unfold compose.
    now setoid_rewrite (app_pure_natural G).
  Qed.

End TraversableModule_respectfulness.

(** * Traversable modules are listable *)
(******************************************************************************)
Section TraversableModule_listable.

  Context
    `{TraversableModule F T}.

  Theorem tolist_right_action : forall A : Type,
      tolist F ∘ right_action F =
      join list ∘ tolist F ∘ fmap F (tolist T) (A := T A).
  Proof.
    intros. rewrite 2(traversable_tolist_spec F False).
    rewrite (traversable_tolist_spec T False).
    unfold traverse. reassociate -> on left.
    rewrite (natural (ϕ := @right_action F T _)).
    reassociate <- on left. rewrite (trvmod_action F T (G := const (list A))).
    change (fmap (const (list A)) (right_action F) ∘ ?f) with f.
    rewrite <- (fun_fmap_fmap F).
    repeat reassociate <-. fequal.
    unfold_ops @Dist_compose. fequal.
    rewrite <- (dist_morph F (ϕ := (fun X : Type => @join list Join_list A))).
    reassociate -> on right. rewrite (fun_fmap_fmap F).
    rewrite (mon_join_ret list). rewrite (fun_fmap_id F).
    change (?f ∘ id) with f.
    now rewrite (dist_const1 F (T False) (M := list A)).
  Qed.

  #[export] Instance ListableModule_Traversable : ListableModule F T.
  Proof.
    constructor; try typeclasses eauto.
    - apply tolist_right_action.
  Qed.

End TraversableModule_listable.


Require Import Evect.

Section Vectorial_Cauchy.
Variable V : Type.
Variable N : V -> R.
Variable (vO:V).
Variable vadd : V->V->V.
Variable smul : R->V->V.
Variable dim : nat.
Variable base : nat -> V.
Variable p : nat -> V -> R.

Hypothesis vect_space : R_vector_space N vO vadd smul dim base p.

(* Cauchy Lipschtz for an autonomous patacouffin TODO *)
Lemma Cauchy_autonomous : forall (f : V -> V) (I : R -> Prop) (K : V -> Prop) (open : Open_space vect_space K)
  (t0 : R) (x0 : V),
  K x0 -> VVcontinuity f open -> lipschitz f open ->
  {x : R -> V & {C : VC vect_space 1 I x | forall (t : R), I t -> (K (x t)) /\ (Vderive (VC_derivable C)) t = f (x t) /\ x t0 = x0}}.
Proof.
intros f I K openK t0 x0 Hx0K Hfcont lipschitzf.
Abort.

End Vectorial_Cauchy.


Require Import
        Coq.Strings.String
        Coq.Arith.Mult
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Common.DecideableEnsembles
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.BinLib.AlignedByteString
        Fiat.Narcissus.BinLib.AlignedDecoders.

Require Import
        Bedrock.Word.

Section AlignedFix.

  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.

  Lemma byte_align_Fix_encode {A}
        (lt_A : A -> A -> Prop)
        (wf_lt_A : well_founded lt_A)
    : forall
      (body : FixComp.funType [A; CacheFormat] (ByteString * CacheFormat)
              -> FixComp.funType [A; CacheFormat] (ByteString * CacheFormat))
      (body' : forall r : A,
          (forall r' : A, lt_A r' r -> FixComp.LeastFixedPointFun.cfunType [CacheFormat] ({n : _ & Vector.t (word 8) n} * CacheFormat)) ->
          FixComp.LeastFixedPointFun.cfunType [CacheFormat] ({n : _ & Vector.t (word 8) n} * CacheFormat))

      (refine_body_OK : forall (r : A)
                               (x : A -> CacheFormat  ->
                                    Comp (ByteString * CacheFormat))
                               (y : forall r' : A,
                                   lt_A r' r ->
                                   CacheFormat ->
                                   {n : _ & Vector.t (word 8) n} * CacheFormat),
          (forall (a' : A) (wf_r : lt_A a' r) (ce : CacheFormat),
              refine (x a' ce)
                     (ret (let (v, ce') := y a' wf_r ce in
                           (build_aligned_ByteString (projT2 v), ce'))))
          -> forall ce, refine (body x r ce) (ret (let (v, ce') := body' r y ce in
                                                   (build_aligned_ByteString (projT2 v), ce'))))

      (body_monotone : forall rec rec' : FixComp.funType [A; CacheFormat] (ByteString * CacheFormat),
          FixComp.refineFun rec rec' -> FixComp.refineFun (body rec) (body rec'))
      (body'_monotone : forall (x0 : A)
                               (f
                                  g : {y : A | lt_A y x0} ->
                                      CacheFormat ->
                                      {n : nat & t (word 8) n} * (CacheFormat)),
          (forall y : {y : A | lt_A y x0}, f y = g y) ->
          body' x0 (fun (a' : A) (lt_a' : lt_A a' x0) => f (exist (fun a'0 : A => lt_A a'0 x0) a' lt_a')) =
          body' x0 (fun (a' : A) (lt_a' : lt_A a' x0) => g (exist (fun a'0 : A => lt_A a'0 x0) a' lt_a')))
      (a : A) (ce : CacheFormat),
      refine (FixComp.LeastFixedPointFun.LeastFixedPoint body a ce)
             (ret (let (v, ce') := Fix wf_lt_A _ body' a ce in
                   (build_aligned_ByteString (projT2 v), ce'))).
  Proof.
    intros.
    unfold FixComp.LeastFixedPointFun.LeastFixedPoint, respectful_hetero; intros.
    simpl.
    revert ce; pattern a; eapply (well_founded_ind wf_lt_A).
    simpl; intros.
    pose proof (proj1 (Frame.Is_GreatestFixedPoint (O := @FixComp.LeastFixedPointFun.funDefOps [A; CacheFormat] (ByteString * CacheFormat)) _ (body_monotone))); etransitivity.
    eapply H0; eauto.
    destruct (Fix wf_lt_A
                  (fun _ : A =>
                     CacheFormat ->
                     {n : nat & t (word 8) n} * (CacheFormat)) body' x ce) eqn: ?.
    pose proof (Fix_eq _ _ wf_lt_A _ (fun a rec => body' a (fun a' lt_a' => rec (exist (fun a' => lt_A a' a) a' lt_a')))).
    simpl in H1; unfold Fix_sub, Fix_F_sub in H1; unfold Fix, Fix_F in Heqp.
    rewrite H1 in Heqp; simpl in Heqp; clear H1; eauto.
    etransitivity.
    eapply refine_body_OK.
    instantiate (1 := (fun (a' : A) (_ : lt_A a' x) =>
                         (fix Fix_F_sub (x0 : A) (r : Acc lt_A x0) {struct r} :
                            CacheFormat ->
                            {n : nat & t (word 8) n} * (CacheFormat) :=
                            body' x0 (fun (a'0 : A) (lt_a'0 : lt_A a'0 x0) => Fix_F_sub a'0 (Acc_inv r lt_a'0))) a'
                                                                                (wf_lt_A a'))).
    eapply H; eauto.
    rewrite Heqp; reflexivity.
  Qed.

  Lemma byte_align_Fix_encode_inv {A}
        (A_OK : A -> Prop)
        (lt_A : _ -> _ -> Prop)
        (wf_lt_A : well_founded lt_A)
    : forall
      (body : FixComp.funType [A; CacheFormat] (ByteString * CacheFormat)
              -> FixComp.funType [A; CacheFormat] (ByteString * CacheFormat))
      (body' : forall r : { a : _ & A_OK a},
          (forall r' : { a : _ & A_OK a},
              lt_A r' r
              -> FixComp.LeastFixedPointFun.cfunType [CacheFormat] ({n : _ & Vector.t (word 8) n} * CacheFormat)) ->
          FixComp.LeastFixedPointFun.cfunType [CacheFormat] ({n : _ & Vector.t (word 8) n} * CacheFormat))
      (refine_body_OK : forall (r : { a : _ & A_OK a})
                               (x : A -> CacheFormat ->
                                    Comp (ByteString * CacheFormat))
                               (y : forall r' : { a : _ & A_OK a},
                                   lt_A r' r ->
                                   CacheFormat ->
                                   {n : _ & Vector.t (word 8) n} * CacheFormat),
          (forall (a' : { a : _ & A_OK a}) (wf_r : lt_A a' r) (ce : CacheFormat),
              refine (x (projT1 a') ce)
                     (ret (let (v, ce') := y a' wf_r ce in
                           (build_aligned_ByteString (projT2 v), ce'))))
          -> forall ce, refine (body x (projT1 r) ce) (ret (let (v, ce') := body' r y ce in
                                                            (build_aligned_ByteString (projT2 v), ce'))))

      (body_monotone : forall rec rec' : FixComp.funType [A; CacheFormat] (ByteString * CacheFormat),
          FixComp.refineFun rec rec' -> FixComp.refineFun (body rec) (body rec'))
      (body'_monotone : forall (x0 : { a : _ & A_OK a})
                               (f
                                  g : {y : { a : _ & A_OK a} | lt_A y x0} ->
                                      CacheFormat ->
                                      {n : nat & t (word 8) n} * (CacheFormat)),
          (forall y : {y : { a : _ & A_OK a} | lt_A y x0}, f y = g y) ->
          body' x0 (fun (a' : { a : _ & A_OK a}) (lt_a' : lt_A a' x0) => f (exist (fun a'0 : { a : _ & A_OK a} => lt_A a'0 x0) a' lt_a')) =
          body' x0 (fun (a' : { a : _ & A_OK a}) (lt_a' : lt_A a' x0) => g (exist (fun a'0 : { a : _ & A_OK a} => lt_A a'0 x0) a' lt_a')))
      (a : A) (ce : CacheFormat) (a_OK : A_OK a),
      refine (FixComp.LeastFixedPointFun.LeastFixedPoint body a ce)
             (ret (let (v, ce') := Fix wf_lt_A _ body' (existT _ _ a_OK) ce in
                   (build_aligned_ByteString (projT2 v), ce'))).
  Proof.
    (*(* 8.4 script *)
    intros.
    unfold FixComp.LeastFixedPointFun.LeastFixedPoint, respectful_hetero; intros.
    simpl.
    replace a with (projT1 (existT _ a a_OK)) at 1.
    revert ce; pattern (existT _ a a_OK); eapply (well_founded_ind wf_lt_A).
    simpl; intros.
    pose proof (proj1 (Frame.Is_GreatestFixedPoint (O := @FixComp.LeastFixedPointFun.funDefOps [A; CacheFormat] (ByteString * CacheFormat)) _ (body_monotone))); etransitivity.
    eapply H0; eauto.
    destruct ( Fix wf_lt_A
                   (fun _ : {a0 : A & A_OK a0} =>
                      CacheFormat ->
                      {n : nat & t (word 8) n} * (CacheFormat)) body' x ce) eqn: ?.
    pose proof (Fix_eq _ _ wf_lt_A _ (fun a rec => body' a (fun a' lt_a' => rec (exist (fun a' => lt_A a' a) a' lt_a')))).
    simpl in H1; unfold Fix_sub, Fix_F_sub in H1; unfold Fix, Fix_F in Heqp.
    rewrite H1 in Heqp; simpl in Heqp; clear H1; eauto.
    etransitivity.
    eapply refine_body_OK.
    instantiate (1 := fun (a' : {a0 : A & A_OK a0}) (_ : lt_A a' x) =>
                        (fix Fix_F_sub (x0 : {a0 : A & A_OK a0}) (r : Acc lt_A x0) {struct r} :
                           CacheFormat ->
                           {n : nat & t (word 8) n} * (CacheFormat) :=
                           body' x0 (fun (a'0 : {a0 : A & A_OK a0}) (lt_a'0 : lt_A a'0 x0) => Fix_F_sub a'0 (Acc_inv r lt_a'0))) a'
                                                                                (wf_lt_A a')).
    eapply H; eauto.
    rewrite Heqp; reflexivity.
    reflexivity.
  Qed. *)
    intros. (*8.6 script. *)
    unfold FixComp.LeastFixedPointFun.LeastFixedPoint, respectful_hetero; intros.
    simpl.
    replace a with (projT1 (existT (fun a0 : A => A_OK a0) a a_OK)) at 1 by reflexivity.
    revert ce; pattern (existT (fun a0 : A => A_OK a0) a a_OK); eapply (well_founded_ind wf_lt_A).
    simpl; intros.
    pose proof (proj1 (Frame.Is_GreatestFixedPoint (O := @FixComp.LeastFixedPointFun.funDefOps [A; CacheFormat] (ByteString * CacheFormat)) _ (body_monotone))); etransitivity.
    eapply H0; eauto.
    destruct (Fix wf_lt_A
               (fun _ : {a0 : A & A_OK a0} =>
                CacheFormat ->
                {n : nat & t (word 8) n} * (CacheFormat)) body' x ce) eqn: ?.
    pose proof (Fix_eq _ _ wf_lt_A _ (fun a rec => body' a (fun a' lt_a' => rec (exist (fun a' => lt_A a' a) a' lt_a')))).
    simpl in H1; unfold Fix_sub, Fix_F_sub in H1; unfold Fix, Fix_F in Heqp.
    rewrite H1 in Heqp; simpl in Heqp; clear H1; eauto.
    etransitivity.
    eapply refine_body_OK.
    instantiate (1 := fun (a' : {a0 : A & A_OK a0}) (_ : lt_A a' x) =>
            (fix Fix_F_sub (x0 : {a0 : A & A_OK a0}) (r : Acc lt_A x0) {struct r} :
               CacheFormat ->
               {n : nat & t (word 8) n} * (CacheFormat) :=
               body' x0 (fun (a'0 : {a0 : A & A_OK a0}) (lt_a'0 : lt_A a'0 x0) => Fix_F_sub a'0 (Acc_inv r lt_a'0))) a'
               (wf_lt_A a')).
    simpl; intros; rewrite H; eauto;  reflexivity.
    rewrite Heqp; try reflexivity.
  Qed.

End AlignedFix.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C D Bprimeprime Bprime Dprime : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime C /\ (wd_ Bprime O /\ (wd_ B Bprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O Eprime Bprimeprime /\ (col_ O Eprime Bprime /\ col_ O Eprime Dprime)))))))))))))))) -> col_ O C B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D B1 C1 P Q R V W X : Universe, ((wd_ B1 B /\ (wd_ B D /\ (wd_ B1 D /\ (wd_ A B /\ (wd_ A D /\ (wd_ C D /\ (wd_ C A /\ (wd_ B C /\ (wd_ A B1 /\ (wd_ B1 C1 /\ (wd_ C1 A /\ (wd_ B C1 /\ (wd_ D C1 /\ (wd_ P Q /\ (wd_ Q R /\ (wd_ V W /\ (wd_ W X /\ (wd_ C C1 /\ (wd_ C B1 /\ (col_ C1 C D /\ (col_ A B B1 /\ (col_ B1 D C1 /\ col_ A C C1)))))))))))))))))))))) -> col_ C D A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus lv3 (plus lv2 (Succ Zero)))).
Admitted.
QuickChick conj18synthconj3.


Require Import Coq.Lists.List NArith. Import ListNotations.
Require Import SyDPaCC.Support.List.
From SyDPaCC.Bsml.Model Require Import Core Pid.
Set Implicit Arguments.

Module Make(Import Bsml: BSML)(Import Pid: Pid.TYPE Bsml.Bsp).

  Definition replicate A (x:A) : par A :=
    mkpar(fun _ => x).
  #[export] Hint Unfold replicate : bsml.

  Lemma replicate_spec:
    forall A (x:A) i, get (replicate x) i = x.
  Proof.
    intros; now  autounfold with bsml; autorewrite with bsml.
  Qed.

  Definition parfun A B (f:A->B)(v:par A) : par B :=
    apply (replicate f) v.
  #[export] Hint Unfold parfun : bsml.

  Lemma parfun_spec:
    forall A B (f:A->B) v i, get(parfun f v) i=f(get v i).
  Proof.
    intros; now repeat autounfold with bsml; autorewrite with bsml.
  Qed.

  #[export] Hint Rewrite replicate_spec parfun_spec : bsml.

  Lemma parfun_ext:
    forall A B (f g:A->B) v,
      (forall a, f a = g a) -> parfun f v = parfun g v.
  Proof.
    intros A B f g v H; apply par_eq; intro i;
      autorewrite with bsml; now apply H.
  Qed.

  Definition parfun2 A B C (f:A->B->C)(v:par A)(v':par B) : par C :=
    apply (parfun f v) v'.
  #[export] Hint Unfold parfun2 : bsml.

  Lemma parfun2_spec:
    forall A B C (f:A->B->C) v v' i, get(parfun2 f v v') i=f(get v i)(get v' i).
  Proof.
    intros; now repeat autounfold with bsml; autorewrite with bsml.
  Qed.

  #[export] Hint Rewrite parfun2_spec : bsml.

  Definition put_list A (data: par(list(pid*A))) : par(list A) :=
    let msg := parfun
                 (fun listDstValue dst => assoc dst listDstValue)
                 data in
    let is_some := fun (x:option A) => match x with Some _ => true | _ => false end in
    parfun (fun f => filter_map_some f Pid.pids) (put msg).
  #[export] Hint Unfold put_list : bsml.

  Lemma put_list_spec:
    forall A v i (value:A),
      In value (get (put_list v) i) <-> exists j, in_first (i, value) (get v j).
  Proof.
    assert(forall A l x, In x l <-> In (Some x) (map (@Some A) l)) as Hsome
        by (intros; apply in_map_iff_inj; intros a b H; inversion H; trivial).
    intros A v i value; split; autounfold with bsml; autorewrite with bsml;
      rewrite Hsome, filter_map_some_prop, filter_In, in_map_iff; intro H.
    - destruct H as [ [ src  [ H1 H2] ] H3].
      autorewrite with bsml in H1.
      exists src. rewrite <- assoc_in_first; exact H1.
    - destruct H as [j Hj]; split; auto; exists j; split; autorewrite with bsml.
      + now rewrite assoc_in_first.
      + apply pids_spec.
  Qed.
  #[export] Hint Rewrite put_list_spec: bsml.

End Make.

Module Type TYPE (Import Bsml: BSML)(Import Pid : Pid.TYPE Bsml.Bsp).
  Include Make Bsml Pid.
End TYPE.