Require Import init.

Require Import set.
Require Import order_minmax.

Require Export analysis_norm.
Require Import norm_mult.

(* begin hide *)
Section NormFunction.

Context {U V} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    UM : Mult U,
    UO : One U,
    UD : Div U,
    @PlusComm U UP,
    @PlusAssoc U UP,
    @PlusLid U UP UZ,
    @PlusRid U UP UZ,
    @PlusLinv U UP UZ UN,
    @PlusRinv U UP UZ UN,
    @MultComm U UM,
    @MultAssoc U UM,
    @Ldist U UP UM,
    @Rdist U UP UM,
    @MultLid U UM UO,
    @MultRid U UM UO,
    @MultLinv U UZ UM UO UD,
    @MultRinv U UZ UM UO UD,
    NotTrivial U,

    USM : ScalarMult real U,
    @ScalarComp real U real_mult USM,
    @ScalarId real U real_one USM,
    @ScalarLdist real U UP USM,
    @ScalarRdist real U real_plus UP USM,
    @ScalarLMult real U UM USM,
    @ScalarRMult real U UM USM,

    UA : AbsoluteValue U,
    @AbsDefinite U UA UZ,
    @AbsNeg U UA UN,
    @AbsTriangle U UA UP,
    @AbsPositive U UA,
    @AbsCauchySchwarz U UA UM,
    @AbsMult U UA UM,
    @AbsScalar U UA USM,

    VP : Plus V,
    VZ : Zero V,
    VN : Neg V,
    VM : Mult V,
    VO : One V,
    VD : Div V,
    @PlusComm V VP,
    @PlusAssoc V VP,
    @PlusLid V VP VZ,
    @PlusRid V VP VZ,
    @PlusLinv V VP VZ VN,
    @PlusRinv V VP VZ VN,
    @MultComm V VM,
    @MultAssoc V VM,
    @Ldist V VP VM,
    @Rdist V VP VM,
    @MultLid V VM VO,
    @MultRid V VM VO,
    @MultLinv V VZ VM VO VD,
    @MultRinv V VZ VM VO VD,
    NotTrivial V,

    VSM : ScalarMult real V,
    @ScalarComp real V real_mult VSM,
    @ScalarId real V real_one VSM,
    @ScalarLdist real V VP VSM,
    @ScalarRdist real V real_plus VP VSM,
    @ScalarLMult real V VM VSM,
    @ScalarRMult real V VM VSM,

    VA : AbsoluteValue V,
    @AbsDefinite V VA VZ,
    @AbsNeg V VA VN,
    @AbsTriangle V VA VP,
    @AbsPositive V VA,
    @AbsCauchySchwarz V VA VM,
    @AbsMult V VA VM,
    @AbsScalar V VA VSM
}.

Existing Instance abs_metric.
(* end hide *)
Definition func_bounded {A : U → Prop} (f : set_type A → V)
    := ∃ M, ∀ x, |f x| ≤ M.

Definition func_bounded_around {A : U → Prop} (f : set_type A → V) a
    := ∃ ε M, ∀ x, a ≠ [x|] → open_ball a ε [x|] → |f x| ≤ M.

Theorem func_lim_bounded_around : ∀ (A : U → Prop) (f : set_type A → V) c l,
    func_lim_base f c l → func_bounded_around f c.
Proof.
    intros A f c l f_lim.
    rewrite metric_func_seq_lim in f_lim.
    unfold func_bounded_around.
    classic_contradiction contr.
    rewrite not_ex in contr.
    assert (∀ ε a, ∃ x, c ≠ [x|] ∧ open_ball c ε [x|] ∧ a < |l-f x|) as contr'.
    {
        intros ε a.
        specialize (contr ε).
        rewrite not_ex in contr.
        specialize (contr (a + |l|)).
        rewrite not_all in contr.
        destruct contr as [x contr].
        do 2 rewrite not_impl in contr.
        rewrite nle_lt in contr.
        destruct contr as [x_neq [x_lt ltq]].
        exists x.
        split; [>|split]; [>exact x_neq|exact x_lt|].
        rewrite lt_plus_lrmove in ltq.
        apply (lt_le_trans2 (abs_le_pos _)) in ltq.
        apply (lt_le_trans ltq).
        rewrite abs_minus.
        apply abs_reverse_tri.
    }
    pose (a' n := ex_val (contr' [_|real_n_div_pos n] 1)).
    assert (∀ n, (A - ❴c❵)%set [a' n|]) as a_in.
    {
        intros n.
        split.
        -   exact [|a' n].
        -   rewrite singleton_eq; intros eq.
            unfold a' in eq.
            rewrite_ex_val x [x_neq xH].
            contradiction.
    }
    pose (a n := [_|a_in n]).
    specialize (f_lim a).
    assert (seq_lim (λ n, [a n|]) c) as c_lim.
    {
        unfold a, a'; cbn.
        rewrite metric_seq_lim.
        intros ε ε_pos.
        pose proof (archimedean2 ε ε_pos) as [N N_ltq].
        exists N.
        intros n n_geq.
        rewrite_ex_val x [x_neq [x_lt fx_gt]].
        unfold open_ball in x_lt; cbn in x_lt.
        cbn.
        apply (trans x_lt).
        apply (le_lt_trans2 N_ltq).
        apply le_div_pos; [>apply from_nat_pos|].
        cbn.
        apply le_lplus.
        rewrite <- homo_le2.
        exact n_geq.
    }
    specialize (f_lim c_lim).
    rewrite metric_seq_lim in f_lim.
    specialize (f_lim 1 one_pos) as [N f_lim].
    specialize (f_lim N (refl _)).
    cbn in f_lim.
    unfold a' in f_lim.
    unpack_ex_val x x_eq [x_neq [x_lt ltq]].
    pose proof (trans f_lim ltq) as ltq'.
    subst x.
    apply ltq'.
    apply f_equal.
    apply f_equal.
    apply f_equal.
    apply f_equal.
    apply set_type_eq; reflexivity.
Qed.

Theorem func_bounded_around_plus : ∀ (A : U → Prop) (xf yf : set_type A → V) a,
    func_bounded_around xf a → func_bounded_around yf a →
    func_bounded_around (λ x, xf x + yf x) a.
Proof.
    intros A xf yf a [ε1 [M M_bound]] [ε2 [N N_bound]].
    exists (min ε1 ε2), (M + N).
    intros x x_neq x_in.
    apply (trans (abs_tri _ _)).
    apply le_lrplus.
    -   apply M_bound; [>exact x_neq|].
        apply (lt_le_trans x_in).
        exact (lmin ε1 ε2).
    -   apply N_bound; [>exact x_neq|].
        apply (lt_le_trans x_in).
        exact (rmin ε1 ε2).
Qed.

Theorem func_bounded_around_subset : ∀ (A B : U → Prop)
    (f : set_type A → V) (g : set_type B → V) a (H : A ⊆ B),
    (∀ x, f x = g [[x|] | H [x|] [|x]]) →
    func_bounded_around g a → func_bounded_around f a.
Proof.
    intros A B f g a sub eq [ε [M M_bound]].
    exists ε, M.
    intros [x Ax]; cbn.
    intros neq ltq.
    specialize (M_bound [x|sub x Ax] neq ltq).
    rewrite eq; cbn.
    exact M_bound.
Qed.

Theorem abs_func_lim : ∀ (A : U → Prop) (xf : set_type A → V) c l,
    func_lim_base xf c l → func_lim_base (λ x, |xf x|) c (|l|).
Proof.
    intros A xf c l xf_lim.
    rewrite metric_func_seq_lim in xf_lim.
    rewrite metric_func_seq_lim.
    intros xn xnc.
    apply abs_seq_lim.
    apply xf_lim.
    exact xnc.
Qed.

Theorem func_lim_zero : ∀ (A : U → Prop) (xf : set_type A → V) c,
    func_lim_base (λ x, |xf x|) c 0 → func_lim_base xf c 0.
Proof.
    intros A xf c xf_lim.
    rewrite metric_func_seq_lim in xf_lim.
    rewrite metric_func_seq_lim.
    intros xn xnc.
    apply seq_lim_zero.
    apply xf_lim.
    exact xnc.
Qed.

Theorem func_lim_plus : ∀ (A : U → Prop) (xf yf : set_type A → V)
    (c : U) (x y : V), func_lim_base xf c x → func_lim_base yf c y →
    func_lim_base (λ n, xf n + yf n) c (x + y).
Proof.
    intros A xf yf c x y cx cy.
    rewrite metric_func_seq_lim in *.
    intros xn xnc.
    apply seq_lim_plus.
    -   apply cx.
        exact xnc.
    -   apply cy.
        exact xnc.
Qed.

Theorem func_lim_scalar : ∀ (A : U → Prop) (xf : set_type A → V)
    (a : real) (c : U) (x : V), func_lim_base xf c x →
    func_lim_base (λ n, a · xf n) c (a · x).
Proof.
    intros A xf a c x cx.
    rewrite metric_func_seq_lim in *.
    intros xn xnc.
    apply seq_lim_scalar.
    apply cx.
    exact xnc.
Qed.

Theorem func_lim_neg : ∀ (A : U → Prop) (xf : set_type A → V)
    (c : U) (x : V), func_lim_base xf c x →
    func_lim_base (λ n, -xf n) c (-x).
Proof.
    intros A xf c x cx.
    rewrite metric_func_seq_lim in *.
    intros xn xnc.
    apply seq_lim_neg.
    apply cx.
    exact xnc.
Qed.

Theorem func_lim_mult : ∀ (A : U → Prop) (xf yf : set_type A → V)
    (c : U) (x y : V), func_lim_base xf c x → func_lim_base yf c y →
    func_lim_base (λ n, xf n * yf n) c (x * y).
Proof.
    intros A xf yf c x y cx cy.
    rewrite metric_func_seq_lim in *.
    intros xn xnc.
    apply seq_lim_mult.
    -   apply cx.
        exact xnc.
    -   apply cy.
        exact xnc.
Qed.

Theorem func_lim_constant : ∀ (A : U → Prop) (xf : set_type A → V)
    (a : V) (c : U) (x : V), func_lim_base xf c x →
    func_lim_base (λ n, a * xf n) c (a * x).
Proof.
    intros A xf a c x cx.
    rewrite metric_func_seq_lim in *.
    intros xn xnc.
    apply seq_lim_constant.
    apply cx.
    exact xnc.
Qed.

Theorem func_lim_div : ∀ (A : U → Prop) (xf : set_type A → V)
    (c : U) (x : V), 0 ≠ x → func_lim_base xf c x →
    func_lim_base (λ n, /xf n) c (/x).
Proof.
    intros A xf c x x_nz cx.
    rewrite metric_func_seq_lim in *.
    intros xn xnc.
    apply seq_lim_div; [>|exact x_nz].
    apply cx.
    exact xnc.
Qed.

Theorem func_lim_zero_mult : ∀ (A : U → Prop) (af bf : set_type A → V) c,
    func_bounded_around af c → func_lim_base bf c 0 →
    func_lim_base (λ x, af x * bf x) c 0.
Proof.
    intros A af bf c [[ε ε_pos] [M' M'_bound]] bf_lim.
    assert (∃ M, ∀ x, open_ball c [ε|ε_pos] [x|] → |af x| ≤ M) as [M M_bound].
    {
        classic_case (A c) as [Ac|Anc].
        -   exists (max M' (|af [c|Ac]|)).
            intros [x Ax] x_in.
            classic_case (c = x) as [eq|neq].
            +   subst x.
                rewrite (proof_irrelevance _ Ac).
                apply rmax.
            +   apply (trans2 (lmax _ _)).
                apply M'_bound.
                *   exact neq.
                *   exact x_in.
        -   exists M'.
            intros x.
            apply M'_bound.
            intros contr.
            subst c.
            apply Anc.
            exact [|x].
    }
    rewrite metric_func_seq_lim in *.
    intros xn xnc.
    pose proof xnc as x_lt.
    rewrite metric_seq_lim in xnc.
    specialize (xnc ε ε_pos) as [N xnc].
    rewrite (seq_lim_part _ N) in x_lt.
    rewrite (seq_lim_part _ N).
    apply seq_lim_zero_mult.
    -   exists M.
        intros n.
        apply M_bound.
        apply xnc.
        apply nat_le_self_lplus.
    -   apply bf_lim.
        exact x_lt.
Qed.

Theorem func_lim_zero_mult2 : ∀ (A : U → Prop) (af bf : set_type A → V) c x,
    func_lim_base af c x → func_lim_base bf c 0 →
    func_lim_base (λ x, af x * bf x) c 0.
Proof.
    intros A af bf c x af_lim bf_lim.
    rewrite metric_func_seq_lim in *.
    intros xn xnc.
    apply (seq_lim_zero_mult2 _ _ x).
    -   apply af_lim.
        exact xnc.
    -   apply bf_lim.
        exact xnc.
Qed.
(* begin hide *)
End NormFunction.
(* end hide *)


Require Import Bool Arith List CpdtTactics SfLib LibTactics.
Require Import Coq.Program.Equality.

Set Implicit Arguments.

Require Import Identifier Environment.
Require Import Imperative.

(* Type system *)

Inductive level :=
  | Low : level
  | High : level.

Lemma eq_level_dec: forall l1 l2: level, {l1 = l2} + { l1<>l2 }.
Proof.

  decide equality.
Qed.
Hint Resolve eq_level_dec.

Hint Resolve eq_exp_dec.
Hint Resolve eq_id_dec.

Tactic Notation "level_cases" tactic (first) ident (c):=
  first;
  [Case_aux c "Low" | Case_aux c "High" ].

Inductive flowsto: level -> level -> Prop :=
  | flowsto_sym: forall ℓ, flowsto ℓ ℓ
  | flowsto_ord: flowsto Low High.
Hint Constructors flowsto.

Notation "ℓ '⊑' ℓ'" := (flowsto ℓ ℓ') (at level 35).

Definition typenv := @Env level.

Reserved Notation "'{{' Γ '⊢' e ':' ℓ '}}'" (at level 0, Γ at level 50, e at level 99).
Inductive exp_has_level : typenv -> exp -> level -> Prop :=
  | T_Const : forall Γ n ℓ,
      {{ Γ ⊢ ENum n : ℓ }}
  | T_Id : forall Γ x ℓ,
      (Γ x) = Some ℓ ->
      {{ Γ ⊢ EId x : ℓ  }}
  | T_Plus : forall Γ e1 e2 ℓ,
      {{ Γ ⊢ e1 : ℓ }} ->
      {{ Γ ⊢ e2 : ℓ }} ->
      {{ Γ ⊢ (EPlus e1 e2) : ℓ }}
  | T_Sub  : forall Γ e ℓ ℓ',
      {{ Γ ⊢ e : ℓ }} ->
      ℓ ⊑ ℓ'  ->
      {{ Γ ⊢ e : ℓ' }}
where "'{{' Γ '⊢' e ':' ℓ '}}' " := (exp_has_level Γ e ℓ).

Tactic Notation "exp_has_level_cases" tactic (first) ident (c) :=
 first;
 [Case_aux c "T_Const" | Case_aux c "T_Id" | Case_aux c "T_Plus"  | Case_aux c "T_Sub" ].

(* Volpano-Smith simple typing *)
Reserved Notation  "'-{' Γ ',' pc '⊢' c '}-'" (at level 0, Γ at level 55, pc at level 35).
Inductive cmd_has_type : typenv -> level -> cmd -> Prop :=
 | T_Skip : forall Γ pc,
     -{ Γ, pc ⊢ SKIP }-
 | T_Assign: forall Γ pc x e ℓ ℓ',
     {{ Γ ⊢ e : ℓ }} ->
     Γ x = Some ℓ' ->
     ℓ ⊑ ℓ' ->
     pc ⊑ ℓ' ->
     -{ Γ , pc ⊢ (x::=e) }-
 | T_Seq : forall Γ pc c1 c2,
     -{ Γ, pc ⊢ c1 }- ->
     -{ Γ, pc ⊢ c2 }- ->
     -{ Γ, pc ⊢ c1;;c2 }-
 | T_If : forall Γ pc e ℓ pc' c1 c2,
     {{ Γ ⊢ e : ℓ }} ->
     ℓ ⊑ pc' ->
     pc ⊑ pc' ->
     -{ Γ, pc' ⊢ c1 }- ->
     -{ Γ, pc' ⊢ c2 }- ->
     -{ Γ, pc  ⊢ IFB e THEN c1 ELSE c2 FI }-
 | T_While : forall Γ pc e ℓ pc' c,
     {{ Γ ⊢ e : ℓ }} ->
     ℓ ⊑ pc' ->
     pc ⊑ pc' ->
     -{ Γ, pc' ⊢ c }- ->
     -{ Γ, pc ⊢ WHILE e DO c END }-

where "'-{' Γ ',' pc '⊢' c '}-'" := (cmd_has_type Γ pc c).

Tactic Notation "cmd_has_type_cases" tactic (first) ident (c) :=
 first;
 [
   Case_aux c "T_Skip" | Case_aux c "T_Assign"  | Case_aux c "T_Seq"
 | Case_aux c "T_if" | Case_aux c "T_While" ].

Lemma high_does_not_flow_to_low: ~ High ⊑ Low.
Proof.
  crush; inversion H.
Qed.

Lemma wt_programs_are_not_stop:
  forall Γ pc c,
     -{ Γ, pc ⊢ c }- ->
     c <> STOP.
Proof.
  intros.
  induction H;
    congruence.
Qed.

Hint Resolve wt_programs_are_not_stop.


Require Import
  FSetInterface
  FMapInterface
  FMapList
  ZArith
  Int.

Import Z_as_Int.

Set Implicit Arguments.

(* notation of 2-tuples *)
Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.

(* integers *)
Definition int := Z.

(* keys are integers *)
Definition key := int.

(* avltree inductive type *)
Inductive avltree :=
  | Leaf : avltree
  | Node : key -> avltree -> avltree -> nat -> avltree.
    (* key, left, right, height *)

Definition height (t:avltree) : nat :=
  match t with
    | Leaf => 0
    | Node _ _ _ h => h
  end.

Fixpoint cardinal (t:avltree) : nat :=
  match t with
    | Leaf => 0
    | Node _ l r _ => S (cardinal l + cardinal r)
  end.

Fixpoint nat_max (m n:nat) : nat :=
  match m ?= n with
    | Lt => n
    | Eq => n
    | Gt => m
  end.

Fixpoint nat_eq (m n:nat) : bool :=
  match m ?= n with
    | Eq => true
    | _  => false
  end.

Definition create k l r :=
  Node k l r (nat_max (height l) (height r) + 1).

Definition assert_false := create.

Fixpoint balance k l r : avltree :=
  let hl := height l in
  let hr := height r in
  if nat_eq hl (hr+2) then
      match l with
      | Leaf => assert_false k l r
      | Node lk ll lr _ =>
        if nat_eq (height ll) (height lr) then
          create lk ll (create k lr r)
          else
            match lr with
            | Leaf => assert_false k l r
            | Node lrk lrl lrr _ =>
                create lrk (create lk ll lrl) (create k lrr r)
            end
      end
  else
    if nat_eq hr (hl+2) then
      match r with
        | Leaf => assert_false k l r
        | Node rk rl rr _ =>
          if nat_eq (height rr) (height rl) then
            create rk (create k l rl) rr
          else
            match rl with
              | Leaf => assert_false k l r
              | Node rlk rll rlr _ =>
                  create rlk (create k l rll) (create rk rlr rr)
            end
      end
  else
    create k l r.

Fixpoint remove_min (k:key) (l r:avltree) : avltree * key :=
  match l with
    | Leaf => (r,k)
    | Node lk ll lr lh =>
        let (l',m) := remove_min lk ll lr in
        (balance k l' r, m)
  end.

Fixpoint merge (t s:avltree) : avltree :=
  match t,s with
    | Leaf, _ => s
    | _, Leaf => t
    | _, Node sk sl sr sh =>
        match remove_min sk sl sr with
          (s',k) => balance k sl s'
        end
  end.

Fixpoint insert (k:key) (t:avltree) : avltree :=
  match t with
    | Leaf => Node k Leaf Leaf 1
    | Node k' l r h =>
        match Z.compare k k' with
          | Lt => balance k' (insert k l) r
          | Eq => Node k' l r h
          | Gt => balance k' l (insert k r)
        end
  end.

Fixpoint remove (k:key) (t:avltree) : avltree :=
  match t with
    | Leaf => Leaf
    | Node k' l r h =>
        match Z.compare k k' with
          | Lt => balance k (remove k' l) r
          | Eq => merge l r
          | Gt => balance k l (remove k' r)
        end
  end.

(* want to show that given a certain type of tree,
the resulting tree after a deletion will be 1 less height *)

Theorem test : forall (t : avltree) (m n : nat),
  m > n -> height t > m -> height t > n.
Proof.
  intros.
  apply (gt_trans (height t0) m n ).
  exact H0.
  exact H.
Qed.

Theorem remove_height : forall (t : avltree) (k : key),
  height t >= height (remove k t).
Proof.
  intros.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.priority rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.global.jitter.job rt.model.schedule.global.jitter.schedule
               rt.model.schedule.global.jitter.interference.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module Platform.

  Import Job SporadicTaskset ScheduleOfSporadicTaskWithJitter SporadicTaskset TaskArrival Interference Priority.

  Section Properties.

    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.
    Variable job_jitter: Job -> time.

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

    (* Consider any schedule. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    (* For simplicity, let's define local names. *)
    Let job_is_backlogged := backlogged job_arrival job_cost job_jitter sched.

    Section Execution.

      (* A scheduler is work-conserving iff when a job j is backlogged,
         all processors are busy with other jobs.
         Note: backlogged means that jitter has already passed. *)
      Definition work_conserving :=
        forall j t,
          arrives_in arr_seq j ->
          job_is_backlogged j t ->
          forall cpu, exists j_other,
            scheduled_on sched j_other cpu t.

      (* We also provide an alternative, equivalent definition of work-conserving
         based on counting the number of scheduled jobs. *)
      Definition work_conserving_count :=
        forall j t,
          arrives_in arr_seq j ->
          job_is_backlogged j t ->
          size (jobs_scheduled_at sched t) = num_cpus.

    End Execution.

    Section FP.

      (* An FP policy ...*)
      Variable higher_eq_priority: FP_policy sporadic_task.

      (* ... is respected by the schedule iff every scheduled
         job has higher (or same) priority than (as) a backlogged job. *)
      Definition respects_FP_policy :=
        forall j j_hp t,
          arrives_in arr_seq j ->
          job_is_backlogged j t ->
          scheduled sched j_hp t ->
          higher_eq_priority (job_task j_hp) (job_task j).

    End FP.

    Section JLFP.

      (* A JLFP policy ...*)
      Variable higher_eq_priority: JLFP_policy Job.

      (* ... is respected by the schedule iff at any time t,
         a scheduled job has higher (or same) priority than (as)
         a backlogged job. *)
      Definition respects_JLFP_policy :=
        forall j j_hp t,
          arrives_in arr_seq j ->
          job_is_backlogged j t ->
          scheduled sched j_hp t ->
          higher_eq_priority j_hp j.

    End JLFP.

    Section JLDP.

      (* A JLDP policy ...*)
      Variable higher_eq_priority: JLDP_policy Job.

      (* ... is respected by the schedule iff at any time t,
         a scheduled job has higher (or same) priority than (as)
         a backlogged job. *)
      Definition respects_JLDP_policy :=
        forall j j_hp t,
          arrives_in arr_seq j ->
          job_is_backlogged j t ->
          scheduled sched j_hp t ->
          higher_eq_priority t j_hp j.

    End JLDP.

    Section Lemmas.

      (* 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 that the two definitions of work-conserving are equivalent. *)
      Section EquivalentDefinitions.

        Lemma work_conserving_eq_work_conserving_count :
          work_conserving <-> work_conserving_count.
        Proof.
          unfold work_conserving, work_conserving_count; split.
          {
            intros EX j t ARRin BACK.
            specialize (EX j t ARRin BACK).
            apply eq_trans with (y := size (enum (processor num_cpus)));
              last by rewrite size_enum_ord.
            unfold jobs_scheduled_at.
            apply eq_trans with (y := size ((\cat_(cpu < num_cpus) map (fun x => Some x)
                                              (make_sequence (sched cpu t)))));
              first by rewrite -map_bigcat_ord size_map.
            apply eq_trans with (y := size (\cat_(cpu < num_cpus) [:: sched cpu t])).
            {
              f_equal; apply eq_bigr; intros cpu _.
              destruct (sched cpu t) eqn:SCHED; first by done.
              by specialize (EX cpu); des; move: EX => /eqP EX; rewrite EX in SCHED.
            }
            rewrite size_bigcat_ord.
            apply eq_trans with (y := \sum_(i < num_cpus) 1);
              last by rewrite big_const_ord iter_addn mul1n addn0 size_enum_ord.
            by apply eq_bigr.
          }
          {
            intros SIZE j t ARRin BACK cpu.
            specialize (SIZE j t ARRin BACK).
            destruct ([exists cpu, sched cpu t == None]) eqn:EX; last first.
            {
              apply negbT in EX; rewrite negb_exists in EX.
              move: EX => /forallP ALL; specialize (ALL cpu).
              destruct (sched cpu t) as [j0|] eqn:SOME; last by done.
              by exists j0; apply/eqP.
            }
            {
              move: EX => /existsP [cpu' /eqP EX].
              unfold jobs_scheduled_at in SIZE.
              move: SIZE => /eqP SIZE; rewrite -[size _ == _]negbK in SIZE.
              move: SIZE => /negP SIZE; exfalso; apply SIZE; clear SIZE.
              rewrite neq_ltn; apply/orP; left.
              rewrite size_bigcat_ord.
              rewrite -> big_mkord_ord with (x0 := 0).
              have MKORD := big_mkord (fun x => true); rewrite -MKORD.
              have CAT := big_cat_nat _ (fun x => true).
              rewrite -> CAT with (n := cpu'); [simpl | by done | by apply ltnW, ltn_ord].
              assert (DIFF: exists k, num_cpus = (cpu' + k).+1).
              {
                exists (num_cpus - cpu').-1.
                rewrite -addnS prednK; last by rewrite ltn_subRL addn0 ltn_ord.
                rewrite addnBA; last by apply ltnW, ltn_ord.
                by rewrite addnC -addnBA // subnn addn0.
              }
              des; rewrite {5}DIFF.
              rewrite big_nat_recl; last by apply leq_addr.
              apply leq_trans with (n := (\sum_(0 <= i < cpu') 1) + 1 +
                                         (\sum_(cpu' <= i < cpu' + k) 1));
                last first.
              {
                rewrite 2!big_const_nat 2!iter_addn 2!mul1n addn0 subn0.
                rewrite [cpu' + k]addnC -addnBA // subnn 2!addn0.
                by rewrite -addnA [1 + k]addnC addnA addn1 -DIFF.
              }
              {
                rewrite -addn1 addnC [_ + 1]addnC -addnA.
                apply leq_add; first by done.
                rewrite eq_fun_ord_to_nat; unfold make_sequence at 2; rewrite EX /= add0n.
                apply leq_add; apply leq_sum; ins; unfold fun_ord_to_nat; des_eqrefl; try done;
                by unfold make_sequence; desf.
              }
            }
          }
        Qed.

      End EquivalentDefinitions.

    End Lemmas.

  End Properties.

End Platform.


(* ************************************************************************* *)
(** * Biequivalence

     Marco Maggesi, Niels van der Weide
     July 2019                                                               *)
(* ************************************************************************* *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Unitality.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.Modifications.Examples.Unitality.

Import PseudoFunctor.Notations.

Local Open Scope cat.
Local Open Scope bicategory_scope.

Section Biequivalence.

Definition is_biequivalence_unit_counit {C D : bicat}
           (F : psfunctor C D) (G : psfunctor D C)
  : UU
  := pstrans (comp_psfunctor G F) (id_psfunctor C) ×
     pstrans (comp_psfunctor F G) (id_psfunctor D).

Definition unit_of_is_biequivalence {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           (e : is_biequivalence_unit_counit F G)
  : pstrans (comp_psfunctor G F) (id_psfunctor C)
  := pr1 e.

Definition counit_of_is_biequivalence {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           (e : is_biequivalence_unit_counit F G)
  : pstrans (comp_psfunctor F G) (id_psfunctor D)
  := pr2 e.

Definition is_biequivalence_adjoints {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           (e : is_biequivalence_unit_counit F G)
  : UU
  := left_adjoint_equivalence (unit_of_is_biequivalence e) ×
     left_adjoint_equivalence (counit_of_is_biequivalence e).

Definition is_biequivalence_adjoint_unit {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           {e : is_biequivalence_unit_counit F G}
           (a : is_biequivalence_adjoints e)
  : left_adjoint_equivalence (unit_of_is_biequivalence e)
  := pr1 a.

Definition is_biequivalence_adjoint_counit {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           {e : is_biequivalence_unit_counit F G}
           (a : is_biequivalence_adjoints e)
  : left_adjoint_equivalence (counit_of_is_biequivalence e)
  := pr2 a.

Definition invunit_of_is_biequivalence {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           {e : is_biequivalence_unit_counit F G}
           (a : is_biequivalence_adjoints e)
  : pstrans (id_psfunctor C) (comp_psfunctor G F)
  := left_adjoint_right_adjoint (is_biequivalence_adjoint_unit a).

Definition invcounit_of_is_biequivalence {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           {e : is_biequivalence_unit_counit F G}
           (a : is_biequivalence_adjoints e)
  : pstrans (id_psfunctor D) (comp_psfunctor F G)
  := left_adjoint_right_adjoint (is_biequivalence_adjoint_counit a).

Definition unitcounit_of_is_biequivalence {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           {e : is_biequivalence_unit_counit F G}
           (a : is_biequivalence_adjoints e)
  : invertible_modification
      (comp_pstrans (invunit_of_is_biequivalence a)
                  (unit_of_is_biequivalence e))
      (id_pstrans _).
Proof.
  refine (left_adjoint_counit (is_biequivalence_adjoint_unit a) ,, _).
  exact (left_equivalence_counit_iso (is_biequivalence_adjoint_unit a)).
Defined.

Definition unitunit_of_is_biequivalence {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           {e : is_biequivalence_unit_counit F G}
           (a : is_biequivalence_adjoints e)
  : invertible_modification
      (comp_pstrans (unit_of_is_biequivalence e)
                  (invunit_of_is_biequivalence a))
      (id_pstrans _).
Proof.
  refine (inv_of_invertible_2cell _).
  refine (left_adjoint_unit (is_biequivalence_adjoint_unit a) ,, _).
  exact (left_equivalence_unit_iso (is_biequivalence_adjoint_unit a)).
Defined.

Definition counitunit_of_is_biequivalence {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           {e : is_biequivalence_unit_counit F G}
           (a : is_biequivalence_adjoints e)
  : invertible_modification
      (comp_pstrans (counit_of_is_biequivalence e)
                  (invcounit_of_is_biequivalence a))
      (id_pstrans _).
Proof.
  refine (inv_of_invertible_2cell _).
  refine (left_adjoint_unit (is_biequivalence_adjoint_counit a) ,, _).
  exact (left_equivalence_unit_iso (is_biequivalence_adjoint_counit a)).
Defined.

Definition counitcounit_of_is_biequivalence {C D : bicat}
           {F : psfunctor C D}
           {G : psfunctor D C}
           {e : is_biequivalence_unit_counit F G}
           (a : is_biequivalence_adjoints e)
  : invertible_modification
      (comp_pstrans (invcounit_of_is_biequivalence a)
                  (counit_of_is_biequivalence e))
      (id_pstrans _).
Proof.
  refine (left_adjoint_counit (is_biequivalence_adjoint_counit a) ,, _).
  exact (left_equivalence_counit_iso (is_biequivalence_adjoint_counit a)).
Defined.

Definition is_biequivalence {C D : bicat} (F : psfunctor C D) : UU
  := ∑ (G : psfunctor D C) (e : is_biequivalence_unit_counit F G),
     is_biequivalence_adjoints e.

Definition inv_psfunctor_of_is_biequivalence
           {C D : bicat} {F : psfunctor C D}
           (e : is_biequivalence F)
  : psfunctor D C
  := pr1 e.

Coercion unit_counit_from_is_biequivalence
           {C D : bicat} {F : psfunctor C D}
           (e : is_biequivalence F)
  : is_biequivalence_unit_counit F
      (inv_psfunctor_of_is_biequivalence e)
  := pr12 e.

Coercion adjoints_from_is_biequivalence
           {C D : bicat} {F : psfunctor C D}
           (e : is_biequivalence F)
  : is_biequivalence_adjoints e
  := pr22 e.

Definition biequivalence (C D : bicat) : UU
  := ∑ F : psfunctor C D, is_biequivalence F.

Coercion psfunctor_of_biequivalence {C D : bicat}
         (e : biequivalence C D)
  : psfunctor C D
  := pr1 e.

Coercion is_biequivalence_of_biequivalence {C D : bicat} (e : biequivalence C D)
  : is_biequivalence (psfunctor_of_biequivalence e)
  := pr2 e.

End Biequivalence.

Section Builder.

Context {C D : bicat} (F : psfunctor C D) (G : psfunctor D C)
        (η : pstrans (id_psfunctor C) (comp_psfunctor G F))
        (ηinv : pstrans (comp_psfunctor G F) (id_psfunctor C))
        (ε : pstrans (comp_psfunctor F G) (id_psfunctor D))
        (εinv : pstrans (id_psfunctor D) (comp_psfunctor F G))
        (pη : invertible_modification
               (id_pstrans (comp_psfunctor G F))
               (comp_pstrans ηinv η))
        (qη : invertible_modification
               (comp_pstrans η ηinv)
               (id_pstrans (id_psfunctor C)))
        (pε : invertible_modification
               (id_pstrans (comp_psfunctor F G))
               (comp_pstrans ε εinv))
        (qε : invertible_modification
               (comp_pstrans εinv ε)
               (id_pstrans (id_psfunctor D))).

Definition make_is_biequivalence : is_biequivalence F.
Proof.
  refine (G,, _).
  refine ((ηinv,, ε),, _).
  split.
  - apply equiv_to_isadjequiv.
    + use tpair.
      * use tpair.
        ** exact η.
        ** split.
           *** exact (pr1 pη).
           *** exact (pr1 qη).
      * split.
        ** apply pη.
        ** apply qη.
  - apply equiv_to_isadjequiv.
    + use tpair.
      * use tpair.
        ** exact εinv.
        ** split.
           *** exact (pr1 pε).
           *** exact (pr1 qε).
      * split.
        ** apply pε.
        ** apply qε.
Defined.

End Builder.

Section Builder_From_Unit_Counit.

Context {C D : bicat} (F : psfunctor C D) (G : psfunctor D C)
        (a : is_biequivalence_unit_counit F G)
        (η : pstrans (id_psfunctor C) (comp_psfunctor G F))
        (εinv : pstrans (id_psfunctor D) (comp_psfunctor F G)).

Local Notation "'ηinv'" := (unit_of_is_biequivalence a).
Local Notation "'ε'" := (counit_of_is_biequivalence a).

Context (pη : invertible_modification
                (comp_pstrans ηinv η)
                (id_pstrans (comp_psfunctor G F)))
        (qη : invertible_modification
                (comp_pstrans η ηinv)
                (id_pstrans (id_psfunctor C)))
        (pε : invertible_modification
                (comp_pstrans ε εinv)
                (id_pstrans (comp_psfunctor F G)))
        (qε : invertible_modification
                (comp_pstrans εinv ε)
                (id_pstrans (id_psfunctor D))).

Definition make_is_biequivalence_from_unit_counit : is_biequivalence F.
Proof.
  use make_is_biequivalence.
  - exact G.
  - exact η.
  - exact ηinv.
  - exact ε.
  - exact εinv.
  - exact (inv_of_invertible_2cell pη).
  - exact qη.
  - exact (inv_of_invertible_2cell pε).
  - exact qε.
Defined.

End Builder_From_Unit_Counit.

Section Pointwise.

Context {C D : bicat}
        (HC : is_univalent_2 C)
        (HD : is_univalent_2 D)
        (e : biequivalence C D).

Definition biequivalence_to_object_equivalence
  : ob C ≃ ob D.
Proof.
  pose (F := psfunctor_of_biequivalence e).
  pose (G := inv_psfunctor_of_is_biequivalence e).
  pose (η := is_biequivalence_adjoint_unit (pr2 e)).
  pose (ε := is_biequivalence_adjoint_counit (pr2 e)).
  use make_weq.
  - exact (λ x, F x).
  - use isweq_iso.
    + exact (λ x, G x).
    + intro x.
      cbn.
      apply (isotoid_2_0 (pr1 HC)).
      use tpair.
      * exact (unit_of_is_biequivalence (pr2 e) x).
      * cbn.
        apply (pointwise_adjequiv (unit_of_is_biequivalence (pr2 e))).
        apply η.
    + intro y.
      cbn.
      apply (isotoid_2_0 (pr1 HD)).
      use tpair.
      * exact (counit_of_is_biequivalence (pr2 e) y).
      * cbn.
        apply (pointwise_adjequiv (counit_of_is_biequivalence (pr2 e))).
        apply ε.
Defined.

End Pointwise.

Definition id_is_biequivalence (B : bicat) : is_biequivalence (id_psfunctor B).
Proof.
  use make_is_biequivalence_from_unit_counit.
  - exact (id_psfunctor B).
  - use tpair.
    + apply lunitor_pstrans.
    + apply lunitor_pstrans.
  - apply linvunitor_pstrans.
  - apply linvunitor_pstrans.
  - apply lunitor_linvunitor_pstrans.
  - apply linvunitor_lunitor_pstrans.
  - apply lunitor_linvunitor_pstrans.
  - apply linvunitor_lunitor_pstrans.
Defined.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export Cring.
Require Export Integral_domain.

(* Rational numbers *)
Require Import QArith.

Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq).

Instance Qri : (Ring (Ro:=Qops)).
constructor.
try apply Q_Setoid.
apply Qplus_comp.
apply Qmult_comp.
apply Qminus_comp.
apply Qopp_comp.
 exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc.
 exact Qmult_1_l.  exact Qmult_1_r. apply Qmult_assoc.
 apply Qmult_plus_distr_l.  intros. apply Qmult_plus_distr_r.
reflexivity. exact Qplus_opp_r.
Defined.

Instance Qcri: (Cring (Rr:=Qri)).
red. exact Qmult_comm. Defined.

Lemma Q_one_zero: not (Qeq 1%Q 0%Q).
unfold Qeq. simpl. auto with *. Qed.

Instance Qdi : (Integral_domain (Rcr:=Qcri)).
constructor.
exact Qmult_integral. exact Q_one_zero. Defined.


Theorem ev_sum : forall n m, ev n -> ev m -> ev (n + m).
Proof.
  intros.
  induction H.
  - apply H0.
  - simpl.
    apply ev_SS.
    apply IHev.
Qed.


(**
Auke Booij
Nov. 2017

If [ P ] is a decidable predicate on the natural numbers, then from the existence of a natural
number satisfying [ P ], we can find a natural number satisfying [ P ].
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.NaturalNumbers.
Require Import UniMath.MoreFoundations.Propositions.

Section constr_indef_descr.
  Context
    (P : nat → hProp)
    (P_dec : ∏ n : nat, P n ⨿ ¬ P n)
    (P_inhab : ∃ n : nat, P n).

  Local Definition minimal (n : nat) : UU := ∏ m : nat, P m → (n ≤ m).
  Local Definition isapropminimal (n : nat) : isaprop (minimal n).
  Proof.
    apply impred_isaprop.
    intros m.
    apply isapropimpl.
    apply isasetbool.
  Defined.

  Local Definition min_n_UU : UU := ∑ n : nat, P n × minimal n.

  Local Definition isapropmin_n : isaprop min_n_UU.
  Proof.
    apply isaproptotal2.
    - intros n.
      apply isapropdirprod. apply (P n).
      apply isapropminimal.
    - intros n n' k k'.
      induction k as [p m], k' as [p' m'].
      apply isantisymmnatleh.
      + exact (m n' p').
      + exact (m' n p).
  Defined.

  Local Definition min_n : hProp := make_hProp min_n_UU isapropmin_n.

  Local Definition smaller (n : nat) := ∑ l : nat, P l × minimal l × (l ≤ n)%nat.

  Local Definition smaller_S (n : nat) (k : smaller n) : smaller (S n).
  Proof.
    induction k as [l pmz].
    induction pmz as [p mz].
    induction mz as [m z].
    refine (l,,p,,m,,_).
    refine (istransnatgth _ _ _ _ _).
    apply natgthsnn.
    apply z.
  Defined.

  Local Definition bounded_search (n : nat) : smaller n ⨿ ∏ l : nat, (l ≤ n)%nat → ¬ P l.
  Proof.
    induction n.
    - assert (P 0 ⨿ ¬ P 0) as X.
      apply P_dec.
      induction X as [h|].
      + apply ii1.
        refine (O,,h,,_,,_).
        * intros ? ?. apply natleh0n.
        * apply isreflnatleh.
      + apply ii2. intros l lleq0.
        assert (H : l = O).
        { apply natleh0tois0. assumption. }
        rewrite H. assumption.
    - induction IHn as [|n0].
      + apply ii1. apply smaller_S. assumption.
      + assert (P (S n) ⨿ ¬ P (S n)) as X.
        apply P_dec.
        induction X as [h|].
        * refine (ii1 (S n,,h,,_,,_)).
          -- intros m q.
             assert (((S n) > m)%nat ⨿ (S n ≤ m)) as X.
             apply natgthorleh.
             induction X as [h0|].
             ++ apply fromempty.
                refine (n0 m h0 q).
             ++ assumption.
          -- apply isreflnatleh.
        * apply ii2. intros l q.
          assert ((l > n)%nat ⨿ (l ≤ n)) as X.
          apply natgthorleh.
          induction X as [h|h].
          -- assert (H : l = S n).
             apply isantisymmnatgeh. apply h. apply q. rewrite H. assumption.
          -- exact (n0 l h).
  Defined.

  Local Definition n_to_min_n (n : nat) (p : P n) : min_n.
  Proof.
    assert (smaller n ⨿ ∏ l : nat, (l ≤ n)%nat → ¬ P l) as X.
    apply bounded_search.
    induction X as [lqmz|none].
    - induction lqmz as [l qmz].
      induction qmz as [q mz].
      induction mz as [m z].
      refine (l,,q,,m).
    - apply fromempty.
      refine (none n (isreflnatgeh _ ) p).
  Defined.

  Local Definition prop_n_to_min_n : min_n.
  Proof.
    refine (@hinhuniv (∑ n : nat, P n) _ _ _).
    - induction 1 as [n p]. exact (n_to_min_n n p).
    - exact P_inhab.
  Defined.

  Definition minimal_n : ∑ n : nat, P n.
  Proof.
    induction prop_n_to_min_n as [n pl]. induction pl as [p _].
    exact (n,,p).
  Defined.

End constr_indef_descr.


Require Import ZArith.
Require Import Toy.Naive.usl.implementation.
(* Require Import Toy.Imp. *)
Require Import Toy.Naive.Language.
Require Import Toy.Naive.Embeddings.
Require Import Toy.Naive.BasicRules.
Require Import Coq.Lists.List.
Import T.
Import Denote_Aexp Denote_Bexp Denote_Com.
Import Assertion_Shallow AssertionDerivationRules.
Import Validity tacticforOSA.
Import implementation.
Import BasicRulesSound.

Definition w : var := 1%nat.
Definition v : var := 2%nat.
Definition t : var := 3%nat.
Definition p : var := 4%nat.

Definition initialization : com :=
  CSeq (CAss_load w (ANum 0)) (CAss_load v (AId p)).

Definition loopcontrol : com :=
  CIf (BEq (AId v) (ANum 0)) CBreak CSkip.

Definition loopbody1 : com :=
  CAss_load t (ADeref (APlus (AId v) (ANum 1))).

Definition loopbody2 : com :=
  CAss_store (APlus (AId v) (ANum 1)) (AId w).

Definition loopbody3 : com :=
  CAss_load w (AId v).

Definition loopbody4 : com :=
  CAss_load v (AId t).

Definition loop : com :=
  CFor CSkip (CSeq loopcontrol (CSeq loopbody1 (CSeq loopbody2
    (CSeq loopbody3 loopbody4)))).

Definition listrev : com :=
  CSeq initialization loop.

Definition NULL : Z := -1.

Fixpoint listrep (p : Z) (l : list Z) : Assertion :=
  match l with
    | nil => fun st => p = NULL
    | cons x l' => sepcon (mapsto p x) (exp (fun q => sepcon (mapsto (p + 1) q) (listrep q l')))
  end.

Theorem listrev_spec : forall l x,
  valid (andp (eqp (AId p) x) (listrep x l)) listrev (exp (fun y => (andp (eqp (AId w) y) (listrep y (rev l))))) falsep falsep.
Admitted.


(* Exercises on Category Theory in UniMath *)
(* for lecture by Peter LeFanu Lumsdaine, Thu 2017-12-14 *)
(* School and Workshop on Univalent Maths, Birmingham 2017 *)
(* https://unimath.github.io/bham2017/ *)

Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.Core.Setcategories.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.FinOrdProducts.
Require Import UniMath.CategoryTheory.limits.equalizers.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.limits.binproducts.

(* NOTE: some of these exercises (or parts of them) are straightforward, while other parts are intended to be quite difficult.  So I don’t recomment aiming to complete them in order — if stuck on a difficult part, move on and come back for another attempt later!

Skeleton solutions and hints are provided, to exhibit good tools and techniques for working with categories.  However, you may well want to add extra definitions/lemmas besides the ones suggested in the skeleton. *)

Section Exercise_0.
(** Univalent categories

  Show that in any univalent category, the type of objects has h-level 3 *)

  Proposition isofhlevel3_ob_of_univalent_cat (C : category) (H : is_univalent C)
    : isofhlevel 3 (ob C).
  Proof.
  Admitted.

End Exercise_0.

Section Exercise_1.
(** Non-univalent categories

  Problem: Construct the category with objects the natural numbers, and with maps m->n all functions {1,…,m}->{1,…,n}.  Show that this is a set-category, and that it is NOT univalent.

  Hint: for defining categories (and other large multi-component structures), it’s usually better to define them a few components at a time, following the structure of the definition, as the following skeleton suggests.

  An alternative approach is to go directly for the total structure [Definition nat_category : category], then begin with [use makecategory.] and construct the whole thing in a single interactive proof.  This approach can be good for first finding a proof/construction; but it often causes speed issues down the line, because the resulting term is very large. *)

  Definition nat_category_ob_mor : precategory_ob_mor.
  Proof.
  Admitted.

  Definition nat_category_data : precategory_data.
  Proof.
  Admitted.

  Definition nat_category_is_precategory : is_precategory nat_category_data.
  Proof.
  Admitted.

  Definition nat_category : category.
  Proof.
  Admitted.

  Definition nat_setcategory : setcategory.
  Proof.
  Admitted.

  Proposition nat_category_not_univalent : ¬ (is_univalent nat_category).
  Proof.
  Admitted.

End Exercise_1.

Section Exercise_2.
  (* Exercise 2.1: Define `pointed_disp_cat` with `disp_struct`. *)
  Definition pointed_disp_cat
    : disp_cat SET.
  Proof.
  Admitted.

  (* Exercise 2.2: Define a displayed category on sets of a binary operation on them.
     The displayed objects over `X` are maps `X × X → X` and the displayed morphisms over `f` are proofs that `f` preserves the operation.
   *)
  Definition operation_disp_cat
    : disp_cat SET.
  Proof.
  Admitted.

  (* Using the product of displayed categories, we now define *)
  Definition pointed_operation_disp_cat
    : disp_cat SET.
  Proof.
    use dirprod_disp_cat.
    - exact pointed_disp_cat.
    - exact operation_disp_cat.
  Defined.

  (* This gives rise to a total category *)
  Definition pointed_operation_set
    : category
    := total_category pointed_operation_disp_cat.

  (* For convenience, we define some projection to access the structure *)
  Definition carrier
             (X : pointed_operation_set)
    : hSet
    := pr1 X.

  Definition unit_el
             (X : pointed_operation_set)
    : carrier X.
  Proof.
  Admitted.
  (* Once defined, the following should type check. *)
  (* := pr12 X. *)

  Definition mul
             (X : pointed_operation_set)
    : carrier X → carrier X → carrier X.
  Admitted.
  (* Once defined, the following should type check. *)
  (* := λ x y, pr22 X (x ,, y). *)

  (* Exercise 2.3: Define the category of monoid displayed category.
     Hint: use `disp_full_sub`.
   *)
  Definition monoid_laws_disp_cat
    : disp_cat pointed_operation_set.
  Proof.
  Admitted.

  Definition monoids
    : category
    := total_category monoid_laws_disp_cat.

  (* During the lecture, we already showed that pointed sets are univalent as follows *)
  Definition pointed_is_univalent_disp
    : is_univalent_disp pointed_disp_cat.
  Proof.
  Admitted.
  (* Once everything is in place, the following proof should work. *)
  (*
    apply is_univalent_disp_from_fibers.
    intros X x₁ x₂.
    use isweqimplimpl.
    - intros f.
      apply f.
    - apply X.
    - apply isaproptotal2.
      + intro.
        apply isaprop_is_iso_disp.
      + intros p q r₁ r₂.
        apply X.
  Defined.
   *)

  (* Exercise 2.4: Show that each part gives rise to a displayed univalent category and conclude that the total category is univalent.
     Hint: adapt the proof from the lecture notes.
   *)
  Definition operation_is_univalent_disp
    : is_univalent_disp operation_disp_cat.
  Proof.
    apply is_univalent_disp_from_fibers.
  Admitted.

  (* Now we conclude *)
  Definition pointed_operation_is_univalent_disp
    : is_univalent_disp pointed_operation_disp_cat.
  Proof.
    use dirprod_disp_cat_is_univalent.
    - exact pointed_is_univalent_disp.
    - exact operation_is_univalent_disp.
  Defined.

  Definition pointed_operation_is_univalent
    : is_univalent pointed_operation_set.
  Proof.
    apply is_univalent_total_category.
    - exact is_univalent_HSET.
    - exact pointed_operation_is_univalent_disp.
  Defined.

  (* Exercise 2.5: conclude that the category of monoids is univalent. *)
  Definition monoid_is_univalent_disp
    : is_univalent_disp monoid_laws_disp_cat.
  Proof.
  Admitted.

  Definition monoids_is_univalent
    : is_univalent monoids.
  Proof.
    apply is_univalent_total_category.
    - exact pointed_operation_is_univalent.
    - exact monoid_is_univalent_disp.
  Defined.
End Exercise_2.

Section Exercise_3.
(** Limits and colimits.

  1. Define the empty graph and empty diagram, and show that any limit of the empty diagram is a terminal object in the directly-defined sense.
*)

  Definition empty_graph : graph.
  Proof.
  Admitted.

  Definition empty_diagram (C : category) : diagram empty_graph C.
  Proof.
  Admitted.

  Definition isTerminal_limit_of_empty_diagram
      {C} (L : LimCone (empty_diagram C))
    : isTerminal _ (lim L).
  Proof.
  Admitted.

  (* 2. Show that for a univalent category, “having an initial object” is a property. *)
  Definition isaprop_initial_obs_of_univalent_category
      {C : univalent_category}
    : isaprop (Initial C).
  Proof.
  Admitted.

  (* 3. Show that if a category has equalisers and finite products, then it has pullbacks *)
  Definition pullbacks_from_equalizers_and_products {C : category}
    : Equalizers C -> BinProducts C -> Pullbacks C.
  Proof.
  Admitted.

End Exercise_3.

Section Exercise_4.
(** Functors and natural transformations / monads and adjunctions

Prove that an adjunction induces a monad.  Construct the Kleisli category of a monad.  Show that the Kleisli construction does not preserve univalence: that is, give an example of a monad on a univalent category whose Kleisli category is not univalent. *)

  (* Hint: as usual, it may be helpful to break out parts of these multi-component structures as separate definitions. *)

  Definition monad_from_adjunction {C D : category}
      (F : functor C D) (G : functor D C) (A : are_adjoints F G)
    : Monad C.
  Proof.
  Admitted.

  Definition kleisli_cat {C : category} (T : Monad C) : category.
  Proof.
    (* see <https://en.wikipedia.org/wiki/Kleisli_category> *)
  Admitted.

  Theorem kleisli_breaks_univalence
    : ∑ (C : univalent_category) (T : Monad C), ¬ is_univalent (kleisli_cat T).
  Proof.
  Admitted.

End Exercise_4.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sum of Data Structures                                                  *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibBool.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Sum type *)

(* ---------------------------------------------------------------------- *)
(** ** Definition *)

(** From the Prelude:

    Inductive sum A B : Type :=
      | inl : A -> sum A B
      | inr : B -> sum A B.

    Hint Constructors sum : core.
    Notation "x + y" := (sum x y) : type_scope.

  Remark: ideally, constructors would be renamed to [sum_l] and [sum_r];
  to follow conventions.

*)

Arguments inl {A} {B}.
Arguments inr {A} {B}.

(* ---------------------------------------------------------------------- *)
(** ** Inhabited *)

Instance sum_inhab_l : forall `{Inhab A} B, Inhab (A + B).
Proof using. intros. apply (Inhab_of_val (inl arbitrary)). Qed.

Instance sum_inhab_r : forall `{Inhab B} A, Inhab (A + B).
Proof using. intros. apply (Inhab_of_val (inr arbitrary)). Qed.

Definition Inhab_sum : forall `{Inhab A, Inhab B}, Inhab (A + B).
Proof using. typeclass. Qed.

(* ********************************************************************** *)
(** * Operations *)

(* ---------------------------------------------------------------------- *)
(** ** Testing the branch of the sum *)

Definition is_inl (A B : Type) (x : A + B) : bool :=
  match x with
  | inl _ => true
  | inr _ => false
  end.

Definition is_inr (A B : Type) (x : A + B) : bool :=
  match x with
  | inl _ => false
  | inr _ => true
  end.

Section IsIn.
Variables (A B : Type).
Implicit Type x : A + B.

Lemma is_inl_neg_is_inr : forall x,
  is_inl x = ! (is_inr x).
Proof using. intros x. destruct~ x. Qed.

Lemma is_inr_neg_is_inl : forall x,
  is_inr x = ! (is_inl x).
Proof using. intros x. destruct~ x. Qed.

End IsIn.

(*-----------------------------------------------------*)
(** ** Stripping of the branch tag *)

Section Get.
Context `{IA1:Inhab A1} `{IA2:Inhab A2}.
Implicit Types x : A1+A2.

Definition get21 x :=
  match x with
  | inl x1 => x1
  | inr x2 => arbitrary
  end.

Definition get22 x :=
  match x with
  | inl x1 => arbitrary
  | inr x2 => x2
  end.

End Get.

(*-----------------------------------------------------*)
(** ** Lifting functions over sum types *)

Section Fget.
Context {A1:Type} {A2:Type} `{IB1:Inhab B1} `{IB2:Inhab B2}.
Implicit Types f : A1+A2->B1+B2.

Definition fun_get21 f :=
  fun x => get21 (f (inl x)).
Definition fun_get22 f :=
  fun x => get22 (f (inr x)).

End Fget.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Strict version of the prefix *)
Definition is_strict_prefix {T: eqType} (bc bc' : seq T) :=
  exists b bc1, bc' = bc ++ (b :: bc1).

Notation "'[' bc1 '<<<' bc2 ']'" := (is_strict_prefix bc1 bc2).

Lemma isp_mt {T: eqType} (bc : seq T) : ~ is_strict_prefix bc [::].
Proof. by case=>b[bc1]; case: bc. Qed.

(* The corresponding checker *)
Fixpoint sprefixb {T: eqType} (s1 s2 : seq T) :=
  if s2 is y :: s2' then
    if s1 is x :: s1' then (x == y) && (sprefixb s1' s2')
    else true
  else false.

Lemma sprefixP {T: eqType} (bc1 bc2 : seq T):
  reflect [bc1 <<< bc2] (sprefixb bc1 bc2).
Proof.
elim: bc2 bc1=>//=[|b2 bc2 Hi/=]bc1.
- case:bc1=>//=[|b1 bc1]; constructor 2=>//; apply: isp_mt.
case: bc1=>//[|b1 bc1]/=; first by constructor 1; exists b2, bc2.
case X: (b1 == b2)=>/=; last first.
- constructor 2=>[[p]][bc']; rewrite cat_cons; case=>Z; subst b2.
  by rewrite eqxx in X.
- move/eqP: X=>X; subst b2.
case: Hi=>H; [constructor 1|constructor 2].
- by case:H=>x[xs]->; exists x, xs; rewrite cat_cons.
case=>x[xs]; rewrite cat_cons; case=>Z; subst bc2; apply: H.
by exists x, xs.
Qed.

(* Non-strict prefix *)
Definition is_prefix {T :eqType} (bc bc' : seq T) :=
  exists bc1, bc' = bc ++ bc1.

Notation "'[' bc1 '<<=' bc2 ']'" := (is_prefix bc1 bc2).

Lemma bc_pre_refl {T :eqType} (bc : seq T) : [bc <<= bc].
Proof. by exists [::]; rewrite cats0. Qed.

Lemma bc_pre_trans {T :eqType} (bc1 bc2 bc3 : seq T) :
  [bc1 <<= bc2] -> [bc2 <<= bc3] -> [bc1 <<= bc3].
Proof.
case=> a1 H1 [a2] H2; subst bc2.
by rewrite -catA in H2; exists (a1 ++ a2).
Qed.

Lemma bc_spre_nrefl {T :eqType} (bc : seq T) : ~ [bc <<< bc].
Proof.
move=>[h][t]. elim: bc=>[|x xs H]; do? by[rewrite cat0s|case].
Qed.

Lemma bc_spre_trans {T :eqType} (bc1 bc2 bc3 : seq T) :
  [bc1 <<< bc2] -> [bc2 <<< bc3] -> [bc1 <<< bc3].
Proof.
move=>[x][xs]eq [y][ys]eq'. rewrite eq' eq. clear eq eq'.
rewrite/is_strict_prefix. eexists x, (xs ++ y :: ys).
by rewrite -catA.
Qed.

Lemma bc_spre_pre {T :eqType} (bc bc' : seq T) :
  [bc <<< bc'] -> [bc <<= bc'].
Proof. by move=>[] x [] xs=>->; exists (x :: xs). Qed.

Lemma bc_pre_spre {T :eqType} (bc bc' : seq T) :
  [bc <<= bc'] -> [bc <<< bc'] \/ bc == bc'.
Proof.
case; case; first by rewrite cats0=>->; right.
by move=>x xs->; left; eexists x, xs.
Qed.

Lemma bc_pre_both {T :eqType} (bc1 bc2 : seq T) :
  [bc1 <<= bc2] -> [bc2 <<= bc1] -> bc1 == bc2.
Proof.
move=>H1 H2. move: (bc_pre_spre H1) (bc_pre_spre H2). clear H1 H2.
case=>A; case=>B; do? by [].
by move: (bc_spre_nrefl (bc_spre_trans A B)).
by rewrite eq_sym.
Qed.

Lemma bc_spre_both {T :eqType} (bc1 bc2 : seq T) :
  sprefixb bc1 bc2 -> sprefixb bc2 bc1 -> False.
Proof.
by move/sprefixP=>A /sprefixP=>B; move: (bc_spre_nrefl (bc_spre_trans A B)).
Qed.

Lemma bc_prefix_mt {T :eqType} (bc : seq T) : [bc <<= [::]] -> bc == [::].
Proof. by case: bc=>//b bc[x]. Qed.

Lemma bc_sprefix_mt {T :eqType} (bc : seq T) : [bc <<< [::]] -> False.
Proof. by case=>x [] xs; case: bc=>//b bc[x]. Qed.

Fixpoint prefixb {T: eqType} (s1 s2 : seq T) :=
  if s2 is y :: s2' then
    if s1 is x :: s1' then (x == y) && (prefixb s1' s2')
    else true
  else s1 == [::].

Lemma bc_prefixb_mt {T :eqType} (bc : seq T) : prefixb bc [::] -> bc == [::].
Proof. by case: bc=>//b bc[x]. Qed.

Lemma prefixP {T :eqType} (bc1 bc2 : seq T):
  reflect [bc1 <<= bc2] (prefixb bc1 bc2).
Proof.
elim: bc2 bc1=>//=[|b2 bc2 Hi/=]bc1.
- case B: (prefixb bc1 [::]); [constructor 1|constructor 2].
  + by move/bc_prefixb_mt/eqP: B=>->; exists [::].
  by case: bc1 B=>//b bc1/=_[?].
case: bc1=>//[|b1 bc1]; first by constructor 1; exists (b2::bc2).
case X: (b1 == b2)=>/=; rewrite X/=; last first.
- constructor 2=>[[p]]; rewrite cat_cons; case=>Z; subst b2.
  by rewrite eqxx in X.
- move/eqP: X=>X; subst b2.
case: Hi=>H; [constructor 1|constructor 2].
- by case:H=>x->; exists x; rewrite cat_cons.
case=>t; rewrite cat_cons; case=>Z; subst bc2; apply: H.
by exists t.
Qed.

Lemma prb_equiv {T: eqType} (bc1 bc2 : seq T) :
  prefixb bc1 bc2 = (bc1 == bc2) || (sprefixb bc1 bc2).
Proof.
apply/Bool.eq_iff_eq_true; split.
- move/prefixP=>[x]->; case: x=>[|x xs]; first by rewrite cats0 eqxx.
  by apply/orP; right; apply/sprefixP; exists x, xs.
- move/orP; case.
  by move/eqP=><-; apply/prefixP; apply bc_pre_refl.
  by move/sprefixP=>[] x [] xs eq; apply/prefixP; rewrite eq; exists (x :: xs).
Qed.

Notation "'[' bc1 '<<=' bc2 ']'" := (is_prefix bc1 bc2).
Notation "'[' bc1 '<<<' bc2 ']'" := (is_strict_prefix bc1 bc2).

(* Decidable fork *)
Definition fork {T: eqType} (bc1 bc2 : seq T) :=
  ~~[|| sprefixb bc1 bc2, sprefixb bc2 bc1 | bc1 == bc2].

Definition fork_rel {T: eqType} (bc1 bc2 : seq T) :=
  ~ ([bc1 <<= bc2] \/ [bc2 <<= bc1]).

Lemma forkP {T: eqType} (bc1 bc2 : seq T) :
  reflect (fork_rel bc1 bc2) (fork bc1 bc2).
Proof.
case F: (fork bc1 bc2); [constructor 1 | constructor 2].
- move/negP: F=>F; rewrite /fork_rel=>G; apply: F.
  case: G; case=>xs; case: xs=>[| x xs]; rewrite ?cats0=>->;
  do? [by rewrite eqxx ![_ || true]orbC].
  + by apply/orP; left; apply/sprefixP; eexists _, _.
  by apply/orP; right; apply/orP; left; apply/sprefixP; eexists _, _.
move=>G. move/negP: F=>F;apply: F. rewrite /fork_rel in G.
case/orP.
- move/sprefixP=>[x][xs]E; apply: G; subst bc2.
  by left; eexists _.
  by rewrite orbC eq_sym -prb_equiv=>P21; apply: G; right; apply/prefixP.
Qed.

Lemma bc_fork_neq {T: eqType} (bc bc' : seq T) :
  fork bc bc' -> bc != bc'.
Proof.
move=>H; apply/negbT/negP=>Z; move/eqP:Z=>Z; subst bc'.
by case/orP: H; right; rewrite orbC eqxx.
Qed.

Lemma bc_fork_nrefl {T: eqType} (bc : seq T) :
  fork bc bc -> False.
Proof. by move=>H; move: (bc_fork_neq H); move/eqP. Qed.

Lemma bc_fork_sym {T: eqType} (bc bc' : seq T) :
  fork bc bc' -> fork bc' bc.
Proof.
by rewrite/fork; rewrite eq_sym orbCA.
Qed.

Lemma bc_fork_prefix {T: eqType} (a b c : seq T):
  fork a b -> [b <<= c] -> fork a c.
Proof.
move/forkP=>F H; apply/forkP; move: F H.
move/Decidable.not_or.
case=>H2 H1[x] H3; subst c.
elim: x b H1 H2=>[|x xs Hi] b H1 H2.
- by rewrite cats0; case=>H; [apply: H2|apply:H1].
rewrite -cat_rcons; apply: Hi=>H.
- by apply: H1; case: H=>z->; rewrite cat_rcons; eexists _.
- rewrite/is_prefix in H H1 H2.
case: H=>z. elim/last_ind: z=>[|zs z Hi].
- by rewrite cats0=>Z; subst a; apply: H1; exists [:: x]; rewrite cats1.
rewrite -rcons_cat=>/eqP; rewrite eqseq_rcons; move/andP=>[/eqP Z]/eqP Z'.
by subst x b; apply: H2; exists zs.
Qed.

Inductive bc_rel {T : eqType} (bc bc' : seq T) : bool-> bool-> bool-> bool-> Set :=
| CmpBcEq of bc == bc' : bc_rel bc bc' true false false false
| CmpBcFork of fork bc bc' : bc_rel bc bc' false true false false
| CmpBcPre12 of sprefixb bc bc' : bc_rel bc bc' false false true false
| CmpBcPre21 of sprefixb bc' bc: bc_rel bc bc' false false false true.

Lemma bc_relP {T : eqType} (bc bc' : seq T) :
  bc_rel bc bc' (bc == bc') (fork bc bc') (sprefixb bc bc') (sprefixb bc' bc).
Proof.
case Eq: (bc == bc'); case F: (fork bc bc');
case S12: (sprefixb bc bc'); case S21: (sprefixb bc' bc);
do? by [
  constructor |
  contradict Eq; move: (bc_fork_neq F)=>/eqP=>A B; apply A; move/eqP in B |
  contradict Eq; move: (bc_spre_both S12 S21) |
  contradict S12; move/eqP: Eq=><-=>/sprefixP; apply: bc_spre_nrefl |
  contradict S21; move/eqP: Eq=><-=>/sprefixP; apply: bc_spre_nrefl
].
- by contradict F; move/norP=>[] C; rewrite S12 in C.
- by contradict F; move/norP=>[] _=>/norP; elim=>C; rewrite S21 in C.
- by contradict F; rewrite/fork Eq S12 S21.
Qed.


Require Export Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsInterface
               Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsProperties.

Unset Implicit Arguments.

Section IBagSpecs.

  Context {TBag TIndex TItem TSearchTerm : Type}.

  Definition TMap := TIndex -> option TItem.

  Definition ib_RepInv_fact
             (RepInv : TMap -> TBag -> Prop)
             (ibenumerate : TBag -> list TIndex) :=
    forall bag imap imap',
      (forall idx, List.In idx (ibenumerate bag) -> imap idx = imap' idx) ->
      (RepInv imap bag -> RepInv imap' bag).

  Definition ibempty_Preserves_RepInv
             (RepInv  : TMap -> TBag -> Prop)
             (ibempty : TBag) :=
    forall imap, RepInv imap ibempty.

  Definition ibinsert_Preserves_RepInv
             (RepInv   : TMap -> TBag -> Prop)
             (ibinsert : TBag -> TIndex -> TBag) :=
    forall bag imap idx, RepInv imap bag -> RepInv imap (ibinsert bag idx).

  Definition ibdelete_Preserves_RepInv
             (RepInv   : TMap -> TBag -> Prop)
             (ibdelete : TBag -> TSearchTerm -> list TIndex * TBag) :=
    forall bag imap searchterm, RepInv imap bag -> RepInv imap (snd (ibdelete bag searchterm)).

  Definition IBagEnumerateEmpty
             (ibempty     : TBag)
             (ibenumerate : TBag -> list TIndex) :=
    forall idx, ~ List.In idx (ibenumerate ibempty).

  Definition IBagInsertEnumerate
             (RepInv      : TMap -> TBag -> Prop)
             (ibenumerate : TBag -> list TIndex)
             (ibinsert    : TBag -> TIndex -> TBag) :=
    forall bag imap idx,
      RepInv imap bag ->
      Permutation (ibenumerate (ibinsert bag idx)) (idx :: ibenumerate bag).

  Definition IBagCountCorrect
             (RepInv  : TMap -> TBag -> Prop)
             (ibfind  : TBag -> TSearchTerm -> list TIndex)
             (ibcount : TBag -> TSearchTerm -> nat) :=
    forall bag imap searchterm,
      RepInv imap bag ->
      List.length (ibfind bag searchterm) = ibcount bag searchterm.

  Definition IBagMatcher
             (Matcher    : TSearchTerm -> TItem -> bool)
             (imap       : TIndex -> option TItem)
             (searchterm : TSearchTerm)
             (idx        : TIndex) :=
    match imap idx with
    | None      => false
    | Some item => Matcher searchterm item
    end.

  Definition IBagFindCorrect
             (RepInv      : TMap -> TBag -> Prop)
             (Matcher     : TSearchTerm -> TItem -> bool)
             (ibenumerate : TBag -> list TIndex)
             (ibfind      : TBag -> TSearchTerm -> list TIndex) :=
    forall bag imap searchterm,
      RepInv imap bag ->
      Permutation (ibfind bag searchterm)
                  (List.filter (IBagMatcher Matcher imap searchterm) (ibenumerate bag)).

  Definition IBagDeleteCorrect
             (RepInv      : TMap -> TBag -> Prop)
             (Matcher     : TSearchTerm -> TItem -> bool)
             (ibenumerate : TBag -> list TIndex)
             (ibdelete    : TBag -> TSearchTerm -> list TIndex * TBag) :=
    forall bag imap searchterm,
      RepInv imap bag ->
      Permutation (ibenumerate (snd (ibdelete bag searchterm)))
                  (snd (List.partition (IBagMatcher Matcher imap searchterm)
                                       (ibenumerate bag))) /\
      Permutation (fst (ibdelete bag searchterm))
                  (fst (List.partition (IBagMatcher Matcher imap searchterm)
                                       (ibenumerate bag))).

End IBagSpecs.

Class IBag (TBag TIndex TSearchTerm : Type) :=
  { ibempty     : TBag;
    ibenumerate : TBag -> list TIndex;
    ibfind      : TBag -> TSearchTerm -> list TIndex;
    ibinsert    : TBag -> TIndex -> TBag;
    ibcount     : TBag -> TSearchTerm -> nat;
    ibdelete    : TBag -> TSearchTerm -> list TIndex * TBag }.

Class IBagCorrect (TBag TIndex TItem TSearchTerm : Type)
      (RepInv  : (TIndex -> option TItem) -> TBag -> Prop)
      (Matcher : TSearchTerm -> TItem -> bool)
      (IBagImplementation : IBag TBag TIndex TSearchTerm) :=
  { ib_RepInv          : ib_RepInv_fact RepInv ibenumerate;
    ibempty_RepInv     : ibempty_Preserves_RepInv RepInv ibempty;
    ibinsert_RepInv    : ibinsert_Preserves_RepInv RepInv ibinsert;
    ibdelete_RepInv    : ibdelete_Preserves_RepInv RepInv ibdelete;

    ibenumerate_empty  : IBagEnumerateEmpty ibempty ibenumerate;
    ibinsert_enumerate : IBagInsertEnumerate RepInv ibenumerate ibinsert;
    ibcount_correct    : IBagCountCorrect RepInv ibfind ibcount;
    ibfind_correct     : IBagFindCorrect RepInv Matcher ibenumerate ibfind;
    ibdelete_correct   : IBagDeleteCorrect RepInv Matcher ibenumerate ibdelete }.

Class IPool (TPool TIndex TItem : Type) :=
  { pempty : TPool;
    pget   : TPool -> TIndex -> option TItem;
    pput   : TPool -> TIndex -> option TItem -> TPool;
    pfresh : TPool -> TIndex }.

Class IPoolCorrect (TPool TIndex TItem : Type)
      (PoolImplementation : IPool TPool TIndex TItem) :=
  { pempty_correct : forall idx, pget pempty idx = None;
    pput_eq        : forall pool idx item, pget (pput pool idx item) idx = item;
    pput_neq       : forall pool idx idx' item, idx <> idx' ->
                                                pget (pput pool idx item) idx' = pget pool idx';
    pfresh_correct : forall pool, pget pool (pfresh pool) = None }.

Module NatIPool.

  Context {TItem : Type}.

  Require Import
          Coq.FSets.FMapInterface
          Coq.FSets.FMapFacts
          Coq.FSets.FMapAVL
          Coq.Structures.OrderedTypeEx.

  Module Import XMap := FMapAVL.Make Nat_as_OT.
  Module Import XMapFacts := WFacts_fun Nat_as_OT XMap.

  Definition TPool := { ds : (t TItem * nat) |
                        forall idx t, MapsTo idx t (fst ds) -> idx < snd ds }.

  Definition NatIPool_pempty : TPool.
    refine (exist _ (empty TItem, O) _).
    intros idx t. rewrite empty_mapsto_iff. tauto.
  Defined.

  Definition NatIPool_pget (pool : TPool) (idx : nat) :=
    find idx (fst (proj1_sig pool)).

  Definition NatIPool_pput : TPool -> nat -> option TItem -> TPool.
    intros [ [m n] pf].
    refine (fun idx t =>
              match t with
              | None   => exist _ (remove idx m, n) _
              | Some t'=> exist _ (add idx t' m, max n (S idx)) _
              end); simpl in *; intuition.
    - destruct (Peano_dec.eq_nat_dec idx idx0); subst.
      apply NPeano.Nat.max_lt_iff. right. auto with arith.
      apply NPeano.Nat.max_lt_iff. left. eapply pf. eapply add_3. eauto. eauto.
    - eapply pf; eapply remove_3; eauto.
  Defined.

  Definition NatIPool_pfresh (pool : TPool) :=
    snd (proj1_sig pool).

  Lemma NatIPool_pempty_correct :
    forall idx, NatIPool_pget NatIPool_pempty idx = None.
  Proof.
    apply empty_o.
  Qed.

  Lemma NatIPool_pput_eq :
    forall pool idx item, NatIPool_pget (NatIPool_pput pool idx item) idx = item.
  Proof.
    unfold NatIPool_pget, NatIPool_pput.
    intros [ [m n] pf] idx item; destruct item eqn: eq; simpl; subst.
    - eapply add_eq_o; eauto.
    - eapply remove_eq_o; eauto.
  Qed.

  Lemma NatIPool_pput_neq :
    forall pool idx idx' item,
      idx <> idx' ->
      NatIPool_pget (NatIPool_pput pool idx item) idx' = NatIPool_pget pool idx'.
  Proof.
    unfold NatIPool_pget, NatIPool_pput.
    intros [ [m n] pf] idx idx' item; destruct item eqn: eq; simpl; subst; intros.
    - eapply add_neq_o; eauto.
    - eapply remove_neq_o; eauto.
  Qed.

  Lemma NatIPool_pfresh_correct :
    forall pool, NatIPool_pget pool (NatIPool_pfresh pool) = None.
  Proof.
    unfold NatIPool_pget, NatIPool_pfresh; intros [ [m n] pf]; simpl.
    destruct (find (elt:=TItem) n m) eqn: eq; eauto.
    apply find_2 in eq. apply pf in eq. simpl in eq. omega.
  Qed.

  Global Instance NatIPoolAsIPool
    : IPool TPool nat TItem :=
    {| pempty := NatIPool_pempty;
       pget   := NatIPool_pget;
       pput   := NatIPool_pput;
       pfresh := NatIPool_pfresh |}.

  Global Instance NatIPoolAsCorrectIPool
    : IPoolCorrect TPool nat TItem NatIPoolAsIPool :=
    {| pempty_correct := NatIPool_pempty_correct;
       pput_eq        := NatIPool_pput_eq;
       pput_neq       := NatIPool_pput_neq;
       pfresh_correct := NatIPool_pfresh_correct |}.

End NatIPool.

Section IndexedBag.

  Context {TBag TPool TIndex TItem TSearchTerm TUpdateTerm : Type}
          (TIndex_dec : forall idx idx' : TIndex, {idx = idx'} + {idx <> idx'})

          (RepInv : (TIndex -> option TItem) -> TBag -> Prop)
          (Matcher : TSearchTerm -> TItem -> bool)
          (Transform : TUpdateTerm -> TItem -> TItem)

          (IBagImpl : IBag TBag TIndex TSearchTerm)
          (IBagProof : IBagCorrect TBag TIndex TItem TSearchTerm RepInv Matcher IBagImpl)

          (IPoolImpl : IPool TPool TIndex TItem)
          (IPoolProof : IPoolCorrect TPool TIndex TItem IPoolImpl).

  Definition TIndexedBag := prod TBag TPool.

  Definition IndexedBag_bempty := (ibempty, pempty).

  Definition IndexesToItems
             (idxs : list TIndex)
             (pool : TPool) :=
    List.fold_right (fun idx ls => match pget pool idx with
                                   | None      => ls
                                   | Some item => cons item ls
                                   end) nil idxs.

  Definition IndexedBag_benumerate
             (bag : TIndexedBag) :=
    IndexesToItems (ibenumerate (fst bag)) (snd bag).

  Definition IndexedBag_bfind
             (bag : TIndexedBag)
             (searchterm : TSearchTerm) :=
    IndexesToItems (ibfind (fst bag) searchterm) (snd bag).

  Definition IndexedBag_binsert
             (bag : TIndexedBag)
             (item : TItem) :=
    let fresh := pfresh (snd bag) in
    (ibinsert (fst bag) fresh, pput (snd bag) fresh (Some item)).

  Definition IndexedBag_bcount
             (bag : TIndexedBag)
             (searchterm : TSearchTerm) :=
    ibcount (fst bag) searchterm.

  Definition IndexedBag_bdelete
             (bag : TIndexedBag)
             (searchterm : TSearchTerm) :=
    let (deleted, ibag) := ibdelete (fst bag) searchterm in
    (IndexesToItems deleted (snd bag),
     (ibag, List.fold_right (fun idx p => pput p idx None) (snd bag) deleted)).

  Definition IndexedBag_bupdate
             (bag : TIndexedBag)
             (searchterm : TSearchTerm)
             (updateterm : TUpdateTerm) :=
    let matched := ibfind (fst bag) searchterm in
    (IndexesToItems matched (snd bag),
     (fst bag, List.fold_right
                 (fun idx p => match pget p idx with
                               | None      => p
                               | Some item => pput p idx (Some (Transform updateterm item))
                               end) (snd bag) matched)).

  Definition IndexedBag_RepInv
             (bag : TIndexedBag) :=
    RepInv (pget (snd bag)) (fst bag) /\
    forall idx, List.In idx (ibenumerate (fst bag)) <->
                pget (snd bag) idx <> None.

  Definition IndexedBag_ValidUpdate
             (updateterm : TUpdateTerm) :=
    forall ibag imap idx,
      RepInv imap ibag ->
      RepInv (fun i => if TIndex_dec i idx
                       then match imap i with
                            | Some item => Some (Transform updateterm item)
                            | None      => None
                            end
                       else imap i) ibag.

  Lemma IndexedBag_Empty_RepInv :
    IndexedBag_RepInv IndexedBag_bempty.
  Proof.
    unfold IndexedBag_RepInv.
    split. apply ibempty_RepInv.
    intro idx. split.
    - intro asmp. exfalso. apply (ibenumerate_empty idx). assumption.
    - intro asmp. exfalso. apply asmp. apply pempty_correct.
  Qed.

  Lemma IndexedBag_binsert_Preserves_RepInv :
    binsert_Preserves_RepInv IndexedBag_RepInv IndexedBag_binsert.
  Proof.
    unfold binsert_Preserves_RepInv, IndexedBag_binsert, IndexedBag_RepInv.
    intros [ibag pool] item [repi repp]; simpl in *; split.
    - eapply ibinsert_RepInv; eapply ib_RepInv; [ | eauto ].
      intros idx asmp; rewrite pput_neq; eauto.
      intro contra; subst; apply repp in asmp; apply asmp; apply pfresh_correct.
    - intro idx; split; intro asmp.
      + eapply Permutation_in in asmp; try eapply ibinsert_enumerate; eauto.
        inversion asmp. subst. rewrite pput_eq. congruence.
        rewrite pput_neq. apply repp. assumption. intro contra.
        subst. apply repp in H. apply H. apply pfresh_correct.
      + eapply Permutation_in. symmetry. eapply ibinsert_enumerate. eauto.
        destruct (TIndex_dec (pfresh pool) idx); subst.
        * left; eauto.
        * right; apply repp; rewrite pput_neq in asmp; eauto.
  Qed.

  Lemma Permutation_in' :
    forall {A : Type} {l l' : list A} (x : A),
      Permutation l l' -> (List.In x l <-> List.In x l').
  Proof.
    split; intros; eapply Permutation_in; [ | | symmetry | ]; eauto.
  Qed.

  Lemma IndexedBag_bdelete_Preserves_RepInv :
    bdelete_Preserves_RepInv IndexedBag_RepInv IndexedBag_bdelete.
  Proof.
    unfold bdelete_Preserves_RepInv, IndexedBag_bdelete, IndexedBag_RepInv.
    simpl; intros [ibag pool] st [repi repp]; simpl.
    assert (forall idx, List.In idx (ibenumerate (snd (ibdelete ibag st))) ->
                        ~ List.In idx (fst (ibdelete ibag st))).
    { intros idx asmp asmp'.
      pose proof (ibdelete_correct _ _ st repi) as [Hsnd Hfst].
      pose proof (Permutation_in _ Hsnd asmp) as asmp_ls.
      pose proof (Permutation_in _ Hfst asmp') as asmp'_ls.
      apply ListFacts.In_partition_unmatched in asmp_ls.
      apply ListFacts.In_partition_matched in asmp'_ls.
      congruence. }
    rewrite surjective_pairing with (p:=ibdelete ibag st); split; simpl in *.
    - pose proof (ibdelete_RepInv _ _ st repi) as repi'; eapply ib_RepInv; [ | eauto ].
      intros idx asmp; apply H in asmp.
      generalize asmp; apply Common.fold_right_rect; eauto; intros; subst.
      destruct (TIndex_dec b idx); eauto; subst. exfalso. apply asmp0. econstructor. eauto.
      rewrite pput_neq; eauto. apply H0. intro. apply asmp0. econstructor 2. eauto.
    - intro idx; split; intro asmp.
      + pose proof (H _ asmp) as asmp'; generalize asmp'.
        eapply Common.fold_right_rect; eauto; intros; subst. apply repp.
        eapply (fun A f x l H => proj1 (proj1 (@List.filter_In A x f l) H)).
        pose proof (ibdelete_correct _ _ st repi) as [Hdel _].
        rewrite ListFacts.partition_filter_neq in Hdel; eapply Permutation_in; eauto.
        destruct (TIndex_dec b idx); subst; [ rewrite pput_eq | rewrite pput_neq ]; eauto.
        exfalso; apply asmp'0; econstructor; eauto.
        apply H0; intro; apply asmp'0; econstructor 2; eauto.
      + specialize (H idx); pose proof (ibdelete_correct _ _ st repi) as [Hsnd Hfst].
        rewrite ListFacts.partition_filter_neq in Hsnd; rewrite (Permutation_in' idx Hsnd) in *.
        rewrite ListFacts.partition_filter_eq in Hfst; symmetry in Hfst.
        apply PermutationFacts.permutation_filter in Hfst.
        destruct Hfst as [ls [Hfst1 Hfst2] ]. rewrite <- Hfst1 in *.
        apply List.filter_In; rewrite (Permutation_in' idx Hfst2).
        specialize (fun H => proj1 (Permutation_in' idx Hfst2) (proj2 (repp idx) H)); clear repp; intro repp.

        clear H Hfst1 Hfst2 Hsnd.
         induction ls; eauto; simpl in *.
        * exfalso; eauto.
        * destruct (IBagMatcher Matcher (pget pool) st a) eqn: eq; simpl in *.
          { destruct (TIndex_dec a idx); subst; eauto.
            rewrite pput_eq in asmp; congruence. rewrite pput_neq in asmp; eauto.
            specialize (IHls asmp); clear asmp.
            split; [ right | ]; apply IHls; intro; destruct (repp H); try congruence; eauto. }
          { destruct (TIndex_dec a idx); subst; eauto.
            split. tauto. rewrite eq. auto.
            split; [ right | ]; apply IHls; eauto.
            intro. destruct (repp H). congruence. auto. intro.
            destruct (repp H). congruence. auto. }
  Qed.

  Lemma  IndexedBag_bupdate_Preserves_RepInv :
    bupdate_Preserves_RepInv IndexedBag_RepInv IndexedBag_ValidUpdate IndexedBag_bupdate.
  Proof.
    unfold bupdate_Preserves_RepInv, IndexedBag_bupdate, IndexedBag_RepInv, IndexedBag_ValidUpdate.
    simpl; intros [ibag pool] st ut [repi repp]; split; simpl.
    - clear repp; remember (ibfind ibag st) as ls; clear Heqls.
      eapply Common.fold_right_rect; eauto.
      clear repi ls; intros _ idx ls _ asmp.
      remember (List.fold_right (fun (idx : TIndex) (p : TPool) =>
                                   match pget p idx with
                                   | Some item => pput p idx (Some (Transform ut item))
                                   | None => p
                                   end) pool ls) as pool'; clear Heqpool'.
      destruct (pget pool' idx) eqn: eq; eauto.
      specialize (valid_update _ _ idx asmp); clear asmp ls.
      assert ((pget (pput pool' idx (Some (Transform ut t)))) =
              (fun i : TIndex =>
                 if TIndex_dec i idx
                 then
                   match pget pool' i with
                   | Some item => Some (Transform ut item)
                   | None => None
                   end
                 else pget pool' i)) as H; try rewrite H; eauto.
      extensionality idx'; destruct (TIndex_dec idx' idx); subst.
      + rewrite pput_eq; rewrite eq; eauto.
      + rewrite pput_neq; eauto.
    - clear valid_update; intro idx; split; intro asmp.
      + eapply Common.fold_right_rect; simpl; intros; try apply repp; eauto; subst.
        destruct (pget (List.fold_right
                          (fun (idx : TIndex) (p : TPool) =>
                             match pget p idx with
                             | Some item => pput p idx (Some (Transform ut item))
                             | None => p
                             end) pool t) b); eauto.
        destruct (TIndex_dec b idx); subst;
        [ rewrite pput_eq; congruence | rewrite pput_neq ]; eauto.
      + remember (ibfind ibag st) as ls; clear Heqls.
        induction ls; simpl in *. apply repp; eauto.
        destruct (pget (List.fold_right
                          (fun (idx : TIndex) (p : TPool) =>
                             match pget p idx with
                             | Some item => pput p idx (Some (Transform ut item))
                             | None => p
                             end) pool ls) a) eqn: eq.
        * destruct (TIndex_dec a idx); subst. rewrite pput_eq in asmp.
          apply IHls; intro; congruence. rewrite pput_neq in asmp; eauto.
        * apply IHls; intro; congruence.
  Qed.

  Lemma IndexedBag_BagEnumerateEmpty :
    BagEnumerateEmpty IndexedBag_benumerate IndexedBag_bempty.
  Proof.
    unfold IndexedBag_benumerate, IndexedBag_bempty, IndexesToItems.
    hnf; simpl; intros item.
    destruct (ibenumerate ibempty) eqn: eq; eauto.
    exfalso; apply (ibenumerate_empty t); rewrite eq; simpl; eauto.
  Qed.

  Lemma InList_ind_helper :
    forall {A : Type} {P : A -> Prop} {x : A} {xs : list A},
      (forall k, List.In k (x :: xs) -> P k) -> (P x /\ (forall k, List.In k xs -> P k)).
  Proof.
    intros; split; intros; eapply H; simpl; eauto.
  Qed.

  Lemma IndexesToItems_perm :
    forall pool idxs idxs',
      Permutation idxs idxs' ->
      Permutation (IndexesToItems idxs pool) (IndexesToItems idxs' pool).
  Proof.
    unfold IndexesToItems; induction 1; eauto; simpl in *.
    - destruct (pget pool x); eauto.
    - destruct (pget pool x); destruct (pget pool y); eauto; apply perm_swap.
    - eapply perm_trans; eauto.
  Qed.

  Lemma IndexedBag_BagInsertEnumerate :
    BagInsertEnumerate IndexedBag_RepInv IndexedBag_benumerate IndexedBag_binsert.
  Proof.
    unfold IndexedBag_benumerate, IndexedBag_RepInv, IndexedBag_binsert.
    hnf; simpl; intros ins bag [repi repp].
    eapply perm_trans; [ eapply IndexesToItems_perm; try eapply ibinsert_enumerate | ]; eauto.
    simpl; rewrite pput_eq; constructor.
    remember (ibenumerate (fst bag)) as ls; clear Heqls.
    pose proof (fun idx => proj1 (repp idx)) as repp_f; clear repp.
    induction ls; simpl; eauto.
    destruct (InList_ind_helper repp_f) as [repp_f_h repp_f_t]; clear repp_f.
    rewrite pput_neq; eauto.
    destruct (pget (snd bag) a); eauto.
    intro contra; subst; apply repp_f_h; apply pfresh_correct.
  Qed.

  Lemma IndexedBag_BagFindCorrect :
    BagFindCorrect IndexedBag_RepInv IndexedBag_bfind Matcher IndexedBag_benumerate.
  Proof.
    unfold BagFindCorrect, IndexedBag_RepInv, IndexedBag_bfind, IndexedBag_benumerate.
    intros [ibag pool] st [repi _]; simpl in *.
    eapply perm_trans; [ | eapply IndexesToItems_perm; symmetry; eapply ibfind_correct ]; eauto.
    induction (ibenumerate ibag); eauto; simpl.
    unfold IBagMatcher in *; destruct (pget pool a) eqn: eq; simpl in *.
    - destruct (Matcher st t); eauto. simpl. rewrite eq. eapply perm_skip; eauto.
    - eauto.
  Qed.

  Lemma IndexedBag_BagCountCorrect :
    BagCountCorrect IndexedBag_RepInv IndexedBag_bcount IndexedBag_bfind.
  Proof.
    unfold BagCountCorrect, IndexedBag_RepInv, IndexedBag_bcount, IndexedBag_bfind.
    intros [ibag pool] st [repi repp]; simpl in *.
    rewrite <- ibcount_correct; eauto.
    specialize (fun i => proj1 (repp i)); clear repp; intro repp.
    assert (forall i, List.In i (ibfind ibag st) -> pget pool i <> None).
    intros i asmp. apply repp. eapply List.filter_In. eapply Permutation_in.
    eapply ibfind_correct; eauto. eauto.
    induction (ibfind ibag st); eauto.
    destruct (InList_ind_helper H) as [H_h H_t]; clear H.
    simpl; destruct (pget pool a); try congruence. simpl. f_equal.
    apply IHl. eauto.
  Qed.

  Lemma IndexedBag_BagDeleteCorrect :
    BagDeleteCorrect IndexedBag_RepInv IndexedBag_bfind Matcher IndexedBag_benumerate IndexedBag_bdelete.
  Proof.
    unfold BagDeleteCorrect, IndexedBag_benumerate, IndexedBag_bdelete.
    intros [ibag pool] st rep.
    pose proof (IndexedBag_bdelete_Preserves_RepInv _ st rep) as rep_del.
    destruct rep as [repi repp]; destruct rep_del as [_ repp_del].
    rewrite surjective_pairing with (p:=ibdelete ibag st); split; simpl in *.
    - admit.
    - admit.
  Qed.

  Lemma IndexedBag_BagUpdateCorrect :
    BagUpdateCorrect IndexedBag_RepInv IndexedBag_ValidUpdate IndexedBag_bfind Matcher IndexedBag_benumerate Transform IndexedBag_bupdate.
  Proof.
    unfold BagUpdateCorrect, IndexedBag_benumerate, IndexedBag_bupdate.
    simpl; intros [ibag pool] st ut [repi repp]; split; simpl.
    - admit.
    - admit.
  Qed.

  Global Instance IndexedBagAsBag
    : Bag TIndexedBag TItem TSearchTerm TUpdateTerm :=
    {| bempty            := IndexedBag_bempty;
       bfind_matcher     := Matcher;
       bupdate_transform := Transform;

       benumerate := IndexedBag_benumerate;
       bfind      := IndexedBag_bfind;
       binsert    := IndexedBag_binsert;
       bcount     := IndexedBag_bcount;
       bdelete    := IndexedBag_bdelete;
       bupdate    := IndexedBag_bupdate |}.

  Global Instance IndexedBagAsCorrectBag
    : CorrectBag IndexedBag_RepInv IndexedBag_ValidUpdate IndexedBagAsBag :=
    {| bempty_RepInv     := IndexedBag_Empty_RepInv;
       binsert_RepInv    := IndexedBag_binsert_Preserves_RepInv;
       bdelete_RepInv    := IndexedBag_bdelete_Preserves_RepInv;
       bupdate_RepInv    := IndexedBag_bupdate_Preserves_RepInv;

       binsert_enumerate := IndexedBag_BagInsertEnumerate;
       benumerate_empty  := IndexedBag_BagEnumerateEmpty;
       bfind_correct     := IndexedBag_BagFindCorrect;
       bcount_correct    := IndexedBag_BagCountCorrect;
       bdelete_correct   := IndexedBag_BagDeleteCorrect;
       bupdate_correct   := IndexedBag_BagUpdateCorrect |}.

End IndexedBag.


Require Export Iron.SimplePCFa.Value.Exp.
Require Export Iron.SimplePCFa.Value.Subst.
Require Export Iron.SimplePCFa.Value.TyJudge.

(* Weakening the type environment in typine judgements.
   We can insert a new type into the type environment, provided we
   lift existing references to types higher in the stack across
   the new one. *)
Lemma typex_tyenv_insert
 :  forall te ix x t1 t2
 ,  TYPEX te x t1
 -> TYPEX (insert ix t2 te) (liftXX ix x) t1.
Proof.
 intros te ix x t1 t2 HT. gen ix te t1 t2.
 induction x using exp_mutind with
  (PV := fun v1 => forall ix te t1 t2
      ,  TYPEV te v1 t1
      -> TYPEV (insert ix t2 te) (liftXV ix v1) t1);
 rip; inverts_type;
  try (solve [simpl; snorm]).

 Case "XLam".
  simpl.
  apply TvLam.
  rewrite insert_rewind.
  eapply IHx. burn.

 Case "XFix".
  simpl.
  destruct t;  nope.
  destruct t1; nope.
  inverts H.
  apply TvFix.
  rewrite insert_rewind.
  apply IHx; burn.

 Case "XLet".
  simpl.
  apply TxLet; eauto.
  rewrite insert_rewind; auto.

 Case "XApp".
  simpl.
  eapply TxApp; eauto.
Qed.

Lemma typex_tyenv_weaken
 :  forall te x t1 t2
 ,  TYPEX  te        x            t1
 -> TYPEX (te :> t2) (liftXX 0 x) t1.
Proof.
 intros.
 rrwrite (te :> t2 = insert 0 t2 te).
 burn using typex_tyenv_insert.
Qed.

Lemma typev_tyenv_weaken
 :  forall te v t1 t2
 ,  TYPEV  te        v            t1
 -> TYPEV (te :> t2) (liftXV 0 v) t1.
Proof.
 intros.
 rrwrite (te :> t2 = insert 0 t2 te).
 assert (TYPEX (insert 0 t2 te) (liftXX 0 (XVal v)) t1).
  eapply typex_tyenv_insert. eauto.
 inverts H0. auto.
Qed.

Theorem subst_val_exp_ix
 :  forall ix te x1 v2 t1 t2
 ,  get  ix te = Some t2
 -> TYPEX te             x1 t1
 -> TYPEV (delete ix te) v2 t2
 -> TYPEX (delete ix te) (substVX ix v2 x1) t1.
Proof.
 intros. gen ix te v2 t1 t2.
 induction x1 using exp_mutind with
  (PV := fun v1 => forall ix te v2 t1 t2
      ,  get ix te = Some t2
      -> TYPEV te             v1 t1
      -> TYPEV (delete ix te) v2 t2
      -> TYPEV (delete ix te) (substVV ix v2 v1) t1);
  intros; simpl; inverts_type;
   try (solve [snorm; eauto]).

 Case "VVar".
  snorm. subst.
  rewrite H in H4. inverts H4. auto.

  eapply TvVar.
   destruct n.
    omega.
    simpl. snorm. down. eapply get_delete_below. omega.

 Case "VLam".
  apply TvLam.
  rewrite delete_rewind.
  eapply IHx1; eauto.
   simpl.
   apply typev_tyenv_weaken. auto.

 Case "VFix".
  destruct t1. nope.
  destruct t.  nope.
  inverts H0.
  eapply TvFix.
   rewrite delete_rewind.
   eapply IHx1; eauto.
    simpl.
    apply typev_tyenv_weaken. auto.

 Case "XLet".
  eapply TxLet. eauto.
   rewrite delete_rewind.
   eapply IHx1_2; eauto.
    simpl.
    apply typev_tyenv_weaken. auto.
Qed.

Theorem subst_val_exp
 :  forall te x1 t1 v2 t2
 ,  TYPEX  (te :> t2) x1                t1
 -> TYPEV  te         v2                t2
 -> TYPEX  te         (substVX 0 v2 x1) t1.
Proof.
 intros.
 rrwrite (te = delete 0 (te :> t2)).
 eapply subst_val_exp_ix; burn.
Qed.

Theorem subst_val_val
 :  forall te v1 t1 v2 t2
 ,  TYPEV  (te :> t2) v1                t1
 -> TYPEV  te         v2                t2
 -> TYPEV  te         (substVV 0 v2 v1) t1.
Proof.
 intros.
 rrwrite (te = delete 0 (te :> t2)).
 assert (TYPEX (delete 0 (te :> t2)) (substVX 0 v2 (XVal v1)) t1).
  eapply subst_val_exp; eauto.
 snorm. inverts H1. auto.
Qed.