CLRS-Lean
Chapters 1–35 · CLRS Fourth Edition
Chapter 15. Greedy Algorithms

Chapter 15 — Greedy Algorithms

CLRS, fourth edition · Lean 4 formalization

The proofs below use the models and assumptions described in the scope and implementation notes.

Imports

import Mathlib

15.1. Activity Selection

This file gives a first Lean model for the activity-selection problem from CLRS Section 15.1. Activities are closed-open intervals over natural-number time points, represented only by their start and finish fields. A selected list is feasible when every earlier activity in the list finishes before every later one starts.

Main results:

Theorem earliest_finish_minFinish: the executable selector earliest_finish returns an activity whose finish time is minimum in the input list.
Theorem finishSorted_head_minFinish: the head of a finish-time-sorted nonempty activity list is the earliest-finishing available activity.
Theorem greedy_choice_minFinish_preserves_optimal_tail_feasibility: if the greedy activity is compatible with an optimal tail solution, prepending it is feasible.
Theorem greedy_choice_optimal_from_certificate: a certificate-based optimality theorem for the greedy-choice step. The exchange argument is provided as a hypothesis, keeping the theorem honest while still matching the CLRS proof structure.
Theorem finishSorted_greedyChoiceCertificate: on a finish-time-sorted candidate list, the CLRS exchange certificate is derived automatically.
Theorem greedySelect_cons_eq: the executable selector follows the CLRS recursive cons-case equation: choose the first finishing activity and recurse on the filtered compatible tail.
Theorems greedySelect_sublist and greedySelect_feasible: the executable greedy selector always returns activities drawn from the input and arranged feasibly.
Theorem greedySelect_maxCardinality: on a finish-time-sorted input, the executable greedy selector has maximum cardinality among feasible sublists.
Theorem greedySelect_cons_maxCardinality: the nonempty sorted-input recursion theorem, exposing the greedy choice plus optimal recursive subproblem directly.
Theorem greedySelect_after_maxCardinality: the filtered compatible tail is itself solved optimally by the same executable selector.
Theorem greedySelect_optimal_length: a direct reader-facing corollary: every feasible sublist of a finish-time-sorted input has length at most the greedy output.
Definition activitySelection: the CLRS-facing name for the executable greedy selector.
Theorems activitySelection_maxCardinality and activitySelection_cons_maxCardinality: top-level maximum-cardinality certificates for the full input and the nonempty recursive step.
Theorems activitySelection_correct and activitySelection_cons_correct: reader-facing correctness bundles for the full sorted-list input and the nonempty recursive step.
Theorems greedySelect_cons_recursive_correct and activitySelection_cons_recursive_correct: bundled nonempty recursion theorems that expose the exact cons-case equation, optimal recursive tail, optimal full solution, feasibility, sublist membership, and optimal-length inequality in one statement.

Textbook-facing companion modules:

Current gaps:

None for the current finite-list model. A lower-level mutable-array/RAM refinement remains a future extension.

              open Listnamespace CLRSnamespace ActivitySelection

Activities and feasibility

An activity is an interval with a natural-number start time and finish time. The reusable core intentionally does not require start ≤ finish; TextbookModel supplies the exact textbook predicate start < finish without breaking clients of the more general representation.

structure Activity where
  start : Nat
  finish : Nat
  deriving Repr, DecidableEq

Two activities are compatible when one finishes before the other starts. This is the symmetric textbook notion used for unordered sets of selected activities.

def Compatible (a b : Activity) : Prop :=
  a.finish ≤ b.start ∨ b.finish ≤ a.start

Before a b is the oriented compatibility relation used by a selected list: activity a is scheduled before activity b.

def Before (a b : Activity) : Prop :=
  a.finish ≤ b.start

A selected list is feasible when it is in chronological order and every head activity finishes before every activity in the tail starts.

def Feasible : List Activity → Prop
  | [] => True
  | a :: rest => Feasible rest ∧ ∀ b ∈ rest, Before a b

Every activity after a in a feasible a :: rest selection is compatible with a.

theorem compatible_of_before {a b : Activity} (h : Before a b) :
    Compatible a b := by
  exact Or.inl h

The tail of a feasible selected list is feasible.

theorem feasible_tail {a : Activity} {rest : List Activity}
    (h : Feasible (a :: rest)) :
    Feasible rest := by
  exact h.1

Consing an activity onto a feasible tail preserves feasibility when the new activity finishes before every activity in the tail starts.

theorem feasible_cons {a : Activity} {rest : List Activity}
    (hrest : Feasible rest)
    (ha : ∀ b ∈ rest, Before a b) :
    Feasible (a :: rest) := by
  exact ⟨hrest, ha⟩

Earliest finishing activity

MinFinish a xs says that a is an element of xs with minimum finish time among all activities in xs.

def MinFinish (a : Activity) (xs : List Activity) : Prop :=
  a ∈ xs ∧ ∀ b ∈ xs, a.finish ≤ b.finish

A list is sorted by nondecreasing finish time. On such a list, the head is the CLRS earliest-finishing activity among the currently available activities.

def FinishSorted : List Activity → Prop :=
  List.Pairwise fun a b => a.finish ≤ b.finish

Filtering a finish-sorted activity list preserves finish-time order.

theorem finishSorted_filter {p : Activity → Bool} {xs : List Activity}
    (hsorted : FinishSorted xs) :
    FinishSorted (xs.filter p) := by
  exact List.Pairwise.sublist List.filter_sublist hsorted

The head of a nonempty finish-sorted list has minimum finish time.

theorem finishSorted_head_minFinish {a : Activity} {rest : List Activity}
    (hsorted : FinishSorted (a :: rest)) :
    MinFinish a (a :: rest) := by
  rcases (List.pairwise_cons.mp hsorted) with ⟨ha, _hrest⟩
  constructor
  · simp
  · intro b hb
    simp at hb
    rcases hb with rfl | hb
    · rfl
    · exact ha b hb

Select an activity with earliest finish time from a finite list, returning none on the empty list.

def earliest_finish : List Activity → Option Activity
  | [] => none
  | a :: rest =>
      match earliest_finish rest with
      | none => some a
      | some b => if a.finish ≤ b.finish then some a else some b

The earliest-finish selector returns none exactly for the empty list.


theorem earliest_finish_eq_none_iff (xs : List Activity) :
    earliest_finish xs = none ↔ xs = [] := by
  induction xs with
  | nil =>
      simp [earliest_finish]
  | cons a rest ih =>
      rw [earliest_finish]
      cases hrest : earliest_finish rest with
      | none =>
          simp
      | some b =>
          by_cases hab : a.finish ≤ b.finish <;> simp [hab]

The executable selector earliest_finish returns a minimum-finish activity.


theorem earliest_finish_minFinish {xs : List Activity} {a : Activity}
    (h : earliest_finish xs = some a) :
    MinFinish a xs := by
  induction xs generalizing a with
  | nil =>
      simp [earliest_finish] at h
  | cons head rest ih =>
      rw [earliest_finish] at h
      cases hrest : earliest_finish rest with
      | none =>
          have hrest_empty : rest = [] :=
            (earliest_finish_eq_none_iff rest).mp hrest
          subst rest
          simp [earliest_finish] at h
          subst a
          simp [MinFinish]
      | some best =>
          have hbest : MinFinish best rest := ih hrest
          by_cases hhead : head.finish ≤ best.finish
          · simp [hrest, hhead] at h
            subst a
            constructor
            · simp
            · intro b hb
              simp at hb
              rcases hb with rfl | hb
              · rfl
              · exact Nat.le_trans hhead (hbest.2 b hb)
          · simp [hrest, hhead] at h
            subst a
            have hbest_head : best.finish ≤ head.finish :=
              Nat.le_of_lt (Nat.lt_of_not_ge hhead)
            constructor
            · simp [hbest.1]
            · intro b hb
              simp at hb
              rcases hb with rfl | hb
              · exact hbest_head
              · exact hbest.2 b hb

Subproblems and greedy selection

The activities still available after choosing a: those whose start time is at least a.finish.

def activitiesAfter (a : Activity) (xs : List Activity) : List Activity :=
  xs.filter fun b => decide (a.finish ≤ b.start)

The post-greedy candidate list is a sublist of the original candidate list.

theorem activitiesAfter_sublist (a : Activity) (xs : List Activity) :
    (activitiesAfter a xs).Sublist xs := by
  unfold activitiesAfter
  exact List.filter_sublist

Membership in activitiesAfter is exactly membership in the source list plus oriented compatibility with the chosen activity.

theorem mem_activitiesAfter {a b : Activity} {xs : List Activity} :
    b ∈ activitiesAfter a xs ↔ b ∈ xs ∧ Before a b := by
  simp [activitiesAfter, Before]

The available list after a greedy choice preserves finish-time ordering.

theorem finishSorted_activitiesAfter {a : Activity} {xs : List Activity}
    (hsorted : FinishSorted xs) :
    FinishSorted (activitiesAfter a xs) := by
  exact finishSorted_filter hsorted

The CLRS recursive greedy algorithm, parameterized by the list order supplied by the caller. On a list sorted by finish time, the head is an earliest-finishing available activity.

def greedySelect : List Activity → List Activity
  | [] => []
  | a :: rest => a :: greedySelect (activitiesAfter a rest)
termination_by xs => xs.length
decreasing_by
  simp_wf
  dsimp [activitiesAfter]
  have hle :
      (List.filter (fun b => decide (a.finish ≤ b.start)) rest).length ≤ rest.length :=
    List.length_filter_le (fun b => decide (a.finish ≤ b.start)) rest
  omega

Executable recursion equation for the nonempty CLRS activity-selection case: choose the first activity in the finish-time order and recurse on the remaining activities compatible with that choice.


theorem greedySelect_cons_eq (a : Activity) (rest : List Activity) :
    greedySelect (a :: rest) = a :: greedySelect (activitiesAfter a rest) := by
  rw [greedySelect.eq_def]

CLRS-facing wrapper around the executable recursive selector. Keeping this name separate lets the proof expose greedySelect as the implementation while readers cite activitySelection as the algorithm.

def activitySelection (xs : List Activity) : List Activity :=
  greedySelect xs

The public algorithm name is definitionally the greedy recursive selector.

theorem activitySelection_eq_greedySelect (xs : List Activity) :
    activitySelection xs = greedySelect xs := by
  rfl

CLRS-facing recursion equation for nonempty finish-time ordered input.

theorem activitySelection_cons_eq (a : Activity) (rest : List Activity) :
    activitySelection (a :: rest) = a :: activitySelection (activitiesAfter a rest) := by
  simp [activitySelection, greedySelect_cons_eq]

The executable greedy selector returns only activities from the input list.


theorem greedySelect_sublist (xs : List Activity) :
    (greedySelect xs).Sublist xs := by
  induction xs using greedySelect.induct with
  | case1 =>
      simp [greedySelect]
  | case2 a rest ih =>
      rw [greedySelect.eq_def]
      exact List.Sublist.cons_cons a
        (List.Sublist.trans ih (activitiesAfter_sublist a rest))

The executable greedy selector always returns a feasible chronologically ordered activity list.


theorem greedySelect_feasible (xs : List Activity) :
    Feasible (greedySelect xs) := by
  induction xs using greedySelect.induct with
  | case1 =>
      simp [greedySelect, Feasible]
  | case2 a rest ih =>
      rw [greedySelect.eq_def]
      apply feasible_cons ih
      intro b hb
      have hsub :
          (greedySelect (activitiesAfter a rest)).Sublist
            (activitiesAfter a rest) :=
        greedySelect_sublist (activitiesAfter a rest)
      exact (mem_activitiesAfter.mp (hsub.subset hb)).2

Maximum-cardinality certificates

MaxCardinality available selected says that selected is a feasible sublist of available and no feasible sublist of available has larger cardinality.

structure MaxCardinality (available selected : List Activity) : Prop where
  sublist : selected.Sublist available
  feasible : Feasible selected
  maximum :
    ∀ other, other.Sublist available → Feasible other →
      other.length ≤ selected.length

A one-step greedy-choice certificate. The field exchange is the CLRS exchange argument: every feasible competitor can be converted, without losing cardinality, into one that starts with the chosen greedy activity and then uses only the after subproblem.

structure GreedyChoiceCertificate
    (available after selected : List Activity) (a : Activity) : Prop where
  chosen_sublist : (a :: selected).Sublist available
  selected_after : ∀ b ∈ selected, Before a b
  exchange :
    ∀ other, other.Sublist available → Feasible other →
      ∃ tail, tail.Sublist after ∧ Feasible tail ∧
        other.length ≤ (a :: tail).length

If a feasible competitor starts with first, and the greedy activity a has minimum finish time in the sorted available list, then the competitor's tail is available after choosing a.


theorem feasible_competitor_tail_sublist_after
    {a first : Activity} {tail rest : List Activity}
    (hmin : MinFinish a (a :: rest))
    (hsub : (first :: tail).Sublist (a :: rest))
    (hbefore : ∀ b ∈ tail, Before first b) :
    tail.Sublist (activitiesAfter a rest) := by
  have hfirst_mem : first ∈ a :: rest :=
    hsub.subset (by simp)
  have ha_first : a.finish ≤ first.finish :=
    hmin.2 first hfirst_mem
  have htail_rest : tail.Sublist rest :=
    hsub.tail
  unfold activitiesAfter
  refine (List.sublist_filter_iff).2 ?_
  refine ⟨tail, htail_rest, ?_⟩
  have hfilter :
      tail.filter (fun b => decide (a.finish ≤ b.start)) = tail := by
    exact List.filter_eq_self.2 (by
      intro b hb
      have hfirst_b : first.finish ≤ b.start := hbefore b hb
      have ha_b : a.finish ≤ b.start := Nat.le_trans ha_first hfirst_b
      simp [ha_b])
  exact hfilter.symm

On a finish-time-sorted nonempty candidate list, the textbook exchange argument is no longer an external assumption: every feasible competitor can be rewritten as the greedy activity followed by a feasible tail from the filtered subproblem.

theorem finishSorted_greedyChoiceCertificate
    {a : Activity} {rest selected : List Activity}
    (hsorted : FinishSorted (a :: rest))
    (hselected_sub : selected.Sublist (activitiesAfter a rest)) :
    GreedyChoiceCertificate (a :: rest) (activitiesAfter a rest) selected a := by
  refine ⟨?_, ?_, ?_⟩
  · exact List.Sublist.cons_cons a
      (List.Sublist.trans hselected_sub (activitiesAfter_sublist a rest))
  · intro b hb
    exact (mem_activitiesAfter.mp (hselected_sub.subset hb)).2
  · intro other hsub hfeasible
    cases other with
    | nil =>
        refine ⟨[], by simp [activitiesAfter], by simp [Feasible], ?_⟩
        simp
    | cons first tail =>
        have hmin : MinFinish a (a :: rest) :=
          finishSorted_head_minFinish hsorted
        have htail_sub :
            tail.Sublist (activitiesAfter a rest) :=
          feasible_competitor_tail_sublist_after hmin hsub hfeasible.2
        exact ⟨tail, htail_sub, hfeasible.1, by simp⟩

Greedy-choice feasibility. If a has minimum finish time among the available activities and an optimal tail solution is compatible with a, then prepending a preserves feasibility.

The minimum-finish hypothesis records the CLRS greedy choice; feasibility itself uses only the compatibility of the chosen tail.

theorem greedy_choice_minFinish_preserves_optimal_tail_feasibility
    {available after selected : List Activity} {a : Activity}
    (hmin : MinFinish a available)
    (hopt : MaxCardinality after selected)
    (hafter : ∀ b ∈ selected, Before a b) :
    Feasible (a :: selected) := by
  rcases hmin with ⟨_, _⟩
  exact feasible_cons hopt.feasible hafter

If the tail is maximum-cardinality for the post-greedy subproblem, then every chosen-tail competitor has size at most the greedy choice plus that tail.

theorem chosen_tail_bound_of_tail_optimal
    {after selected tail : List Activity} {a : Activity}
    (hopt : MaxCardinality after selected)
    (htail : tail.Sublist after)
    (hfeasible : Feasible tail) :
    (a :: tail).length ≤ (a :: selected).length := by
  have htail_len : tail.length ≤ selected.length :=
    hopt.maximum tail htail hfeasible
  simpa using Nat.succ_le_succ htail_len

Certificate-based greedy-choice optimality. This is the Lean-friendly version of the CLRS exchange step. Given:

an optimal solution selected for the after subproblem, and
a certificate that every feasible competitor for available can be exchanged for one beginning with a,

the solution a :: selected is maximum-cardinality for available.

theorem greedy_choice_optimal_from_certificate
    {available after selected : List Activity} {a : Activity}
    (hopt : MaxCardinality after selected)
    (hcert : GreedyChoiceCertificate available after selected a) :
    MaxCardinality available (a :: selected) := by
  refine ⟨hcert.chosen_sublist, ?_, ?_⟩
  · exact feasible_cons hopt.feasible hcert.selected_after
  · intro other hsub hfeasible
    rcases hcert.exchange other hsub hfeasible with
      ⟨tail, htail_sub, htail_feasible, hle_exchange⟩
    have htail_bound :
        (a :: tail).length ≤ (a :: selected).length :=
      chosen_tail_bound_of_tail_optimal hopt htail_sub htail_feasible
    exact Nat.le_trans hle_exchange htail_bound

Full finite-list optimality for sorted inputs. If the candidate activities are sorted by nondecreasing finish time, the executable greedy selector returns a feasible sublist of maximum cardinality.


theorem greedySelect_maxCardinality {xs : List Activity}
    (hsorted : FinishSorted xs) :
    MaxCardinality xs (greedySelect xs) := by
  induction xs using greedySelect.induct with
  | case1 =>
      refine ⟨by simp [greedySelect], by simp [greedySelect, Feasible], ?_⟩
      intro other hsub _hfeasible
      have hlen : other.length ≤ ([] : List Activity).length :=
        hsub.length_le
      simpa [greedySelect] using hlen
  | case2 a rest ih =>
      rw [greedySelect.eq_def]
      have hafter_sorted : FinishSorted (activitiesAfter a rest) := by
        rcases (List.pairwise_cons.mp hsorted) with ⟨_ha, hrest_sorted⟩
        exact finishSorted_activitiesAfter hrest_sorted
      have htail_opt :
          MaxCardinality (activitiesAfter a rest)
            (greedySelect (activitiesAfter a rest)) :=
        ih hafter_sorted
      exact greedy_choice_optimal_from_certificate htail_opt
        (finishSorted_greedyChoiceCertificate hsorted htail_opt.sublist)

Top-level CLRS-facing optimality certificate: on finish-time-sorted input, activitySelection is a feasible sublist of maximum cardinality.

theorem activitySelection_maxCardinality {xs : List Activity}
    (hsorted : FinishSorted xs) :
    MaxCardinality xs (activitySelection xs) := by
  simpa [activitySelection] using greedySelect_maxCardinality hsorted

Recursive subproblem optimality. After the greedy choice from a sorted nonempty candidate list, the executable selector is maximum-cardinality for the filtered compatible tail.

theorem greedySelect_after_maxCardinality {a : Activity} {rest : List Activity}
    (hsorted : FinishSorted (a :: rest)) :
    MaxCardinality (activitiesAfter a rest)
      (greedySelect (activitiesAfter a rest)) := by
  have hrest_sorted : FinishSorted rest :=
    (List.pairwise_cons.mp hsorted).2
  exact greedySelect_maxCardinality (finishSorted_activitiesAfter hrest_sorted)

Nonempty sorted-input recursion theorem. The CLRS greedy choice followed by the recursively optimal compatible tail is itself maximum-cardinality for the whole candidate list.

theorem greedySelect_cons_maxCardinality {a : Activity} {rest : List Activity}
    (hsorted : FinishSorted (a :: rest)) :
    MaxCardinality (a :: rest) (a :: greedySelect (activitiesAfter a rest)) := by
  simpa [greedySelect_cons_eq] using
    (greedySelect_maxCardinality (xs := a :: rest) hsorted)

CLRS-facing nonempty recursion certificate: choose the first finish-sorted activity, recursively solve its compatible tail, and obtain a maximum-cardinality solution for the original candidate list.

theorem activitySelection_cons_maxCardinality {a : Activity} {rest : List Activity}
    (hsorted : FinishSorted (a :: rest)) :
    MaxCardinality (a :: rest) (a :: activitySelection (activitiesAfter a rest)) := by
  simpa [activitySelection] using greedySelect_cons_maxCardinality hsorted

Reader-facing optimality corollary. On finish-time-sorted inputs, any feasible sublist has cardinality at most the executable greedy selection.

theorem greedySelect_optimal_length {xs other : List Activity}
    (hsorted : FinishSorted xs) (hsub : other.Sublist xs)
    (hfeasible : Feasible other) :
    other.length ≤ (greedySelect xs).length :=
  (greedySelect_maxCardinality hsorted).maximum other hsub hfeasible

Reader-facing correctness theorem for the finite sorted-list activity-selection model: the executable greedy selector returns a feasible sublist and no feasible sublist of the input is longer.

theorem activitySelection_correct {xs : List Activity}
    (hsorted : FinishSorted xs) :
    (activitySelection xs).Sublist xs ∧
      Feasible (activitySelection xs) ∧
      ∀ other, other.Sublist xs → Feasible other →
        other.length ≤ (activitySelection xs).length := by
  let hopt := activitySelection_maxCardinality hsorted
  exact ⟨hopt.sublist, hopt.feasible, hopt.maximum⟩

Reader-facing correctness theorem for the nonempty CLRS recursion step: choose the first finish-sorted activity, solve the compatible tail recursively, and no feasible competitor from the original nonempty list is longer.

theorem activitySelection_cons_correct {a : Activity} {rest : List Activity}
    (hsorted : FinishSorted (a :: rest)) :
    (a :: activitySelection (activitiesAfter a rest)).Sublist (a :: rest) ∧
      Feasible (a :: activitySelection (activitiesAfter a rest)) ∧
      ∀ other, other.Sublist (a :: rest) → Feasible other →
        other.length ≤ (a :: activitySelection (activitiesAfter a rest)).length := by
  let hopt := activitySelection_cons_maxCardinality hsorted
  exact ⟨hopt.sublist, hopt.feasible, hopt.maximum⟩

Bundled executable recursion theorem for the sorted nonempty greedy selector. It exposes the exact cons-case equation, the optimal recursive subproblem, the optimal whole solution, and the reader-facing correctness facts in one place.

theorem greedySelect_cons_recursive_correct {a : Activity} {rest : List Activity}
    (hsorted : FinishSorted (a :: rest)) :
    greedySelect (a :: rest) = a :: greedySelect (activitiesAfter a rest) ∧
      MaxCardinality (activitiesAfter a rest)
        (greedySelect (activitiesAfter a rest)) ∧
      MaxCardinality (a :: rest) (greedySelect (a :: rest)) ∧
      (greedySelect (a :: rest)).Sublist (a :: rest) ∧
      Feasible (greedySelect (a :: rest)) ∧
      ∀ other, other.Sublist (a :: rest) → Feasible other →
        other.length ≤ (greedySelect (a :: rest)).length := by
  let htail := greedySelect_after_maxCardinality hsorted
  let hfull := greedySelect_maxCardinality hsorted
  exact ⟨greedySelect_cons_eq a rest, htail, hfull, hfull.sublist,
    hfull.feasible, hfull.maximum⟩

CLRS-facing bundled recursion theorem for activity selection. On a nonempty finish-time-sorted input, the public algorithm chooses the head, recursively solves the compatible tail, and the resulting executable output is feasible, drawn from the input, and maximum-cardinality.


theorem activitySelection_cons_recursive_correct {a : Activity} {rest : List Activity}
    (hsorted : FinishSorted (a :: rest)) :
    activitySelection (a :: rest) =
        a :: activitySelection (activitiesAfter a rest) ∧
      MaxCardinality (activitiesAfter a rest)
        (activitySelection (activitiesAfter a rest)) ∧
      MaxCardinality (a :: rest) (activitySelection (a :: rest)) ∧
      (activitySelection (a :: rest)).Sublist (a :: rest) ∧
      Feasible (activitySelection (a :: rest)) ∧
      ∀ other, other.Sublist (a :: rest) → Feasible other →
        other.length ≤ (activitySelection (a :: rest)).length := by
  let htail : MaxCardinality (activitiesAfter a rest)
      (activitySelection (activitiesAfter a rest)) := by
    simpa [activitySelection] using greedySelect_after_maxCardinality hsorted
  let hfull := activitySelection_maxCardinality hsorted
  exact ⟨activitySelection_cons_eq a rest, htail, hfull, hfull.sublist,
    hfull.feasible, hfull.maximum⟩

end ActivitySelectionend CLRS

Definitions and proofs

CLRSLean.FourthEdition.Chapter_15.Section_15_1_Activity_Selection.Iterative

CLRS GREEDY-ACTIVITY-SELECTOR

This module gives the one-pass version of the activity-selection algorithm. greedyScan lastFinish xs carries the finish time of the most recently chosen activity and inspects every remaining activity exactly once.

namespace CLRS.ActivitySelection

Scan the finish-sorted candidates once, retaining compatible activities.

def greedyScan (lastFinish : Nat) : List Activity → List Activity
  | [] => []
  | a :: rest =>
      if lastFinish ≤ a.start then
        a :: greedyScan a.finish rest
      else
        greedyScan lastFinish rest

The iterative textbook selector: choose the first activity, then scan.

def greedySelectIterative : List Activity → List Activity
  | [] => []
  | a :: rest => a :: greedyScan a.finish rest



private theorem filter_after_filter_eq
    (threshold : Nat) (a : Activity) (rest : List Activity)
    (hthreshold : threshold ≤ a.start) (hvalid : TextbookValid a) :
    activitiesAfter a
        (rest.filter fun b => decide (threshold ≤ b.start)) =
      rest.filter fun b => decide (a.finish ≤ b.start) := by
  rw [activitiesAfter, List.filter_filter]
  congr 1
  funext b
  by_cases hab : a.finish ≤ b.start
  · have hthresholdFinish : threshold ≤ a.finish :=
      Nat.le_trans hthreshold (Nat.le_of_lt hvalid)
    have hthresholdB : threshold ≤ b.start :=
      Nat.le_trans hthresholdFinish hab
    simp [hab, hthresholdB]
  · simp [hab]



private theorem greedyScan_eq_filtered_recursive
    (threshold : Nat) (xs : List Activity)
    (hsorted : FinishSorted xs) (hvalid : TextbookInput xs) :
    greedyScan threshold xs =
      greedySelect (xs.filter fun a => decide (threshold ≤ a.start)) := by
  induction xs generalizing threshold with
  | nil => simp [greedyScan, greedySelect]
  | cons a rest ih =>
      have hsortedParts := List.pairwise_cons.mp hsorted
      have hvalidParts := textbookInput_cons.mp hvalid
      by_cases hselect : threshold ≤ a.start
      · rw [greedyScan]
        simp only [hselect, if_pos]
        rw [show (a :: rest).filter (fun b => decide (threshold ≤ b.start)) =
            a :: rest.filter (fun b => decide (threshold ≤ b.start)) by
          simp [hselect]]
        rw [greedySelect_cons_eq]
        rw [filter_after_filter_eq threshold a rest hselect hvalidParts.1]
        exact congrArg (a :: ·)
          (ih a.finish hsortedParts.2 hvalidParts.2)
      · rw [greedyScan]
        simp only [hselect]
        rw [show (a :: rest).filter (fun b => decide (threshold ≤ b.start)) =
            rest.filter (fun b => decide (threshold ≤ b.start)) by
          simp [hselect]]
        exact ih threshold hsortedParts.2 hvalidParts.2

The one-pass and recursive textbook selectors return the same activities on finish-sorted, textbook-valid inputs.


theorem greedySelectIterative_eq_greedySelect {xs : List Activity}
    (hsorted : FinishSorted xs) (hvalid : TextbookInput xs) :
    greedySelectIterative xs = greedySelect xs := by
  cases xs with
  | nil => simp [greedySelectIterative, greedySelect]
  | cons a rest =>
      have hsortedParts := List.pairwise_cons.mp hsorted
      have hvalidParts := textbookInput_cons.mp hvalid
      rw [greedySelectIterative, greedySelect_cons_eq]
      apply congrArg (a :: ·)
      simpa [activitiesAfter] using
        (greedyScan_eq_filtered_recursive a.finish rest
          hsortedParts.2 hvalidParts.2)

The iterative selector inherits the complete maximum-cardinality theorem.


theorem greedySelectIterative_maxCardinality {xs : List Activity}
    (hsorted : FinishSorted xs) (hvalid : TextbookInput xs) :
    MaxCardinality xs (greedySelectIterative xs) := by
  rw [greedySelectIterative_eq_greedySelect hsorted hvalid]
  exact greedySelect_maxCardinality hsorted

Exact scan cost

Result and number of inspected candidates for greedyScan.

def greedyScanCost (lastFinish : Nat) : List Activity → List Activity × Nat
  | [] => ([], 0)
  | a :: rest =>
      let tail := greedyScanCost (if lastFinish ≤ a.start then a.finish else lastFinish) rest
      (if lastFinish ≤ a.start then a :: tail.1 else tail.1, tail.2 + 1)

theorem greedyScanCost_result (lastFinish : Nat) (xs : List Activity) :
    (greedyScanCost lastFinish xs).1 = greedyScan lastFinish xs := by
  induction xs generalizing lastFinish with
  | nil => rfl
  | cons a rest ih =>
      simp only [greedyScanCost, greedyScan]
      by_cases h : lastFinish ≤ a.start
      · simp [h, ih]
      · simp [h, ih]

theorem greedyScanCost_steps (lastFinish : Nat) (xs : List Activity) :
    (greedyScanCost lastFinish xs).2 = xs.length := by
  induction xs generalizing lastFinish with
  | nil => rfl
  | cons a rest ih =>
      simp only [greedyScanCost]
      by_cases h : lastFinish ≤ a.start <;> simp [h, ih]

Result and exact inspection count for the complete iterative selector.

def greedySelectIterativeCost : List Activity → List Activity × Nat
  | [] => ([], 0)
  | a :: rest =>
      let tail := greedyScanCost a.finish rest
      (a :: tail.1, tail.2 + 1)

theorem greedySelectIterativeCost_result (xs : List Activity) :
    (greedySelectIterativeCost xs).1 = greedySelectIterative xs := by
  cases xs with
  | nil => rfl
  | cons a rest =>
      simp [greedySelectIterativeCost, greedySelectIterative,
        greedyScanCost_result]

The iterative algorithm inspects exactly xs.length activities. This exact cost identity is the formal Θ(n) statement for the unit-cost scan model.

theorem greedySelectIterativeCost_steps (xs : List Activity) :
    (greedySelectIterativeCost xs).2 = xs.length := by
  cases xs with
  | nil => rfl
  | cons a rest =>
      simp [greedySelectIterativeCost, greedyScanCost_steps]

end CLRS.ActivitySelection

CLRSLean.FourthEdition.Chapter_15.Section_15_1_Activity_Selection.TextbookModel

CLRS §15.1 textbook activity inputs

The executable core intentionally accepts arbitrary natural-number endpoints. This small layer states the textbook input contract sᵢ < fᵢ and provides a subtype for clients that want the contract enforced by the type checker.

namespace CLRS.ActivitySelection

The endpoint condition imposed on every activity in CLRS §15.1.

def TextbookValid (a : Activity) : Prop :=
  a.start < a.finish

A list consists entirely of textbook-valid activities.

def TextbookInput (xs : List Activity) : Prop :=
  ∀ a ∈ xs, TextbookValid a

An activity whose endpoints satisfy the textbook contract.

abbrev TextbookActivity := {a : Activity // TextbookValid a}

              theorem textbookInput_nil : TextbookInput [] := by
  simp [TextbookInput]theorem textbookInput_cons {a : Activity} {xs : List Activity} :
    TextbookInput (a :: xs) ↔ TextbookValid a ∧ TextbookInput xs := by
  simp [TextbookInput]theorem TextbookInput.of_sublist {xs ys : List Activity}
    (hxs : TextbookInput xs) (hsub : ys.Sublist xs) :
    TextbookInput ys := by
  intro a ha
  exact hxs a (hsub.subset ha)theorem TextbookInput.activitiesAfter {a : Activity} {xs : List Activity}
    (hxs : TextbookInput xs) :
    TextbookInput (activitiesAfter a xs) :=
  hxs.of_sublist (activitiesAfter_sublist a xs)theorem TextbookInput.greedySelect {xs : List Activity}
    (hxs : TextbookInput xs) :
    TextbookInput (greedySelect xs) :=
  hxs.of_sublist (greedySelect_sublist xs)end CLRS.ActivitySelection

Imports

import Mathlib

15.2. Greedy-Choice Property and Optimal Substructure (Meta-Theorems)

This section formalizes the two structural properties that CLRS §15.2 identifies as the reusable core of every greedy algorithm:

Greedy-choice property: making a locally optimal (greedy) choice never prevents a globally optimal solution.
Optimal substructure: an optimal solution to a problem contains within it optimal solutions to its subproblems.

We define an abstract GreedyProblem structure that bundles the data and axioms needed to prove greedy optimality, and prove the meta-theorem gsolve_optimal: if a problem satisfies both properties (with a well-founded size measure), then the recursive greedy algorithm returns an optimal solution for every instance.

The instantiation with the activity-selection problem from §15.1 is provided in a separate companion file and recovers the existing greedySelect_maxCardinality theorem as a corollary of the generic meta-theorem.

Activity-selection instance

Main results:

Structure GreedyProblem : bundles the greedy-choice property and optimal substructure.
Definition gsolve : the generic recursive greedy solver.
Theorem gsolve_optimal : gsolve returns optimal solutions for every instance of a GreedyProblem.
Predicate GreedyChoiceProperty : the abstract greedy-choice property.
Predicate OptimalSubstructure : the abstract, solver-independent optimal-substructure property.

Notation conventions:

P : problem type
Sol : solution type
Elem : type of individual elements
optimal p s : s is an optimal solution for p
greedyElt p : the greedy element for p
sub p : the subproblem after making the greedy choice
combine e s : assemble a solution from the greedy element and tail solution
size p : a Nat well-founded measure

namespace CLRSnamespace GreedyMeta

The abstract `GreedyProblem` structure

A GreedyProblem formalizes the CLRS §15.2 pattern. It bundles:

Data:

optimal p s : s is an optimal solution for p
greedyElt p : the locally optimal (greedy) element
sub p : the residual subproblem after removing the greedy choice and incompatible elements
combine e s : construct a solution from the greedy element and a subproblem solution
base : the base (empty) solution
size p : a Nat measure for termination and induction

Axioms:

greedy_choice: a non-base problem has an optimal solution beginning with the greedy choice.
optimal_substructure: the tail of such an optimal solution is optimal for the residual subproblem.
replace_optimal_tail: any other optimal residual solution can replace that tail. This is the small compositional bridge needed by the generic solver.
sub_lt and base_opt: well-foundedness and base-case optimality.

structure GreedyProblem (Elem Sol P : Type) where
  optimal : P → Sol → Prop
  greedyElt : P → Elem
  sub : P → P
  combine : Elem → Sol → Sol
  base : Sol
  size : P → ℕ

  -- The greedy choice occurs in some optimal solution.
  greedy_choice : ∀ (p : P), size p > 0 →
    ∃ tail, optimal p (combine (greedyElt p) tail)

  -- The tail of an optimal greedy-shaped solution is optimal for the subproblem.
  optimal_substructure : ∀ (p : P) (tail : Sol), size p > 0 →
    optimal p (combine (greedyElt p) tail) → optimal (sub p) tail

  -- Optimal tails are interchangeable under the fixed greedy choice.
  replace_optimal_tail : ∀ (p : P) (oldTail newTail : Sol), size p > 0 →
    optimal (sub p) oldTail → optimal (sub p) newTail →
    optimal p (combine (greedyElt p) oldTail) →
    optimal p (combine (greedyElt p) newTail)

  -- The subproblem is strictly smaller (well-foundedness)
  sub_lt : ∀ (p : P), size p > 0 → size (sub p) < size p

  -- Base-case optimality
  base_opt : ∀ (p : P), size p = 0 → optimal p base

Generic recursive greedy solver

The recursive greedy solver for a GreedyProblem. Defined by well-founded recursion on the size measure.

noncomputable def gsolve (gp : GreedyProblem Elem Sol P) : P → Sol :=
  fun p =>
    if Variable name `h` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`h : gp.size p > 0 then
      gp.combine (gp.greedyElt p) (gsolve gp (gp.sub p))
    else
      gp.base
termination_by p => gp.size p
decreasing_by
  exact gp.sub_lt _ h

Recursion equation for non-base problems: gsolve makes the greedy choice and recurses on the subproblem.


theorem gsolve_eq (gp : GreedyProblem Elem Sol P) {p : P} (h : gp.size p > 0) :
    gsolve gp p = gp.combine (gp.greedyElt p) (gsolve gp (gp.sub p)) := by
  rw [gsolve.eq_def]
  simp [h]

Base-case equation: when size p = 0, gsolve returns base.


theorem gsolve_base (gp : GreedyProblem Elem Sol P) {p : P} (h : gp.size p = 0) :
    gsolve gp p = gp.base := by
  rw [gsolve.eq_def]
  simp [h]

Meta-theorem (CLRS §15.2)

Meta-theorem. If a problem class satisfies the greedy-choice property and optimal substructure (formalized as a GreedyProblem), then the recursive greedy algorithm gsolve returns an optimal solution for every problem instance.

Proof by strong induction on the size measure.


theorem gsolve_optimal (gp : GreedyProblem Elem Sol P) (p : P) :
    gp.optimal p (gsolve gp p) := by
  induction hsize : gp.size p using Nat.strong_induction_on generalizing p with
  | h n ih =>
    by_cases hzero : gp.size p = 0
    · rw [gsolve_base gp hzero]
      exact gp.base_opt p hzero
    · have hpos : gp.size p > 0 := Nat.pos_of_ne_zero hzero
      rw [gsolve_eq gp hpos]
      have hsub_lt : gp.size (gp.sub p) < gp.size p := gp.sub_lt p hpos
      have h_eq : gp.size (gp.sub p) < n := by
        rw [← hsize]
        exact hsub_lt
      have h_ih : gp.optimal (gp.sub p) (gsolve gp (gp.sub p)) :=
        ih (gp.size (gp.sub p)) h_eq (gp.sub p) rfl
      rcases gp.greedy_choice p hpos with ⟨oldTail, hwhole⟩
      have hold_opt : gp.optimal (gp.sub p) oldTail :=
        gp.optimal_substructure p oldTail hpos hwhole
      exact gp.replace_optimal_tail p oldTail (gsolve gp (gp.sub p)) hpos
        hold_opt h_ih hwhole

Predicate form of the greedy properties

GreedyChoiceProperty says that every active problem has an optimal solution that begins with its locally greedy element. It is an existence property and does not mention a particular solver.

def GreedyChoiceProperty (P Elem Sol : Type) (optimal : P → Sol → Prop)
    (active : P → Prop) (greedyElt : P → Elem)
    (combine : Elem → Sol → Sol) : Prop :=
  ∀ p, active p → ∃ tail, optimal p (combine (greedyElt p) tail)

OptimalSubstructure says that whenever an optimal solution is decomposed into the greedy choice and a tail, that tail is optimal for the residual subproblem. Unlike the former formulation, this is a property of the problem decomposition and is independent of any solver.

def OptimalSubstructure (P Elem Sol : Type) (optimal : P → Sol → Prop)
    (active : P → Prop) (greedyElt : P → Elem) (subproblem : P → P)
    (combine : Elem → Sol → Sol) : Prop :=
  ∀ p tail, active p →
    optimal p (combine (greedyElt p) tail) → optimal (subproblem p) tail

              theorem GreedyProblem.greedyChoiceProperty (gp : GreedyProblem Elem Sol P) :
    GreedyChoiceProperty P Elem Sol gp.optimal (fun p => gp.size p > 0)
      gp.greedyElt gp.combine :=
  gp.greedy_choicetheorem GreedyProblem.hasOptimalSubstructure (gp : GreedyProblem Elem Sol P) :
    OptimalSubstructure P Elem Sol gp.optimal (fun p => gp.size p > 0)
      gp.greedyElt gp.sub gp.combine :=
  gp.optimal_substructureend GreedyMetaend CLRS

Definitions and proofs

CLRSLean.FourthEdition.Chapter_15.Section_15_2_Greedy_Meta.ActivitySelection

Activity selection as a `GreedyProblem`

This companion connects the concrete §15.1 exchange proof to the abstract §15.2 framework. Problem instances carry the finish-sortedness invariant, so the generic solver's axioms are proved rather than assumed by callers.

namespace CLRS.GreedyMetaopen CLRS.ActivitySelection

A finish-time-sorted activity-selection subproblem.

abbrev SortedActivityProblem :=
  {xs : List Activity // FinishSorted xs}

              def activityGreedyElt : SortedActivityProblem → Option Activity
  | ⟨[], _⟩ => none
  | ⟨a :: _, _⟩ => some adef activitySubproblem : SortedActivityProblem → SortedActivityProblem
  | ⟨[], _⟩ => ⟨[], by simp [FinishSorted]⟩
  | ⟨a :: rest, hsorted⟩ =>
      ⟨activitiesAfter a rest,
        finishSorted_activitiesAfter (List.pairwise_cons.mp hsorted).2⟩def activityCombine : Option Activity → List Activity → List Activity
  | none, selected => selected
  | some a, selected => a :: selecteddef activityOptimal (p : SortedActivityProblem) (selected : List Activity) : Prop :=
  MaxCardinality p.1 selecteddef activitySize (p : SortedActivityProblem) : Nat :=
  p.1.length

The §15.1 activity-selection problem satisfies the separated greedy-choice and optimal-substructure interface from §15.2.


noncomputable def activityGreedyProblem :
    GreedyProblem (Option Activity) (List Activity) SortedActivityProblem where
  optimal := activityOptimal
  greedyElt := activityGreedyElt
  sub := activitySubproblem
  combine := activityCombine
  base := []
  size := activitySize
  greedy_choice := by
    rintro ⟨xs, hsorted⟩ hpos
    cases xs with
    | nil => simp [activitySize] at hpos
    | cons a rest =>
        refine ⟨greedySelect (activitiesAfter a rest), ?_⟩
        exact greedySelect_cons_maxCardinality hsorted
  optimal_substructure := by
    rintro ⟨xs, hsorted⟩ tail hpos hwhole
    cases xs with
    | nil => simp [activitySize] at hpos
    | cons a rest =>
        change MaxCardinality (activitiesAfter a rest) tail
        change MaxCardinality (a :: rest) (a :: tail) at hwhole
        have htailSub : tail.Sublist (activitiesAfter a rest) :=
          feasible_competitor_tail_sublist_after
            (finishSorted_head_minFinish hsorted) hwhole.sublist hwhole.feasible.2
        refine ⟨htailSub, hwhole.feasible.1, ?_⟩
        intro other hotherSub hotherFeasible
        have hotherBefore : ∀ b ∈ other, Before a b := by
          intro b hb
          exact (mem_activitiesAfter.mp (hotherSub.subset hb)).2
        have hbound := hwhole.maximum (a :: other)
          (List.Sublist.cons_cons a
            (hotherSub.trans (activitiesAfter_sublist a rest)))
          (feasible_cons hotherFeasible hotherBefore)
        simpa using hbound
  replace_optimal_tail := by
    rintro ⟨xs, hsorted⟩ oldTail newTail hpos hold hnew hwhole
    cases xs with
    | nil => simp [activitySize] at hpos
    | cons a rest =>
        change MaxCardinality (activitiesAfter a rest) newTail at hnew
        change MaxCardinality (a :: rest) (a :: newTail)
        exact greedy_choice_optimal_from_certificate hnew
          (finishSorted_greedyChoiceCertificate hsorted hnew.sublist)
  sub_lt := by
    rintro ⟨xs, _hsorted⟩ hpos
    cases xs with
    | nil => simp [activitySize] at hpos
    | cons a rest =>
        have hle := (activitiesAfter_sublist a rest).length_le
        change (activitiesAfter a rest).length < (a :: rest).length
        simpa using Nat.lt_succ_of_le hle
  base_opt := by
    rintro ⟨xs, hsorted⟩ hzero
    cases xs with
    | nil =>
        exact ⟨by simp, by simp [Feasible], by
          intro other hsub _
          simpa using hsub.length_le⟩
    | cons a rest => simp [activitySize] at hzero

Generic §15.2 optimality specialized to activity selection.

theorem activityGsolve_maxCardinality (p : SortedActivityProblem) :
    MaxCardinality p.1 (gsolve activityGreedyProblem p) :=
  gsolve_optimal activityGreedyProblem p

The generic solver computes the same recursive selector formalized in §15.1.


theorem activityGsolve_eq_greedySelect (p : SortedActivityProblem) :
    gsolve activityGreedyProblem p = greedySelect p.1 := by
  induction hsize : activitySize p using Nat.strong_induction_on generalizing p with
  | h n ih =>
      rcases p with ⟨xs, hsorted⟩
      cases xs with
      | nil =>
          rw [gsolve_base activityGreedyProblem (by rfl)]
          simp [activityGreedyProblem, greedySelect]
      | cons a rest =>
          have hpos : activityGreedyProblem.size ⟨a :: rest, hsorted⟩ > 0 := by
            simp [activityGreedyProblem, activitySize]
          rw [gsolve_eq activityGreedyProblem hpos, greedySelect_cons_eq]
          change a :: gsolve activityGreedyProblem
              (activitySubproblem ⟨a :: rest, hsorted⟩) =
            a :: greedySelect (activitiesAfter a rest)
          apply congrArg (a :: ·)
          have hlt := activityGreedyProblem.sub_lt ⟨a :: rest, hsorted⟩ hpos
          have hltN : activitySize (activitySubproblem ⟨a :: rest, hsorted⟩) < n := by
            rw [← hsize]
            exact hlt
          simpa [activitySubproblem] using
            ih (activitySize (activitySubproblem ⟨a :: rest, hsorted⟩)) hltN
              (activitySubproblem ⟨a :: rest, hsorted⟩) rfl

The concrete §15.1 optimum theorem is recovered from the §15.2 instance.


theorem greedySelect_maxCardinality_via_meta {xs : List Activity}
    (hsorted : FinishSorted xs) :
    MaxCardinality xs (greedySelect xs) := by
  let p : SortedActivityProblem := ⟨xs, hsorted⟩
  rw [← activityGsolve_eq_greedySelect p]
  exact activityGsolve_maxCardinality p

The abstract instance exposes the two textbook properties separately.

theorem activityGreedyChoiceProperty :
    GreedyChoiceProperty SortedActivityProblem (Option Activity) (List Activity)
      activityOptimal (fun p => activitySize p > 0)
      activityGreedyElt activityCombine :=
  activityGreedyProblem.greedyChoiceProperty

theorem activityOptimalSubstructure :
    OptimalSubstructure SortedActivityProblem (Option Activity) (List Activity)
      activityOptimal (fun p => activitySize p > 0)
      activityGreedyElt activitySubproblem activityCombine :=
  activityGreedyProblem.hasOptimalSubstructure

end CLRS.GreedyMeta

Imports

import Mathlib

              set_option linter.unusedSimpArgs falseset_option linter.unusedVariables falseset_option linter.unreachableTactic falseset_option linter.unusedTactic falseset_option linter.unnecessarySimpa false

15.3. Huffman Codes

This section gives a self-contained Lean proof of the optimality of Huffman codes. It is isolated from the legacy CfProofs.Greedy.Huffman.* modules and is arranged as a readable pipeline:

Trees, frequencies, forests, and the Huffman merge algorithm.
Local tree-editing lemmas for swaps, merges, and split leaves.
Preservation lemmas for huffman over a forest.
The exchange/split-leaf theorem.
The bundled-forest V2 optimality theorem and frequency-table interface.

Textbook-facing companion modules:

              open Listnamespace CLRSnamespace HuffmanV2

Trees, forests, and the Huffman algorithm

              inductive HuffTree : Type
  | htLeaf (symbol freq : ℕ) | htInner (left right : HuffTree)
  deriving Repr, DecidableEqopen HuffTreedef rootFreq : HuffTree → ℕ
  | htLeaf _ f => f | htInner l r => rootFreq l + rootFreq rdef alphabet : HuffTree → Finset ℕ
  | htLeaf s _ => {s} | htInner l r => alphabet l ∪ alphabet rdef consistent : HuffTree → Prop
  | htLeaf _ _ => True
  | htInner l r => consistent l ∧ consistent r ∧ Disjoint (alphabet l) (alphabet r)def height : HuffTree → ℕ
  | htLeaf _ _ => 0 | htInner l r => max (height l) (height r) + 1def depthOf (s : ℕ) : HuffTree → Option ℕ
  | htLeaf sym _ => if sym = s then some 0 else none
  | htInner l r =>
    match depthOf s l with
    | some d => some (d + 1)
    | none => match depthOf s r with | some d => some (d + 1) | none => nonedef freqOf (s : ℕ) : HuffTree → ℕ
  | htLeaf sym f => if sym = s then f else 0
  | htInner l r => freqOf s l + freqOf s rdef cost : HuffTree → ℕ
  | htLeaf _ _ => 0 | htInner l r => cost l + cost r + rootFreq l + rootFreq rdef nodeCount : HuffTree → ℕ
  | htLeaf _ _ => 1
  | htInner l r => 1 + nodeCount l + nodeCount rlemma height_eq_zero_iff (t : HuffTree) : height t = 0 ↔ ∃ s f, t = htLeaf s f := by
  constructor
  · intro h; cases t with
    | htLeaf s f => exact ⟨s, f, rfl⟩
    | htInner l r => simp [height] at h
  · rintro ⟨s, f, rfl⟩; rfl

lemma height_pos_of_distinct_mem (t : HuffTree) {a b : ℕ}
    (ha : a ∈ alphabet t) (hb : b ∈ alphabet t) (hne : a ≠ b) : height t ≥ 1 := by
  by_contra! h_lt
  have h_zero : height t = 0 := by omega
  rcases (height_eq_zero_iff t).mp h_zero with ⟨s, f, rfl⟩
  simp [alphabet] at ha hb
  exact hne (ha.trans hb.symm)def sameFreqs (t u : HuffTree) : Prop := ∀ s, freqOf s t = freqOf s udef optimum (t : HuffTree) : Prop :=
  consistent t ∧ (∀ s ∈ alphabet t, freqOf s t > 0) ∧ ∀ u, consistent u → sameFreqs t u → cost t ≤ cost udef unite (t₁ t₂ : HuffTree) : HuffTree := htInner t₁ t₂def insortTree (t : HuffTree) : List HuffTree → List HuffTree
  | [] => [t]
  | u :: us => if rootFreq t ≤ rootFreq u then t :: u :: us else u :: insortTree t us
def huffman : List HuffTree → HuffTree
  | [] => htLeaf 0 0 | [t] => t
  | t₁ :: t₂ :: rest => huffman (insortTree (unite t₁ t₂) rest)
termination_by forest => forest.length
decreasing_by
  simp_wf
  have hlen : (insortTree (unite t₁ t₂) rest).length = rest.length + 1 := by
    induction rest with
    | nil => simp [insortTree]
    | cons u us ih => simp [insortTree]; split <;> simp [ih, add_comm, add_left_comm]
  omegadef forest_consistent : List HuffTree → Prop
  | [] => True | [t] => consistent t
  | t :: ts => consistent t ∧ forest_consistent ts ∧ (∀ u ∈ ts, Disjoint (alphabet t) (alphabet u))def forest_sorted : List HuffTree → Prop
  | [] => True | [_] => True
  | t₁ :: t₂ :: ts => rootFreq t₁ ≤ rootFreq t₂ ∧ forest_sorted (t₂ :: ts)def replaceFreq (sym newFreq : ℕ) : HuffTree → HuffTree
  | htLeaf s f => if s = sym then htLeaf s newFreq else htLeaf s f
  | htInner l r => htInner (replaceFreq sym newFreq l) (replaceFreq sym newFreq r)def swapFreqs (a c : ℕ) (t : HuffTree) : HuffTree :=
  replaceFreq c (freqOf a t) (replaceFreq a (freqOf c t) t)def splitLeaf (t : HuffTree) (z a b fa fb : ℕ) : HuffTree :=
  match t with
  | htLeaf sym f => if sym = z then htInner (htLeaf a fa) (htLeaf b fb) else htLeaf sym f
  | htInner l r => htInner (splitLeaf l z a b fa fb) (splitLeaf r z a b fa fb)def swapLeaves (a b : ℕ) : HuffTree → HuffTree
  | htLeaf s f => if s = a then htLeaf b f else if s = b then htLeaf a f else htLeaf s f
  | htInner l r => htInner (swapLeaves a b l) (swapLeaves a b r)def mergePair (a b z fz : ℕ) : HuffTree → HuffTree
  | htInner (htLeaf x fx) (htLeaf y fy) =>
    if (x = a ∧ y = b) ∨ (x = b ∧ y = a) then htLeaf z fz
    else htInner (htLeaf x fx) (htLeaf y fy)
  | htInner l r => htInner (mergePair a b z fz l) (mergePair a b z fz r)
  | t => t

lemma nodeCount_exchangeLeaf_eq (a x : ℕ) (t : HuffTree) :
    nodeCount (swapFreqs a x (swapLeaves a x t)) = nodeCount t := by
  have h_swap : ∀ a b t, nodeCount (swapLeaves a b t) = nodeCount t := by
    intro a b t
    induction t with
    | htLeaf s f => unfold swapLeaves; simp [nodeCount]; split_ifs <;> simp [nodeCount]
    | htInner l r ihl ihr => unfold swapLeaves; simp [nodeCount, ihl, ihr]
  have h_replace : ∀ sym f t, nodeCount (replaceFreq sym f t) = nodeCount t := by
    intro sym f t
    induction t with
    | htLeaf s f' => unfold replaceFreq; simp [nodeCount]; split_ifs <;> simp [nodeCount]
    | htInner l r ihl ihr => unfold replaceFreq; simp [nodeCount, ihl, ihr]
  dsimp [swapFreqs]
  rw [h_replace, h_replace, h_swap]

Alphabet, frequency, and depth lemmas

              

theorem freqOf_eq_zero_of_not_mem (s : ℕ) (t : HuffTree) (h : s ∉ alphabet t) : freqOf s t = 0 := by
  induction t with
  | htLeaf sym f =>
    have hs : sym ≠ s := by intro heq; subst heq; exact h (by simp [alphabet])
    simp [freqOf, hs]
  | htInner l r ihl ihr =>
    have hl : s ∉ alphabet l := by intro hm; apply h; simp [alphabet, hm]
    have hr : s ∉ alphabet r := by intro hm; apply h; simp [alphabet, hm]
    simp [freqOf, ihl hl, ihr hr]theorem mem_alphabet_of_freq_pos (s : ℕ) (t : HuffTree) (h : freqOf s t > 0) :
    s ∈ alphabet t := by
  contrapose! h
  simpa [freqOf_eq_zero_of_not_mem s t h]

theorem depthOf_none_of_not_mem (s : ℕ) (t : HuffTree) (h : s ∉ alphabet t) : depthOf s t = none := by
  induction t with
  | htLeaf sym f =>
    have hs : sym ≠ s := by intro heq; subst heq; exact h (by simp [alphabet])
    simp [depthOf, hs]
  | htInner l r ihl ihr =>
    have hl : s ∉ alphabet l := by intro hm; apply h; simp [alphabet, hm]
    have hr : s ∉ alphabet r := by intro hm; apply h; simp [alphabet, hm]
    simp [depthOf, ihl hl, ihr hr]

theorem depthOf_some_of_mem (s : ℕ) (t : HuffTree) (h : s ∈ alphabet t) : ∃ d, depthOf s t = some d := by
  induction t with
  | htLeaf sym f => simp [alphabet] at h; subst h; exact ⟨0, by simp [depthOf]⟩
  | htInner l r ihl ihr =>
    have h_union : s ∈ alphabet l ∪ alphabet r := by simpa [alphabet] using h
    rcases Finset.mem_union.1 h_union with (hl | hr)
    · rcases ihl hl with ⟨d, hd⟩; refine ⟨d + 1, ?_⟩; rw [depthOf]; simp [hd]
    · by_cases hl' : s ∈ alphabet l
      · rcases ihl hl' with ⟨d, hd⟩; refine ⟨d + 1, ?_⟩; rw [depthOf]; simp [hd]
      · have h_none_l : depthOf s l = none := depthOf_none_of_not_mem s l hl'
        rcases ihr hr with ⟨d, hd⟩
        refine ⟨d + 1, ?_⟩; rw [depthOf]; simp [h_none_l, hd]theorem alphabet_replaceFreq (sym newFreq : ℕ) (t : HuffTree) :
    alphabet (replaceFreq sym newFreq t) = alphabet t := by
  induction t with
  | htLeaf s f => unfold replaceFreq; split <;> simp [alphabet]
  | htInner l r ihl ihr => simp [replaceFreq, alphabet, ihl, ihr]

theorem consistent_replaceFreq (sym newFreq : ℕ) (t : HuffTree) (h_cons : consistent t) :
    consistent (replaceFreq sym newFreq t) := by
  induction t with
  | htLeaf s f => unfold replaceFreq; split <;> simp [consistent]
  | htInner l r ihl ihr =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rw [replaceFreq, consistent]
    refine ⟨ihl hcl, ihr hcr, ?_⟩
    rw [alphabet_replaceFreq sym newFreq l, alphabet_replaceFreq sym newFreq r]
    exact hdtheorem freqOf_replaceFreq_of_ne (sym newFreq other : ℕ) (t : HuffTree) (h_ne : other ≠ sym) :
    freqOf other (replaceFreq sym newFreq t) = freqOf other t := by
  induction t with
  | htLeaf s f =>
    by_cases h_eq : s = sym
    · subst h_eq; simp [replaceFreq, freqOf, Ne.symm h_ne]
    · simp [replaceFreq, freqOf, h_eq]
  | htInner l r ihl ihr => simp [replaceFreq, freqOf, ihl, ihr]

private lemma rootFreq_replaceFreq_id_of_not_mem (sym newFreq : ℕ) (t : HuffTree) (h : sym ∉ alphabet t) :
    rootFreq (replaceFreq sym newFreq t) = rootFreq t := by
  induction t with
  | htLeaf s f =>
    have hs : s ≠ sym := by intro heq; subst heq; exact h (by simp [alphabet])
    simp [replaceFreq, rootFreq, hs]
  | htInner l r ihl ihr =>
    have hl : sym ∉ alphabet l := by intro hm; apply h; simp [alphabet, hm]
    have hr : sym ∉ alphabet r := by intro hm; apply h; simp [alphabet, hm]
    simp [replaceFreq, rootFreq, ihl hl, ihr hr]

private lemma cost_replaceFreq_id_of_not_mem (sym newFreq : ℕ) (t : HuffTree) (h : sym ∉ alphabet t) :
    cost (replaceFreq sym newFreq t) = cost t := by
  induction t with
  | htLeaf s f =>
    have hs : s ≠ sym := by intro heq; subst heq; exact h (by simp [alphabet])
    simp [replaceFreq, cost, hs]
  | htInner l r ihl ihr =>
    have hl : sym ∉ alphabet l := by intro hm; apply h; simp [alphabet, hm]
    have hr : sym ∉ alphabet r := by intro hm; apply h; simp [alphabet, hm]
    have h_root_l : rootFreq (replaceFreq sym newFreq l) = rootFreq l :=
      rootFreq_replaceFreq_id_of_not_mem sym newFreq l hl
    have h_root_r : rootFreq (replaceFreq sym newFreq r) = rootFreq r :=
      rootFreq_replaceFreq_id_of_not_mem sym newFreq r hr
    simp [replaceFreq, cost, ihl hl, ihr hr, h_root_l, h_root_r]

theorem rootFreq_replaceFreq_eq_int (sym newFreq : ℕ) (t : HuffTree) (h_cons : consistent t)
    (h_sym_in : sym ∈ alphabet t) :
    (rootFreq (replaceFreq sym newFreq t) : ℤ) = (rootFreq t : ℤ) + ((newFreq : ℤ) - (freqOf sym t : ℤ)) := by
  induction t with
  | htLeaf s f => simp [alphabet] at h_sym_in; subst h_sym_in; simp [replaceFreq, rootFreq, freqOf]
  | htInner l r ihl ihr =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    have h_union : sym ∈ alphabet l ∪ alphabet r := by simpa [alphabet] using h_sym_in
    rcases Finset.mem_union.1 h_union with (hl_in | hr_in)
    · have hr_not : sym ∉ alphabet r := Finset.disjoint_left.mp hd hl_in
      have h_freq_r : freqOf sym r = 0 := freqOf_eq_zero_of_not_mem sym r hr_not
      have h_root_r : rootFreq (replaceFreq sym newFreq r) = rootFreq r :=
        rootFreq_replaceFreq_id_of_not_mem sym newFreq r hr_not
      have h_ih := ihl hcl hl_in
      simp [replaceFreq, rootFreq, freqOf, h_freq_r, h_root_r, h_ih]; ring
    · have hl_not : sym ∉ alphabet l := Finset.disjoint_right.mp hd hr_in
      have h_freq_l : freqOf sym l = 0 := freqOf_eq_zero_of_not_mem sym l hl_not
      have h_root_l : rootFreq (replaceFreq sym newFreq l) = rootFreq l :=
        rootFreq_replaceFreq_id_of_not_mem sym newFreq l hl_not
      have h_ih := ihr hcr hr_in
      simp [replaceFreq, rootFreq, freqOf, h_freq_l, h_root_l, h_ih]; ringtheorem cost_replaceFreq_eq (sym newFreq : ℕ) (t : HuffTree) (h_cons : consistent t) :
    (cost (replaceFreq sym newFreq t) : ℤ) = (cost t : ℤ) +
    ((newFreq : ℤ) - (freqOf sym t : ℤ)) * ((depthOf sym t).getD 0 : ℤ) := by
  induction t with
  | htLeaf s f =>
    by_cases h_eq : s = sym
    · subst h_eq; simp [replaceFreq, cost, freqOf, depthOf]
    · simp [replaceFreq, cost, freqOf, depthOf, h_eq]
  | htInner l r ihl ihr =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    by_cases h_sym_l : sym ∈ alphabet l
    · have h_sym_not_r : sym ∉ alphabet r := Finset.disjoint_left.mp hd h_sym_l
      have h_freq_r : freqOf sym r = 0 := freqOf_eq_zero_of_not_mem sym r h_sym_not_r
      have h_depth_r : depthOf sym r = none := depthOf_none_of_not_mem sym r h_sym_not_r
      rcases depthOf_some_of_mem sym l h_sym_l with ⟨dl, h_depth_l⟩
      have h_root_l := rootFreq_replaceFreq_eq_int sym newFreq l hcl h_sym_l
      have h_cost_r_id : cost (replaceFreq sym newFreq r) = cost r :=
        cost_replaceFreq_id_of_not_mem sym newFreq r h_sym_not_r
      have h_root_r_id : rootFreq (replaceFreq sym newFreq r) = rootFreq r :=
        rootFreq_replaceFreq_id_of_not_mem sym newFreq r h_sym_not_r
      have h_ih := ihl hcl
      simp [replaceFreq, cost, rootFreq, freqOf, depthOf,
        h_freq_r, h_depth_r, h_depth_l, h_cost_r_id, h_root_r_id, h_ih, h_root_l]; ring
    · by_cases h_sym_r : sym ∈ alphabet r
      · have h_sym_not_l : sym ∉ alphabet l := h_sym_l
        have h_freq_l : freqOf sym l = 0 := freqOf_eq_zero_of_not_mem sym l h_sym_not_l
        have h_depth_l : depthOf sym l = none := depthOf_none_of_not_mem sym l h_sym_not_l
        rcases depthOf_some_of_mem sym r h_sym_r with ⟨dr, h_depth_r⟩
        have h_root_r := rootFreq_replaceFreq_eq_int sym newFreq r hcr h_sym_r
        have h_cost_l_id : cost (replaceFreq sym newFreq l) = cost l :=
          cost_replaceFreq_id_of_not_mem sym newFreq l h_sym_not_l
        have h_root_l_id : rootFreq (replaceFreq sym newFreq l) = rootFreq l :=
          rootFreq_replaceFreq_id_of_not_mem sym newFreq l h_sym_not_l
        have h_ih := ihr hcr
        simp [replaceFreq, cost, rootFreq, freqOf, depthOf,
          h_freq_l, h_depth_l, h_depth_r, h_cost_l_id, h_root_l_id, h_ih, h_root_r]; ring
      · have h_freq_l : freqOf sym l = 0 := freqOf_eq_zero_of_not_mem sym l h_sym_l
        have h_freq_r : freqOf sym r = 0 := freqOf_eq_zero_of_not_mem sym r h_sym_r
        have h_depth_l : depthOf sym l = none := depthOf_none_of_not_mem sym l h_sym_l
        have h_depth_r : depthOf sym r = none := depthOf_none_of_not_mem sym r h_sym_r
        have h_cost_l : cost (replaceFreq sym newFreq l) = cost l :=
          cost_replaceFreq_id_of_not_mem sym newFreq l h_sym_l
        have h_cost_r : cost (replaceFreq sym newFreq r) = cost r :=
          cost_replaceFreq_id_of_not_mem sym newFreq r h_sym_r
        have h_root_l : rootFreq (replaceFreq sym newFreq l) = rootFreq l :=
          rootFreq_replaceFreq_id_of_not_mem sym newFreq l h_sym_l
        have h_root_r : rootFreq (replaceFreq sym newFreq r) = rootFreq r :=
          rootFreq_replaceFreq_id_of_not_mem sym newFreq r h_sym_r
        simp [replaceFreq, cost, rootFreq, freqOf, depthOf,
          h_freq_l, h_freq_r, h_depth_l, h_depth_r, h_cost_l, h_cost_r, h_root_l, h_root_r]

splitLeaf infrastructure

              

lemma splitLeaf_eq_of_z_not_mem (t : HuffTree) (z a b fa fb : ℕ) (h : z ∉ alphabet t) :
    splitLeaf t z a b fa fb = t := by
  induction t with
  | htLeaf sym f =>
    have hs : sym ≠ z := by intro heq; subst heq; exact h (by simp [alphabet])
    simp [splitLeaf, hs]
  | htInner l r ihl ihr =>
    have hl : z ∉ alphabet l := by intro hm; apply h; simp [alphabet, hm]
    have hr : z ∉ alphabet r := by intro hm; apply h; simp [alphabet, hm]
    simp [splitLeaf, ihl hl, ihr hr]

theorem rootFreq_splitLeaf_eq (t : HuffTree) (z a b fa fb : ℕ) (h_cons : consistent t)
    (h_z_in : z ∈ alphabet t) (h_sum : freqOf z t = fa + fb) :
    rootFreq (splitLeaf t z a b fa fb) = rootFreq t := by
  induction t with
  | htLeaf sym f =>
    simp [alphabet] at h_z_in; subst h_z_in
    have hf : f = fa + fb := by simp [freqOf] at h_sum; omega
    simp [splitLeaf, rootFreq, hf]
  | htInner l r ihl ihr =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    have h_union : z ∈ alphabet l ∪ alphabet r := by simpa [alphabet] using h_z_in
    rcases Finset.mem_union.1 h_union with (hl_in | hr_in)
    · have hr_not : z ∉ alphabet r := Finset.disjoint_left.mp hd hl_in
      have h_freq_r : freqOf z r = 0 := freqOf_eq_zero_of_not_mem z r hr_not
      have h_sum_l : freqOf z l = fa + fb := by
        simp [freqOf] at h_sum; rw [h_freq_r] at h_sum; omega
      have h_split_r : splitLeaf r z a b fa fb = r :=
        splitLeaf_eq_of_z_not_mem r z a b fa fb hr_not
      have h_ih := ihl hcl hl_in h_sum_l
      simp [splitLeaf, rootFreq, h_split_r, h_ih]
    · have hl_not : z ∉ alphabet l := Finset.disjoint_right.mp hd hr_in
      have h_freq_l : freqOf z l = 0 := freqOf_eq_zero_of_not_mem z l hl_not
      have h_sum_r : freqOf z r = fa + fb := by
        simp [freqOf] at h_sum; rw [h_freq_l] at h_sum; omega
      have h_split_l : splitLeaf l z a b fa fb = l :=
        splitLeaf_eq_of_z_not_mem l z a b fa fb hl_not
      have h_ih := ihr hcr hr_in h_sum_r
      simp [splitLeaf, rootFreq, h_split_l, h_ih]

theorem cost_splitLeaf_eq (t : HuffTree) (z a b fa fb : ℕ) (h_cons : consistent t)
    (h_z_in : z ∈ alphabet t) (h_sum : freqOf z t = fa + fb) :
    cost (splitLeaf t z a b fa fb) = cost t + fa + fb := by
  have rootFreq_splitLeaf_eq' : ∀ (t' : HuffTree), consistent t' → z ∈ alphabet t' →
      freqOf z t' = fa + fb → rootFreq (splitLeaf t' z a b fa fb) = rootFreq t' := by
    intro t' hc hzin hs
    induction t' with
    | htLeaf sym f =>
      simp [alphabet] at hzin; subst hzin
      have hf : f = fa + fb := by simp [freqOf] at hs; omega
      simp [splitLeaf, rootFreq, hf]
    | htInner l r ihl ihr =>
      rcases hc with ⟨hcl, hcr, hd⟩
      have h_union : z ∈ alphabet l ∪ alphabet r := by simpa [alphabet] using hzin
      rcases Finset.mem_union.1 h_union with (hl_in | hr_in)
      · have hr_not : z ∉ alphabet r := Finset.disjoint_left.mp hd hl_in
        have h_freq_r : freqOf z r = 0 := freqOf_eq_zero_of_not_mem z r hr_not
        have h_sum_l : freqOf z l = fa + fb := by
          simp [freqOf] at hs; rw [h_freq_r] at hs; omega
        have h_split_r : splitLeaf r z a b fa fb = r :=
          splitLeaf_eq_of_z_not_mem r z a b fa fb hr_not
        have h_ih := ihl hcl hl_in h_sum_l
        simp [splitLeaf, rootFreq, h_split_r, h_ih]
      · have hl_not : z ∉ alphabet l := Finset.disjoint_right.mp hd hr_in
        have h_freq_l : freqOf z l = 0 := freqOf_eq_zero_of_not_mem z l hl_not
        have h_sum_r : freqOf z r = fa + fb := by
          simp [freqOf] at hs; rw [h_freq_l] at hs; omega
        have h_split_l : splitLeaf l z a b fa fb = l :=
          splitLeaf_eq_of_z_not_mem l z a b fa fb hl_not
        have h_ih := ihr hcr hr_in h_sum_r
        simp [splitLeaf, rootFreq, h_split_l, h_ih]
  induction t with
  | htLeaf sym f =>
    simp [alphabet] at h_z_in; subst h_z_in
    have hf : f = fa + fb := by simp [freqOf] at h_sum; omega
    simp [splitLeaf, cost, rootFreq, hf]
  | htInner l r ihl ihr =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    have h_union : z ∈ alphabet l ∪ alphabet r := by simpa [alphabet] using h_z_in
    rcases Finset.mem_union.1 h_union with (hl_in | hr_in)
    · have hr_not : z ∉ alphabet r := Finset.disjoint_left.mp hd hl_in
      have h_freq_r : freqOf z r = 0 := freqOf_eq_zero_of_not_mem z r hr_not
      have h_sum_l : freqOf z l = fa + fb := by
        simp [freqOf] at h_sum; rw [h_freq_r] at h_sum; omega
      have h_split_r : splitLeaf r z a b fa fb = r :=
        splitLeaf_eq_of_z_not_mem r z a b fa fb hr_not
      have h_ih := ihl hcl hl_in h_sum_l
      have h_root_l : rootFreq (splitLeaf l z a b fa fb) = rootFreq l :=
        rootFreq_splitLeaf_eq l z a b fa fb hcl hl_in h_sum_l
      simp [splitLeaf, cost, h_split_r, h_ih, h_root_l]; omega
    · have hl_not : z ∉ alphabet l := Finset.disjoint_right.mp hd hr_in
      have h_freq_l : freqOf z l = 0 := freqOf_eq_zero_of_not_mem z l hl_not
      have h_sum_r : freqOf z r = fa + fb := by
        simp [freqOf] at h_sum; rw [h_freq_l] at h_sum; omega
      have h_split_l : splitLeaf l z a b fa fb = l :=
        splitLeaf_eq_of_z_not_mem l z a b fa fb hl_not
      have h_ih := ihr hcr hr_in h_sum_r
      have h_root_r : rootFreq (splitLeaf r z a b fa fb) = rootFreq r :=
        rootFreq_splitLeaf_eq r z a b fa fb hcr hr_in h_sum_r
      simp [splitLeaf, cost, h_split_l, h_ih, h_root_r]; omega

Basic swap invariants



lemma cost_swapLeaves_eq (a b : ℕ) (t : HuffTree) : cost (swapLeaves a b t) = cost t := by
  have h_root : ∀ t, rootFreq (swapLeaves a b t) = rootFreq t := by
    intro t
    induction t with
    | htLeaf s f =>
      by_cases hsa : s = a
      · rw [hsa]; simp [swapLeaves, rootFreq]
      · by_cases hsb : s = b
        · rw [hsb]; by_cases hba : b = a
          · rw [hba]; simp [swapLeaves, rootFreq]
          · simp [swapLeaves, rootFreq, hba]
        · simp [swapLeaves, rootFreq, hsa, hsb]
    | htInner l r ihl ihr => simp [swapLeaves, rootFreq, ihl, ihr]
  induction t with
  | htLeaf s f =>
    by_cases hsa : s = a
    · rw [hsa]; simp [swapLeaves, cost]
    · by_cases hsb : s = b
      · rw [hsb]; by_cases hba : b = a
        · rw [hba]; simp [swapLeaves, cost]
        · simp [swapLeaves, cost, hba]
      · simp [swapLeaves, cost, hsa, hsb]
  | htInner l r ihl ihr =>
    simp [swapLeaves, cost, ihl, ihr, h_root l, h_root r]

Frequency and depth behavior under swaps

              

lemma freqOf_swapLeaves_of_not_is (a b s : ℕ) (t : HuffTree) (h_ne_a : s ≠ a) (h_ne_b : s ≠ b) :
    freqOf s (swapLeaves a b t) = freqOf s t := by
  induction t with
  | htLeaf sym f =>
    by_cases h_eq_a : sym = a
    · rw [h_eq_a]; simp [swapLeaves, freqOf, h_ne_a.symm, h_ne_b.symm]
    · by_cases h_eq_b : sym = b
      · rw [h_eq_b]; by_cases hba : b = a
        · rw [hba]; simp [swapLeaves, freqOf, h_ne_a.symm, h_ne_b.symm]
        · simp [swapLeaves, freqOf, h_ne_a.symm, h_ne_b.symm, hba]
      · simp [swapLeaves, freqOf, h_eq_a, h_eq_b]
  | htInner l r ihl ihr => simp [swapLeaves, freqOf, ihl, ihr]

lemma freqOf_swapLeaves_at_a (a b : ℕ) (t : HuffTree) (h_ne : a ≠ b) :
    freqOf a (swapLeaves a b t) = freqOf b t := by
  induction t with
  | htLeaf sym f =>
    by_cases h_eq_a : sym = a
    · rw [h_eq_a]; simp [swapLeaves, freqOf, h_ne, h_ne.symm]
    · by_cases h_eq_b : sym = b
      · rw [h_eq_b]; by_cases hba : b = a
        · rw [hba]; simp [swapLeaves, freqOf, h_ne.symm]
        · simp [swapLeaves, freqOf, h_ne.symm, hba]
      · simp [swapLeaves, freqOf, h_eq_a, h_eq_b]
  | htInner l r ihl ihr => simp [swapLeaves, freqOf, ihl, ihr]

lemma freqOf_swapLeaves_at_b (a b : ℕ) (t : HuffTree) (h_ne : a ≠ b) :
    freqOf b (swapLeaves a b t) = freqOf a t := by
  induction t with
  | htLeaf sym f =>
    by_cases h_eq_a : sym = a
    · rw [h_eq_a]; simp [swapLeaves, freqOf, h_ne, h_ne.symm]
    · by_cases h_eq_b : sym = b
      · rw [h_eq_b]; by_cases hba : b = a
        · rw [hba]; simp [swapLeaves, freqOf, h_ne]
        · simp [swapLeaves, freqOf, hba, h_ne, h_ne.symm]
      · simp [swapLeaves, freqOf, h_eq_a, h_eq_b]
  | htInner l r ihl ihr => simp [swapLeaves, freqOf, ihl, ihr]

lemma depthOf_swapLeaves_of_not_is (a b s : ℕ) (t : HuffTree) (h_ne_a : s ≠ a) (h_ne_b : s ≠ b) :
    depthOf s (swapLeaves a b t) = depthOf s t := by
  induction t with
  | htLeaf sym f =>
    by_cases h_eq_a : sym = a
    · rw [h_eq_a]; simp [swapLeaves, depthOf, h_ne_a.symm, h_ne_b.symm]
    · by_cases h_eq_b : sym = b
      · rw [h_eq_b]; by_cases hba : b = a
        · rw [hba]; simp [swapLeaves, depthOf, h_ne_a.symm, h_ne_b.symm]
        · simp [swapLeaves, depthOf, h_ne_a.symm, h_ne_b.symm, hba]
      · simp [swapLeaves, depthOf, h_eq_a, h_eq_b]
  | htInner l r ihl ihr => simp [swapLeaves, depthOf, ihl, ihr]

lemma depthOf_swapLeaves_at_a (a b : ℕ) (t : HuffTree) (h_ne : a ≠ b) :
    depthOf a (swapLeaves a b t) = depthOf b t := by
  induction t with
  | htLeaf sym f =>
    by_cases h_eq_a : sym = a
    · rw [h_eq_a]; simp [swapLeaves, depthOf, h_ne, h_ne.symm]
    · by_cases h_eq_b : sym = b
      · rw [h_eq_b]; by_cases hba : b = a
        · rw [hba]; simp [swapLeaves, depthOf, h_ne.symm]
        · simp [swapLeaves, depthOf, h_ne.symm, hba]
      · simp [swapLeaves, depthOf, h_eq_a, h_eq_b]
  | htInner l r ihl ihr => simp [swapLeaves, depthOf, ihl, ihr]

lemma depthOf_swapLeaves_at_b (a b : ℕ) (t : HuffTree) (h_ne : a ≠ b) :
    depthOf b (swapLeaves a b t) = depthOf a t := by
  induction t with
  | htLeaf sym f =>
    by_cases h_eq_a : sym = a
    · rw [h_eq_a]; simp [swapLeaves, depthOf, h_ne, h_ne.symm]
    · by_cases h_eq_b : sym = b
      · rw [h_eq_b]; by_cases hba : b = a
        · rw [hba]; simp [swapLeaves, depthOf, h_ne]
        · simp [swapLeaves, depthOf, hba, h_ne, h_ne.symm]
      · simp [swapLeaves, depthOf, h_eq_a, h_eq_b]
  | htInner l r ihl ihr => simp [swapLeaves, depthOf, ihl, ihr]lemma depthOf_replaceFreq_eq (sym newFreq s : ℕ) (t : HuffTree) :
    depthOf s (replaceFreq sym newFreq t) = depthOf s t := by
  induction t with
  | htLeaf sym' f =>
    by_cases h : sym' = sym
    · subst h; simp [replaceFreq, depthOf]
    · simp [replaceFreq, depthOf, h]
  | htInner l r ihl ihr => simp [replaceFreq, depthOf, ihl, ihr]

lemma depthOf_swapFreqs_eq (a c s : ℕ) (t : HuffTree) :
    depthOf s (swapFreqs a c t) = depthOf s t := by
  rw [swapFreqs, depthOf_replaceFreq_eq, depthOf_replaceFreq_eq]

lemma depthOf_getD_exchange_of_ne (a x s : ℕ) (t : HuffTree)
    (hs_ne_a : s ≠ a) (hs_ne_x : s ≠ x) :
    (depthOf s (swapFreqs a x (swapLeaves a x t))).getD 0 = (depthOf s t).getD 0 := by
  rw [depthOf_swapFreqs_eq, depthOf_swapLeaves_of_not_is a x s t hs_ne_a hs_ne_x]

Consistency and cost behavior under exchanges

              def swapSym (a b s : ℕ) : ℕ := if s = a then b else if s = b then a else s

lemma swapSym_involutive (a b : ℕ) : Function.Involutive (swapSym a b) := by
  intro s
  dsimp [swapSym]
  by_cases hsa : s = a
  · subst s; simp
  · by_cases hsb : s = b
    · subst s
      by_cases hba : b = a
      · subst b; simp
      · have h1 : swapSym a b b = a := by dsimp [swapSym]; simp [hba]
        have h2 : swapSym a b a = b := by dsimp [swapSym]; simp
        calc
          swapSym a b (swapSym a b b) = swapSym a b a := by rw [h1]
          _ = b := h2
    · simp [hsa, hsb]lemma alphabet_swapLeaves_eq_image (a b : ℕ) (t : HuffTree) :
    alphabet (swapLeaves a b t) = (alphabet t).image (swapSym a b) := by
  induction t with
  | htLeaf s f =>
    by_cases hsa : s = a
    · subst s; simp [swapLeaves, alphabet, swapSym]
    · by_cases hsb : s = b
      · subst s; simp [swapLeaves, alphabet, swapSym, hsa]
      · simp [swapLeaves, alphabet, swapSym, hsa, hsb]
  | htInner l r ihl ihr =>
    simp [swapLeaves, alphabet, ihl, ihr, Finset.image_union]

lemma consistent_swapLeaves (a b : ℕ) (t : HuffTree) (h_cons : consistent t) :
    consistent (swapLeaves a b t) := by
  induction t with
  | htLeaf s f =>
    by_cases hsa : s = a
    · rw [hsa]; simp [swapLeaves, consistent]
    · by_cases hsb : s = b
      · rw [hsb]; by_cases hba : b = a
        · rw [hba]; simp [swapLeaves, consistent]
        · simp [swapLeaves, consistent, hba]
      · simp [swapLeaves, consistent, hsa, hsb]
  | htInner l r ihl ihr =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rw [swapLeaves, consistent]
    have h_l := ihl hcl; have h_r := ihr hcr
    have hd' : Disjoint (alphabet (swapLeaves a b l)) (alphabet (swapLeaves a b r)) :=
      by
        rw [alphabet_swapLeaves_eq_image a b l, alphabet_swapLeaves_eq_image a b r]
        exact (Finset.disjoint_image (swapSym_involutive a b).injective).mpr hd
    exact ⟨h_l, h_r, hd'⟩

lemma freqOf_replaceFreq_eq_of_mem (sym f : ℕ) (t : HuffTree) (h_sym : sym ∈ alphabet t) (h_cons : consistent t) :
    freqOf sym (replaceFreq sym f t) = f := by
  induction t with
  | htLeaf s g =>
    simp [alphabet] at h_sym; subst h_sym; simp [replaceFreq, freqOf]
  | htInner l r ihl ihr =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    simp [replaceFreq, freqOf]
    simp [alphabet] at h_sym
    rcases h_sym with (hl | hr)
    · have hr_not : sym ∉ alphabet r := Finset.disjoint_left.mp hd hl
      have h_r : freqOf sym (replaceFreq sym f r) = 0 :=
        freqOf_eq_zero_of_not_mem sym (replaceFreq sym f r)
          (by rw [alphabet_replaceFreq sym f r]; exact hr_not)
      rw [ihl hl hcl, h_r, add_zero]
    · have hl_not : sym ∉ alphabet l := Finset.disjoint_right.mp hd hr
      have h_l : freqOf sym (replaceFreq sym f l) = 0 :=
        freqOf_eq_zero_of_not_mem sym (replaceFreq sym f l)
          (by rw [alphabet_replaceFreq sym f l]; exact hl_not)
      rw [ihr hr hcr, h_l, zero_add]

lemma freqOf_exchangeLeaf (t : HuffTree) (a x s : ℕ) (h_ne : a ≠ x)
    (ha_in : a ∈ alphabet t) (hx_in : x ∈ alphabet t) (h_cons : consistent t) :
    freqOf s (swapFreqs a x (swapLeaves a x t)) = freqOf s t := by
  have h_ne' : x ≠ a := Ne.symm h_ne
  let t' := swapLeaves a x t
  have h_cons_t' : consistent t' := consistent_swapLeaves a x t h_cons
  have ha_t' : freqOf a t' = freqOf x t := freqOf_swapLeaves_at_a a x t h_ne
  have hx_t' : freqOf x t' = freqOf a t := freqOf_swapLeaves_at_b a x t h_ne
  have ha_mem_t' : a ∈ alphabet t' := by
    rw [alphabet_swapLeaves_eq_image a x t, Finset.mem_image]
    exact ⟨x, hx_in, by dsimp [swapSym]; simp [h_ne']⟩
  have hx_mem_t' : x ∈ alphabet t' := by
    rw [alphabet_swapLeaves_eq_image a x t, Finset.mem_image]
    exact ⟨a, ha_in, by dsimp [swapSym]; simp⟩
  by_cases hs_a : s = a
  · rw [hs_a]
    dsimp [swapFreqs]
    rw [hx_t', ha_t']
    rw [freqOf_replaceFreq_of_ne x (freqOf x t) a (replaceFreq a (freqOf a t) t') h_ne]
    rw [freqOf_replaceFreq_eq_of_mem a (freqOf a t) t' ha_mem_t' h_cons_t']
  · by_cases hs_x : s = x
    · rw [hs_x]
      dsimp [swapFreqs]
      rw [hx_t', ha_t']
      have h_cons_t1 : consistent (replaceFreq a (freqOf a t) t') :=
        consistent_replaceFreq a (freqOf a t) t' h_cons_t'
      have hx_mem_t1 : x ∈ alphabet (replaceFreq a (freqOf a t) t') := by
        rw [alphabet_replaceFreq a (freqOf a t) t']; exact hx_mem_t'
      rw [freqOf_replaceFreq_eq_of_mem x (freqOf x t) (replaceFreq a (freqOf a t) t') hx_mem_t1 h_cons_t1]
    ·
      have hs_t' : freqOf s t' = freqOf s t :=
        freqOf_swapLeaves_of_not_is a x s t hs_a hs_x
      have hs_ne_a : s ≠ a := hs_a
      have hs_ne_x : s ≠ x := hs_x
      dsimp [swapFreqs]
      rw [hx_t', ha_t']
      rw [freqOf_replaceFreq_of_ne x (freqOf x t) s (replaceFreq a (freqOf a t) t') hs_ne_x]
      rw [freqOf_replaceFreq_of_ne a (freqOf a t) s t' hs_ne_a, hs_t']

lemma cost_exchangeLeaf_le (t : HuffTree) (a x : ℕ) (h_cons : consistent t)
    (ha_in : a ∈ alphabet t) (hx_in : x ∈ alphabet t) (h_ne : a ≠ x)
    (h_freq : freqOf a t ≤ freqOf x t)
    (h_depth : (depthOf a t).getD 0 ≤ (depthOf x t).getD 0) :
    (cost (swapFreqs a x (swapLeaves a x t)) : ℤ) ≤ (cost t : ℤ) := by
  have h_ne' : x ≠ a := Ne.symm h_ne
  let t1 := swapLeaves a x t
  have h_cost_t1 : cost t1 = cost t := cost_swapLeaves_eq a x t
  have h_cons_t1 : consistent t1 := consistent_swapLeaves a x t h_cons
  have h_fa_t1 : freqOf a t1 = freqOf x t := freqOf_swapLeaves_at_a a x t h_ne
  have h_fx_t1 : freqOf x t1 = freqOf a t := freqOf_swapLeaves_at_b a x t h_ne
  have h_da_val : (depthOf a t1).getD 0 = (depthOf x t).getD 0 := by
    have h := depthOf_swapLeaves_at_a a x t h_ne; simp [t1, h]
  have h_dx_val : (depthOf x t1).getD 0 = (depthOf a t).getD 0 := by
    have h := depthOf_swapLeaves_at_b a x t h_ne; simp [t1, h]
  let t2 := replaceFreq a (freqOf x t1) t1
  have h_cons_t2 : consistent t2 := consistent_replaceFreq a (freqOf x t1) t1 h_cons_t1
  have h_fx_t2 : freqOf x t2 = freqOf x t1 := by
    simp [t2, freqOf_replaceFreq_of_ne a (freqOf x t1) x t1 h_ne']
  have h_dx_t2_val : (depthOf x t2).getD 0 = (depthOf x t1).getD 0 := by
    simp [t2, depthOf_replaceFreq_eq a (freqOf x t1) x t1]
  calc
    (cost (swapFreqs a x (swapLeaves a x t)) : ℤ)
        = (cost (swapFreqs a x t1) : ℤ) := by simp [t1]
    _ = (cost (replaceFreq x (freqOf a t1) t2) : ℤ) := by simp [t2, swapFreqs]
    _ = (cost t2 : ℤ) + (((freqOf a t1 : ℤ) - (freqOf x t2 : ℤ)) * ((depthOf x t2).getD 0 : ℤ)) :=
      cost_replaceFreq_eq x (freqOf a t1) t2 h_cons_t2
    _ = (cost t2 : ℤ) + (((freqOf x t : ℤ) - (freqOf a t : ℤ)) * ((depthOf a t).getD 0 : ℤ)) := by
      simp [h_fa_t1, h_fx_t2, h_fx_t1, h_dx_t2_val, h_dx_val]
    _ = ((cost t : ℤ) + (((freqOf a t : ℤ) - (freqOf x t : ℤ)) * ((depthOf x t).getD 0 : ℤ))) +
        (((freqOf x t : ℤ) - (freqOf a t : ℤ)) * ((depthOf a t).getD 0 : ℤ)) := by
      have h_t2_eq_raw := cost_replaceFreq_eq a (freqOf x t1) t1 h_cons_t1
      have h_t2_eq : (cost t2 : ℤ) = (cost t1 : ℤ) + (((freqOf x t1 : ℤ) - (freqOf a t1 : ℤ)) * ((depthOf a t1).getD 0 : ℤ)) := by
        simpa [t2] using h_t2_eq_raw
      rw [h_t2_eq]
      simp [h_cost_t1, h_fx_t1, h_fa_t1, h_da_val]
    _ = (cost t : ℤ) + (((freqOf a t : ℤ) - (freqOf x t : ℤ)) * (((depthOf x t).getD 0 : ℤ) - ((depthOf a t).getD 0 : ℤ))) := by ring
    _ ≤ (cost t : ℤ) := by
      have h_fa_le_fx_int : (freqOf a t : ℤ) ≤ (freqOf x t : ℤ) := by exact_mod_cast h_freq
      have h_da_le_dx_int : ((depthOf a t).getD 0 : ℤ) ≤ ((depthOf x t).getD 0 : ℤ) := by exact_mod_cast h_depth
      nlinarith

Merging sibling leaves

              inductive areSiblings (a b : ℕ) : HuffTree → Prop
  | here (fa fb : ℕ) : areSiblings a b (htInner (htLeaf a fa) (htLeaf b fb))
  | here' (fa fb : ℕ) : areSiblings a b (htInner (htLeaf b fb) (htLeaf a fa))
  | inLeft (l r : HuffTree) : areSiblings a b l → areSiblings a b (htInner l r)
  | inRight (l r : HuffTree) : areSiblings a b r → areSiblings a b (htInner l r)

lemma mergePair_eq_self_of_not_mem (a b z fz : ℕ) (t : HuffTree)
    (ha : a ∉ alphabet t) (hb : b ∉ alphabet t) : mergePair a b z fz t = t := by
  induction t with
  | htLeaf s f => simp [mergePair]
  | htInner l r ihl ihr =>
    have ha_l : a ∉ alphabet l := by intro hm; apply ha; simp [alphabet, hm]
    have hb_l : b ∉ alphabet l := by intro hm; apply hb; simp [alphabet, hm]
    have ha_r : a ∉ alphabet r := by intro hm; apply ha; simp [alphabet, hm]
    have hb_r : b ∉ alphabet r := by intro hm; apply hb; simp [alphabet, hm]
    have hl := ihl ha_l hb_l
    have hr := ihr ha_r hb_r
    cases l with
    | htLeaf sl fl =>
      cases r with
      | htLeaf sr fr =>
        have h_not_pair : ¬ ((sl = a ∧ sr = b) ∨ (sl = b ∧ sr = a)) := by
          intro h; rcases h with (⟨hsl, hsr⟩ | ⟨hsl, hsr⟩)
          · subst hsl hsr; exact ha (by simp [alphabet])
          · subst hsl hsr; exact ha (by simp [alphabet])
        simp [mergePair, h_not_pair, hl, hr]
      | htInner _ _ => simp [mergePair, hl, hr]
    | htInner _ _ => simp [mergePair, hl, hr]

lemma nodeCount_mergePair_le (a b z fz : ℕ) (t : HuffTree) :
    nodeCount (mergePair a b z fz t) ≤ nodeCount t := by
  induction t with
  | htLeaf s f => simp [mergePair, nodeCount]
  | htInner l r ihl ihr =>
    cases l with
    | htLeaf x fx =>
      cases r with
      | htLeaf y fy =>
        simp [mergePair, nodeCount]
        by_cases hc : (x = a ∧ y = b) ∨ (x = b ∧ y = a)
        · simp [hc, nodeCount]
        · simp [hc, nodeCount]
      | htInner rl rr =>
        have hm : mergePair a b z fz (htInner (htLeaf x fx) (htInner rl rr)) =
          htInner (htLeaf x fx) (mergePair a b z fz (htInner rl rr)) := by simp [mergePair]
        rw [hm]; simp [nodeCount] at ihr ⊢
        omega
    | htInner ll lr =>
      cases r with
      | htLeaf y fy =>
        have hm : mergePair a b z fz (htInner (htInner ll lr) (htLeaf y fy)) =
          htInner (mergePair a b z fz (htInner ll lr)) (htLeaf y fy) := by simp [mergePair]
        rw [hm]; simp [nodeCount] at ihl ⊢
        omega
      | htInner rl rr =>
        have hm : mergePair a b z fz (htInner (htInner ll lr) (htInner rl rr)) =
          htInner (mergePair a b z fz (htInner ll lr)) (mergePair a b z fz (htInner rl rr)) := by simp [mergePair]
        rw [hm]; simp [nodeCount] at ihl ihr ⊢
        omegalemma areSiblings_mem_alphabet {a b : ℕ} {t : HuffTree} (h_sib : areSiblings a b t) :
    a ∈ alphabet t ∧ b ∈ alphabet t := by
  induction h_sib with
  | here fa fb => simp [alphabet]
  | here' fa fb => simp [alphabet]
  | inLeft l r h ih =>
    rcases ih with ⟨ha, hb⟩
    exact ⟨Finset.mem_union_left _ ha, Finset.mem_union_left _ hb⟩
  | inRight l r h ih =>
    rcases ih with ⟨ha, hb⟩
    exact ⟨Finset.mem_union_right _ ha, Finset.mem_union_right _ hb⟩

lemma nodeCount_mergePair_lt_of_areSiblings (t : HuffTree) (a b z fz : ℕ)
    (h_sib : areSiblings a b t) (h_ne : a ≠ b) :
    nodeCount (mergePair a b z fz t) < nodeCount t := by
  induction h_sib with
  | here fa fb =>
    simp [mergePair, nodeCount]
  | here' fa fb =>
    simp [mergePair, nodeCount]
  | inLeft l r h_sib_l ih =>
    cases l with
    | htLeaf s f => exfalso; cases h_sib_l
    | htInner ll lr =>
      have h_l : nodeCount (mergePair a b z fz (htInner ll lr)) < nodeCount (htInner ll lr) := ih
      have h_r : nodeCount (mergePair a b z fz r) ≤ nodeCount r := nodeCount_mergePair_le a b z fz r
      simp [nodeCount] at h_l h_r ⊢
      have hm : mergePair a b z fz (htInner (htInner ll lr) r) =
        htInner (mergePair a b z fz (htInner ll lr)) (mergePair a b z fz r) := by simp [mergePair]
      rw [hm]; simp [nodeCount]
      omega
  | inRight l r h_sib_r ih =>
    cases r with
    | htLeaf s f => exfalso; cases h_sib_r
    | htInner rl rr =>
      have h_l : nodeCount (mergePair a b z fz l) ≤ nodeCount l := nodeCount_mergePair_le a b z fz l
      have h_r : nodeCount (mergePair a b z fz (htInner rl rr)) < nodeCount (htInner rl rr) := ih
      simp [nodeCount] at h_l h_r ⊢
      have hm : mergePair a b z fz (htInner l (htInner rl rr)) =
        htInner (mergePair a b z fz l) (mergePair a b z fz (htInner rl rr)) := by simp [mergePair]
      rw [hm]; simp [nodeCount]
      omega

lemma rootFreq_mergePair_of_areSiblings (t : HuffTree) (a b z fz : ℕ)
    (h_sib : areSiblings a b t) (h_cons : consistent t) (h_ne : a ≠ b) (h_fz : fz = freqOf a t + freqOf b t) :
    rootFreq (mergePair a b z fz t) = rootFreq t := by
  induction h_sib with
  | here fa fb =>
    simp [mergePair, rootFreq, freqOf, h_ne, h_ne.symm, h_fz]
  | here' fa fb =>
    simp [mergePair, rootFreq, freqOf, h_ne, h_ne.symm, h_fz]; omega
  | inLeft l r h_sib_l ih =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_l with ⟨ha_l, hb_l⟩
    have ha_r : a ∉ alphabet r := Finset.disjoint_left.mp hd ha_l
    have hb_r : b ∉ alphabet r := Finset.disjoint_left.mp hd hb_l
    have h_fz_l : fz = freqOf a l + freqOf b l := by
      rw [freqOf, freqOf, freqOf_eq_zero_of_not_mem a r ha_r, freqOf_eq_zero_of_not_mem b r hb_r] at h_fz
      simpa [add_comm, add_left_comm, add_assoc] using h_fz
    have h_merge_r : mergePair a b z fz r = r := mergePair_eq_self_of_not_mem a b z fz r ha_r hb_r
    have h_root_l : rootFreq (mergePair a b z fz l) = rootFreq l := ih hcl h_fz_l
    cases l with
    | htLeaf s f => exfalso; cases h_sib_l
    | htInner ll lr =>
      simp [mergePair, rootFreq, h_merge_r, h_root_l]
  | inRight l r h_sib_r ih =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_r with ⟨ha_r, hb_r⟩
    have ha_l : a ∉ alphabet l := Finset.disjoint_right.mp hd ha_r
    have hb_l : b ∉ alphabet l := Finset.disjoint_right.mp hd hb_r
    have h_fz_r : fz = freqOf a r + freqOf b r := by
      rw [freqOf, freqOf, freqOf_eq_zero_of_not_mem a l ha_l, freqOf_eq_zero_of_not_mem b l hb_l] at h_fz
      simpa [add_comm, add_left_comm, add_assoc] using h_fz
    have h_merge_l : mergePair a b z fz l = l := mergePair_eq_self_of_not_mem a b z fz l ha_l hb_l
    have h_root_r : rootFreq (mergePair a b z fz r) = rootFreq r := ih hcr h_fz_r
    cases r with
    | htLeaf s f => exfalso; cases h_sib_r
    | htInner rl rr =>
      simp [mergePair, rootFreq, h_merge_l, h_root_r]

lemma cost_mergePair_of_areSiblings (t : HuffTree) (a b z fa fb : ℕ)
    (h_sib : areSiblings a b t) (h_cons : consistent t) (h_ne : a ≠ b)
    (h_fa : freqOf a t = fa) (h_fb : freqOf b t = fb) (h_fz : fz = fa + fb) :
    (cost (mergePair a b z fz t) : ℤ) = (cost t : ℤ) - (fa : ℤ) - (fb : ℤ) := by
  revert h_cons h_fa h_fb h_fz
  induction h_sib with
  | here fa' fb' =>
    intro h_cons h_fa h_fb h_fz
    have h_fa_val : freqOf a (htInner (htLeaf a fa') (htLeaf b fb')) = fa' := by
      simp [freqOf, h_ne, h_ne.symm]
    have h_fb_val : freqOf b (htInner (htLeaf a fa') (htLeaf b fb')) = fb' := by
      simp [freqOf, h_ne, h_ne.symm]
    rw [h_fa_val] at h_fa; rw [h_fb_val] at h_fb; subst h_fa; subst h_fb
    have h_cost_merged : cost (mergePair a b z fz (htInner (htLeaf a fa') (htLeaf b fb'))) = 0 := by
      simp [mergePair, cost]
    have h_cost_t : cost (htInner (htLeaf a fa') (htLeaf b fb')) = fa' + fb' := by
      simp [cost, rootFreq]
    rw [h_cost_merged, h_cost_t]; push_cast; omega
  | here' fa' fb' =>
    intro h_cons h_fa h_fb h_fz
    have h_fa_val : freqOf a (htInner (htLeaf b fb') (htLeaf a fa')) = fa' := by
      simp [freqOf, h_ne, h_ne.symm]
    have h_fb_val : freqOf b (htInner (htLeaf b fb') (htLeaf a fa')) = fb' := by
      simp [freqOf, h_ne, h_ne.symm]
    rw [h_fa_val] at h_fa; rw [h_fb_val] at h_fb; subst h_fa; subst h_fb
    have h_cost_merged : cost (mergePair a b z fz (htInner (htLeaf b fb') (htLeaf a fa'))) = 0 := by
      simp [mergePair, cost]
    have h_cost_t : cost (htInner (htLeaf b fb') (htLeaf a fa')) = fa' + fb' := by
      simp [cost, rootFreq]; omega
    rw [h_cost_merged, h_cost_t]; push_cast; omega
  | inLeft l r h_sib_l ih =>
    intro h_cons h_fa h_fb h_fz
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_l with ⟨ha_l, hb_l⟩
    have ha_r : a ∉ alphabet r := Finset.disjoint_left.mp hd ha_l
    have hb_r : b ∉ alphabet r := Finset.disjoint_left.mp hd hb_l
    have h_freq_l_a : freqOf a l = fa := by
      rw [← h_fa, freqOf, freqOf_eq_zero_of_not_mem a r ha_r]; simp
    have h_freq_l_b : freqOf b l = fb := by
      rw [← h_fb, freqOf, freqOf_eq_zero_of_not_mem b r hb_r]; simp
    have h_root_l : rootFreq (mergePair a b z fz l) = rootFreq l :=
      rootFreq_mergePair_of_areSiblings l a b z fz h_sib_l hcl h_ne (by rw [h_freq_l_a, h_freq_l_b]; exact h_fz)
    have h_cost_l : (cost (mergePair a b z fz l) : ℤ) = (cost l : ℤ) - (fa : ℤ) - (fb : ℤ) :=
      ih hcl h_freq_l_a h_freq_l_b h_fz
    have h_cost_r : cost (mergePair a b z fz r) = cost r := by
      simp [mergePair_eq_self_of_not_mem a b z fz r ha_r hb_r]
    have h_root_r : rootFreq (mergePair a b z fz r) = rootFreq r := by
      simp [mergePair_eq_self_of_not_mem a b z fz r ha_r hb_r]
    cases l with
    | htLeaf s f => exfalso; cases h_sib_l
    | htInner ll lr =>
      simp [mergePair, cost, h_cost_l, h_cost_r, h_root_l, h_root_r]; ring
  | inRight l r h_sib_r ih =>
    intro h_cons h_fa h_fb h_fz
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_r with ⟨ha_r, hb_r⟩
    have ha_l : a ∉ alphabet l := Finset.disjoint_right.mp hd ha_r
    have hb_l : b ∉ alphabet l := Finset.disjoint_right.mp hd hb_r
    have h_freq_r_a : freqOf a r = fa := by
      rw [← h_fa, freqOf, freqOf_eq_zero_of_not_mem a l ha_l]; simp
    have h_freq_r_b : freqOf b r = fb := by
      rw [← h_fb, freqOf, freqOf_eq_zero_of_not_mem b l hb_l]; simp
    have h_root_r : rootFreq (mergePair a b z fz r) = rootFreq r :=
      rootFreq_mergePair_of_areSiblings r a b z fz h_sib_r hcr h_ne (by rw [h_freq_r_a, h_freq_r_b]; exact h_fz)
    have h_cost_r : (cost (mergePair a b z fz r) : ℤ) = (cost r : ℤ) - (fa : ℤ) - (fb : ℤ) :=
      ih hcr h_freq_r_a h_freq_r_b h_fz
    have h_cost_l : cost (mergePair a b z fz l) = cost l := by
      simp [mergePair_eq_self_of_not_mem a b z fz l ha_l hb_l]
    have h_root_l : rootFreq (mergePair a b z fz l) = rootFreq l := by
      simp [mergePair_eq_self_of_not_mem a b z fz l ha_l hb_l]
    cases r with
    | htLeaf s f => exfalso; cases h_sib_r
    | htInner rl rr =>
      simp [mergePair, cost, h_cost_l, h_cost_r, h_root_l, h_root_r]; ring

lemma alphabet_mergePair_subset (a b z fz : ℕ) (t : HuffTree) :
    alphabet (mergePair a b z fz t) ⊆ alphabet t ∪ {z} := by
  induction t with
  | htLeaf s f => simp [mergePair]
  | htInner l r ihl ihr =>
    intro x hx
    cases l with
    | htLeaf sl fl =>
      cases r with
      | htLeaf sr fr =>
        by_cases hpair : (sl = a ∧ sr = b) ∨ (sl = b ∧ sr = a)
        ·
          have h_merge_val : mergePair a b z fz (htInner (htLeaf sl fl) (htLeaf sr fr)) = htLeaf z fz := by
            simp [mergePair, hpair]
          have hx' : x ∈ alphabet (htLeaf z fz) := by rwa [h_merge_val] at hx
          rcases Finset.mem_singleton.mp hx' with rfl
          simp
        ·
          have h_merge_val : mergePair a b z fz (htInner (htLeaf sl fl) (htLeaf sr fr)) =
                             htInner (htLeaf sl fl) (htLeaf sr fr) := by
            simp [mergePair, hpair]
          have hx' : x ∈ alphabet (htInner (htLeaf sl fl) (htLeaf sr fr)) := by rwa [h_merge_val] at hx
          exact Finset.mem_union_left _ hx'
      | htInner rl rr =>
        simp only [mergePair, alphabet] at hx ⊢
        rcases Finset.mem_union.mp hx with (hx_l | hx_r)
        · apply Finset.mem_union_left; apply Finset.mem_union_left; exact hx_l
        · have h := ihr hx_r
          rcases Finset.mem_union.mp h with (h' | h')
          · apply Finset.mem_union_left; apply Finset.mem_union_right; exact h'
          · apply Finset.mem_union_right; exact h'
    | htInner ll lr =>
      cases r with
      | htLeaf sr fr =>
        simp only [mergePair, alphabet] at hx ⊢
        rcases Finset.mem_union.mp hx with (hx_l | hx_r)
        · have h := ihl hx_l
          rcases Finset.mem_union.mp h with (h' | h')
          · apply Finset.mem_union_left; apply Finset.mem_union_left; exact h'
          · apply Finset.mem_union_right; exact h'
        · apply Finset.mem_union_left; apply Finset.mem_union_right; exact hx_r
      | htInner rl rr =>
        simp only [mergePair, alphabet] at hx ⊢
        rcases Finset.mem_union.mp hx with (hx_l | hx_r)
        · have h := ihl hx_l
          rcases Finset.mem_union.mp h with (h' | h')
          · apply Finset.mem_union_left; apply Finset.mem_union_left; exact h'
          · apply Finset.mem_union_right; exact h'
        · have h := ihr hx_r
          rcases Finset.mem_union.mp h with (h' | h')
          · apply Finset.mem_union_left; apply Finset.mem_union_right; exact h'
          · apply Finset.mem_union_right; exact h'

lemma freqOf_mergePair_of_areSiblings (t : HuffTree) (a b z : ℕ)
    (h_sib : areSiblings a b t) (h_cons : consistent t) (hz_fresh : z ∉ alphabet t) (s : ℕ) :
    freqOf s (mergePair a b z (freqOf a t + freqOf b t) t) =
    if s = z then freqOf a t + freqOf b t
    else if s = a ∨ s = b then 0
    else freqOf s t := by
  cases h_sib with
  | here fa fb =>
    rcases h_cons with ⟨_, _, hd⟩
    have h_ne : a ≠ b := by
      intro h_eq
      subst h_eq
      simpa [alphabet, Finset.disjoint_iff_inter_eq_empty] using hd
    have hz_ne_a : z ≠ a := by intro heq; subst heq; apply hz_fresh; simp [alphabet]
    have hz_ne_b : z ≠ b := by intro heq; subst heq; apply hz_fresh; simp [alphabet]
    have h_freq_sum : freqOf a (htInner (htLeaf a fa) (htLeaf b fb)) +
                     freqOf b (htInner (htLeaf a fa) (htLeaf b fb)) = fa + fb := by
      simp [freqOf, h_ne, h_ne.symm]
    have h_merge_val : mergePair a b z (freqOf a (htInner (htLeaf a fa) (htLeaf b fb)) +
                                        freqOf b (htInner (htLeaf a fa) (htLeaf b fb)))
                                        (htInner (htLeaf a fa) (htLeaf b fb)) =
                       htLeaf z (fa + fb) := by
      rw [h_freq_sum]; simp [mergePair]
    rw [h_merge_val, freqOf, h_freq_sum]
    by_cases hsz : s = z
    · subst s; simp
    · rw [if_neg (Ne.symm hsz), if_neg hsz]
      by_cases hsa : s = a
      · subst s; simp
      · by_cases hsb : s = b
        · subst s; simp
        · have h_freq_s : freqOf s (htInner (htLeaf a fa) (htLeaf b fb)) = 0 := by
            simp [freqOf, hsa, hsb, Ne.symm hsa, Ne.symm hsb]
          simp [hsa, hsb, h_freq_s]
  | here' fb_a fa_a =>
    rcases h_cons with ⟨_, _, hd⟩
    have h_ne : a ≠ b := by
      intro h_eq
      subst h_eq
      simpa [alphabet, Finset.disjoint_iff_inter_eq_empty] using hd
    have hz_ne_a : z ≠ a := by intro heq; subst heq; apply hz_fresh; simp [alphabet]
    have hz_ne_b : z ≠ b := by intro heq; subst heq; apply hz_fresh; simp [alphabet]
    have h_freq_sum : freqOf a (htInner (htLeaf b fa_a) (htLeaf a fb_a)) +
                     freqOf b (htInner (htLeaf b fa_a) (htLeaf a fb_a)) = fa_a + fb_a := by
      simp [freqOf, h_ne, h_ne.symm]; omega
    have h_merge_val : mergePair a b z (freqOf a (htInner (htLeaf b fa_a) (htLeaf a fb_a)) +
                                        freqOf b (htInner (htLeaf b fa_a) (htLeaf a fb_a)))
                                        (htInner (htLeaf b fa_a) (htLeaf a fb_a)) =
                       htLeaf z (fa_a + fb_a) := by
      rw [h_freq_sum]; simp [mergePair]
    rw [h_merge_val, freqOf, h_freq_sum]
    by_cases hsz : s = z
    · subst s; simp
    · rw [if_neg (Ne.symm hsz), if_neg hsz]
      by_cases hsa : s = a
      · subst s; simp
      · by_cases hsb : s = b
        · subst s; simp
        · have h_freq_s : freqOf s (htInner (htLeaf b fa_a) (htLeaf a fb_a)) = 0 := by
            simp [freqOf, hsa, hsb, Ne.symm hsa, Ne.symm hsb]
          simp [hsa, hsb, h_freq_s]
  | inLeft l r h_sib_l =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_l with ⟨ha_l, hb_l⟩
    have ha_r : a ∉ alphabet r := Finset.disjoint_left.mp hd ha_l
    have hb_r : b ∉ alphabet r := Finset.disjoint_left.mp hd hb_l
    have hz_l : z ∉ alphabet l := by intro hz; apply hz_fresh; simp [alphabet, hz]
    have hz_r : z ∉ alphabet r := by intro hz; apply hz_fresh; simp [alphabet, hz]
    have h_freq_ar : freqOf a r = 0 := freqOf_eq_zero_of_not_mem _ _ ha_r
    have h_freq_br : freqOf b r = 0 := freqOf_eq_zero_of_not_mem _ _ hb_r
    have h_freq_zr : freqOf z r = 0 := freqOf_eq_zero_of_not_mem _ _ hz_r
    cases l with
    | htLeaf _ _ => exfalso; cases h_sib_l
    | htInner ll lr =>
      have h_fz_l : freqOf a (htInner (htInner ll lr) r) + freqOf b (htInner (htInner ll lr) r) =
                   freqOf a (htInner ll lr) + freqOf b (htInner ll lr) := by
        simp [freqOf, h_freq_ar, h_freq_br]
      rw [h_fz_l]
      have h_merge_r' : mergePair a b z (freqOf a (htInner ll lr) + freqOf b (htInner ll lr)) r = r :=
        mergePair_eq_self_of_not_mem a b z (freqOf a (htInner ll lr) + freqOf b (htInner ll lr)) r ha_r hb_r
      have h_freq_l := freqOf_mergePair_of_areSiblings (htInner ll lr) a b z h_sib_l hcl hz_l s
      have h_mp : mergePair a b z (freqOf a (htInner ll lr) + freqOf b (htInner ll lr))
                                 (htInner (htInner ll lr) r) =
                 htInner (mergePair a b z (freqOf a (htInner ll lr) + freqOf b (htInner ll lr)) (htInner ll lr))
                        (mergePair a b z (freqOf a (htInner ll lr) + freqOf b (htInner ll lr)) r) := by
        simp [mergePair]
      rw [h_mp, h_merge_r']
      conv => lhs; rw [freqOf]
      rw [h_freq_l]
      by_cases hsz : s = z
      · subst s; simp [h_freq_zr]
      · by_cases hsa : s = a
        · subst s; simp [h_freq_ar]
        · by_cases hsb : s = b
          · subst s; simp [h_freq_br]
          · simp [hsz, hsa, hsb, freqOf]
  | inRight l r h_sib_r =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_r with ⟨ha_r, hb_r⟩
    have ha_l : a ∉ alphabet l := Finset.disjoint_right.mp hd ha_r
    have hb_l : b ∉ alphabet l := Finset.disjoint_right.mp hd hb_r
    have hz_l : z ∉ alphabet l := by intro hz; apply hz_fresh; simp [alphabet, hz]
    have hz_r : z ∉ alphabet r := by intro hz; apply hz_fresh; simp [alphabet, hz]
    have h_freq_al : freqOf a l = 0 := freqOf_eq_zero_of_not_mem _ _ ha_l
    have h_freq_bl : freqOf b l = 0 := freqOf_eq_zero_of_not_mem _ _ hb_l
    have h_freq_zl : freqOf z l = 0 := freqOf_eq_zero_of_not_mem _ _ hz_l
    cases r with
    | htLeaf _ _ => exfalso; cases h_sib_r
    | htInner rl rr =>
      have h_fz_r : freqOf a (htInner l (htInner rl rr)) + freqOf b (htInner l (htInner rl rr)) =
                   freqOf a (htInner rl rr) + freqOf b (htInner rl rr) := by
        simp [freqOf, h_freq_al, h_freq_bl]
      rw [h_fz_r]
      have h_merge_l' : mergePair a b z (freqOf a (htInner rl rr) + freqOf b (htInner rl rr)) l = l :=
        mergePair_eq_self_of_not_mem a b z (freqOf a (htInner rl rr) + freqOf b (htInner rl rr)) l ha_l hb_l
      have h_freq_r := freqOf_mergePair_of_areSiblings (htInner rl rr) a b z h_sib_r hcr hz_r s
      have h_mp : mergePair a b z (freqOf a (htInner rl rr) + freqOf b (htInner rl rr))
                                 (htInner l (htInner rl rr)) =
                 htInner (mergePair a b z (freqOf a (htInner rl rr) + freqOf b (htInner rl rr)) l)
                        (mergePair a b z (freqOf a (htInner rl rr) + freqOf b (htInner rl rr)) (htInner rl rr)) := by
        simp [mergePair]
      rw [h_mp, h_merge_l']
      conv => lhs; rw [freqOf]
      rw [h_freq_r]
      by_cases hsz : s = z
      · subst s; simp [h_freq_zl]
      · by_cases hsa : s = a
        · subst s; simp [h_freq_al]
        · by_cases hsb : s = b
          · subst s; simp [h_freq_bl]
          · simp [hsz, hsa, hsb, freqOf]

Commuting split leaves through Huffman merging

The commutation proof only needs rootFreq (splitLeaf t) = rootFreq t for each forest tree.

              lemma insortTree_length (t : HuffTree) (ts : List HuffTree) : (insortTree t ts).length = ts.length + 1 := by
  induction ts with
  | nil => simp [insortTree]
  | cons u us ih => simp [insortTree]; split <;> simp [ih]

lemma insortTree_ne_nil (t : HuffTree) (ts : List HuffTree) : insortTree t ts ≠ [] := by rw [← List.length_pos_iff_ne_nil, insortTree_length]; omega@[simp] lemma splitLeaf_unite (l r : HuffTree) (z a b fa fb : ℕ) :
    splitLeaf (unite l r) z a b fa fb = unite (splitLeaf l z a b fa fb) (splitLeaf r z a b fa fb) := by
  simp [unite, splitLeaf]@[simp] lemma rootFreq_unite (t1 t2 : HuffTree) : rootFreq (unite t1 t2) = rootFreq t1 + rootFreq t2 := by simp [unite, rootFreq]

`insortTree` commutation with `map splitLeaf`



lemma map_splitLeaf_insortTree (U : HuffTree) (ts : List HuffTree) (s1 s2 f1 f2 : ℕ)
    (hU_rf : rootFreq (splitLeaf U s1 s1 s2 f1 f2) = rootFreq U)
    (hts_rf : ∀ t ∈ ts, rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t) :
    (insortTree U ts).map (λ t => splitLeaf t s1 s1 s2 f1 f2)
    = insortTree (splitLeaf U s1 s1 s2 f1 f2) (ts.map (λ t => splitLeaf t s1 s1 s2 f1 f2)) := by
  induction ts generalizing U with
  | nil => simp [insortTree]
  | cons t us ih =>
    have h_us_rf : ∀ u ∈ us, rootFreq (splitLeaf u s1 s1 s2 f1 f2) = rootFreq u :=
      fun u hu => hts_rf u (by simp [hu])
    have ht_rf := hts_rf t (by simp)
    simp [insortTree, List.map_cons]
    by_cases h_rf : rootFreq U ≤ rootFreq t
    · have h_rf' : rootFreq (splitLeaf U s1 s1 s2 f1 f2) ≤ rootFreq (splitLeaf t s1 s1 s2 f1 f2) := by
        rw [hU_rf, ht_rf]; exact h_rf
      simp [h_rf, h_rf']
    · have h_rf' : ¬ rootFreq (splitLeaf U s1 s1 s2 f1 f2) ≤ rootFreq (splitLeaf t s1 s1 s2 f1 f2) := by
        rw [hU_rf, ht_rf]; exact h_rf
      simp [h_rf, h_rf', ih U hU_rf h_us_rf]

`insortTree` membership

lemma mem_insortTree (t : HuffTree) (ts : List HuffTree) (u : HuffTree) :
    u ∈ insortTree t ts ↔ u = t ∨ u ∈ ts := by
  induction ts generalizing t with
  | nil => simp [insortTree]
  | cons v vs ih =>
    simp [insortTree]
    by_cases h : rootFreq t ≤ rootFreq v
    · simp [h, ih, or_assoc]
    · simp [h, ih, or_assoc, or_comm, or_left_comm]

lemma forall_mem_insortTree {P : HuffTree → Prop} {U : HuffTree} {ts : List HuffTree}
    (hU : P U) (hts : ∀ t ∈ ts, P t) : ∀ t ∈ insortTree U ts, P t := by
  intro t ht
  rcases (mem_insortTree U ts t).mp ht with (rfl | ht')
  · exact hU
  · exact hts t ht'

General commutation theorem



theorem splitLeaf_huffman_commute_general (ts : List HuffTree) (s1 s2 f1 f2 : ℕ)
    (h_nonempty : ts ≠ [])
    (h_rf_forest : ∀ t ∈ ts, rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t) :
    splitLeaf (huffman ts) s1 s1 s2 f1 f2
    = huffman (ts.map (λ t => splitLeaf t s1 s1 s2 f1 f2)) := by
  induction ts using huffman.induct with
  | case1 =>
    exfalso; exact h_nonempty rfl
  | case2 t => simp [huffman]
  | case3 t1 t2 rest IH =>
    have h1_rf := h_rf_forest t1 (by simp)
    have h2_rf := h_rf_forest t2 (by simp)
    have h_rest_rf : ∀ t ∈ rest, rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t :=
      fun t ht => h_rf_forest t (by simp [ht])
    let U := unite t1 t2
    have hU_rf : rootFreq (splitLeaf U s1 s1 s2 f1 f2) = rootFreq U :=
      by simp [U, h1_rf, h2_rf]
    have h_rec_rf : ∀ t ∈ insortTree U rest,
        rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t :=
      forall_mem_insortTree (P := λ t => rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t)
        hU_rf h_rest_rf
    simp [huffman, List.map_cons, splitLeaf_unite, U]
    have h_nonempty_rec : insortTree U rest ≠ [] := insortTree_ne_nil U rest
    rw [IH h_nonempty_rec h_rec_rf]
    have hU_rf' : rootFreq (splitLeaf U s1 s1 s2 f1 f2) = rootFreq U :=
      h_rec_rf U ((mem_insortTree U rest U).mpr (Or.inl rfl))
    have h_rest_rf' : ∀ t ∈ rest, rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t :=
      fun t ht => h_rec_rf t ((mem_insortTree U rest t).mpr (Or.inr ht))
    rw [map_splitLeaf_insortTree U rest s1 s2 f1 f2 hU_rf' h_rest_rf']
    rfl

Special case for `optimum_huffman`

Given a forest rest where s1 appears only as htLeaf s1 (f1+f2) (the combined leaf), we have the commutation:

splitLeaf (huffman (insortTree (htLeaf s1 (f1+f2)) rest)) s1 s1 s2 f1 f2 = huffman (insortTree (htInner (htLeaf s1 f1) (htLeaf s2 f2)) rest)

Requires: s1 ∉ alphabet t for all t ∈ rest, so that splitLeaf does nothing on rest.


theorem splitLeaf_huffman_commute (s1 s2 f1 f2 : ℕ) (rest : List HuffTree)
    (h_s1_notin_rest : ∀ t ∈ rest, s1 ∉ alphabet t) :
    splitLeaf (huffman (insortTree (htLeaf s1 (f1+f2)) rest)) s1 s1 s2 f1 f2
    = huffman (insortTree (htInner (htLeaf s1 f1) (htLeaf s2 f2)) rest) := by
  let LF := htLeaf s1 (f1+f2)
  let IF := htInner (htLeaf s1 f1) (htLeaf s2 f2)
  have h_LF_rf : rootFreq (splitLeaf LF s1 s1 s2 f1 f2) = rootFreq LF := by
    simp [LF, splitLeaf, rootFreq]
  have h_rest_rf : ∀ t ∈ rest, rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t := by
    intro t ht
    have h_id : splitLeaf t s1 s1 s2 f1 f2 = t :=
      splitLeaf_eq_of_z_not_mem t s1 s1 s2 f1 f2 (h_s1_notin_rest t ht)
    rw [h_id]
  have h_rf_forest : ∀ t ∈ insortTree LF rest,
      rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t :=
    forall_mem_insortTree (P := λ t => rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t)
      h_LF_rf h_rest_rf
  calc
    splitLeaf (huffman (insortTree LF rest)) s1 s1 s2 f1 f2
        = huffman ((insortTree LF rest).map (λ t => splitLeaf t s1 s1 s2 f1 f2)) :=
      splitLeaf_huffman_commute_general (insortTree LF rest) s1 s2 f1 f2
        (insortTree_ne_nil LF rest)
        h_rf_forest
    _ = huffman (insortTree (splitLeaf LF s1 s1 s2 f1 f2) (rest.map (λ t => splitLeaf t s1 s1 s2 f1 f2))) := by
      have hLF_rf' : rootFreq (splitLeaf LF s1 s1 s2 f1 f2) = rootFreq LF :=
        h_rf_forest LF ((mem_insortTree LF rest LF).mpr (Or.inl rfl))
      have h_rest_rf' : ∀ t ∈ rest, rootFreq (splitLeaf t s1 s1 s2 f1 f2) = rootFreq t :=
        fun t ht => h_rf_forest t ((mem_insortTree LF rest t).mpr (Or.inr ht))
      rw [map_splitLeaf_insortTree LF rest s1 s2 f1 f2 hLF_rf' h_rest_rf']
    _ = huffman (insortTree IF (rest.map (λ t => splitLeaf t s1 s1 s2 f1 f2))) := by
      simp [LF, IF, splitLeaf]
    _ = huffman (insortTree IF rest) := by
      have h_map_id : rest.map (λ t => splitLeaf t s1 s1 s2 f1 f2) = rest := by
        let go : ∀ ts : List HuffTree,
            (∀ t ∈ ts, s1 ∉ alphabet t) →
            ts.map (λ t => splitLeaf t s1 s1 s2 f1 f2) = ts := by
          intro ts h
          induction ts with
          | nil => rfl
          | cons t ts ih =>
            have h_t : s1 ∉ alphabet t := h t (by simp)
            have h_ts : ∀ t' ∈ ts, s1 ∉ alphabet t' := fun t' ht' => h t' (by simp [ht'])
            simp [splitLeaf_eq_of_z_not_mem t s1 s1 s2 f1 f2 h_t, ih h_ts]
        exact go rest h_s1_notin_rest
      rw [h_map_id]

Preservation of forest frequencies and alphabets

huffman preserves the aggregate frequencies and alphabet of a nonempty forest.

              def forest_freq (ts : List HuffTree) (s : ℕ) : ℕ := (ts.map (freqOf s)).sumdef forest_alphabet : List HuffTree → Finset ℕ
  | [] => ∅
  | t :: ts => alphabet t ∪ forest_alphabet tslemma mem_forest_alphabet (ts : List HuffTree) (s : ℕ) :
    s ∈ forest_alphabet ts ↔ ∃ t ∈ ts, s ∈ alphabet t := by
  induction ts with
  | nil => simp [forest_alphabet]
  | cons t ts ih =>
    simp [forest_alphabet, ih]lemma forest_freq_cons (t : HuffTree) (ts : List HuffTree) (s : ℕ) :
    forest_freq (t :: ts) s = freqOf s t + forest_freq ts s := by simp [forest_freq]lemma forest_freq_insortTree (t : HuffTree) (ts : List HuffTree) (s : ℕ) :
    forest_freq (insortTree t ts) s = forest_freq (t :: ts) s := by
  induction ts generalizing t with
  | nil => simp [insortTree, forest_freq]
  | cons u us ih =>
    by_cases h : rootFreq t ≤ rootFreq u
    · simp [insortTree, h, forest_freq]
    · simp [insortTree, h, forest_freq]
      have h_ih := ih t
      simp [forest_freq] at h_ih ⊢
      omegalemma forest_alphabet_insortTree (t : HuffTree) (ts : List HuffTree) :
    forest_alphabet (insortTree t ts) = forest_alphabet (t :: ts) := by
  induction ts generalizing t with
  | nil => simp [insortTree, forest_alphabet]
  | cons u us ih =>
    by_cases h : rootFreq t ≤ rootFreq u
    · simp [insortTree, h, forest_alphabet]
    · simp [insortTree, h, ih, forest_alphabet]; ac_rfllemma freqOf_huffman_eq_forest_freq (ts : List HuffTree) (s : ℕ) (h_nonempty : ts ≠ []) :
    freqOf s (huffman ts) = forest_freq ts s := by
  induction ts using huffman.induct with
  | case1 => exact False.elim (h_nonempty rfl)
  | case2 t => simp [huffman, forest_freq]
  | case3 t1 t2 rest IH =>
    simp [huffman, forest_freq_insortTree, IH (insortTree_ne_nil (unite t1 t2) rest)]
    simp [forest_freq, unite, freqOf]
    omegalemma alphabet_huffman_eq_forest_alphabet (ts : List HuffTree) (h_nonempty : ts ≠ []) :
    alphabet (huffman ts) = forest_alphabet ts := by
  induction ts using huffman.induct with
  | case1 => exact False.elim (h_nonempty rfl)
  | case2 t => simp [huffman, forest_alphabet]
  | case3 t1 t2 rest IH =>
    simp [huffman, forest_alphabet_insortTree, IH (insortTree_ne_nil (unite t1 t2) rest)]
    simp [forest_alphabet, unite, alphabet]lemma forest_consistent_cons_iff (t : HuffTree) (ts : List HuffTree) :
    forest_consistent (t :: ts) ↔
      consistent t ∧ forest_consistent ts ∧ ∀ u ∈ ts, Disjoint (alphabet t) (alphabet u) := by
  cases ts with
  | nil => simp [forest_consistent]
  | cons u us => simp [forest_consistent]

lemma forest_consistent_tail (t : HuffTree) (ts : List HuffTree)
    (h_cons : forest_consistent (t :: ts)) : forest_consistent ts := by
  rw [forest_consistent_cons_iff] at h_cons
  exact h_cons.2.1

lemma forest_consistent_insortTree_fresh (z fz : ℕ) (ts : List HuffTree)
    (h_fresh : ∀ t ∈ ts, z ∉ alphabet t)
    (h_cons : forest_consistent ts) :
  forest_consistent (insortTree (htLeaf z fz) ts) := by
  induction ts with
  | nil => simp [insortTree, forest_consistent, consistent]
  | cons u us ih =>
    have h_fresh_u : z ∉ alphabet u := h_fresh u (by simp)
    have h_fresh_us : ∀ t ∈ us, z ∉ alphabet t := fun t ht => h_fresh t (by simp [ht])
    have h_cons_us : forest_consistent us := forest_consistent_tail u us h_cons
    rw [forest_consistent_cons_iff] at h_cons
    have hcu : consistent u := h_cons.1
    have hdisj_u : ∀ w ∈ us, Disjoint (alphabet u) (alphabet w) := h_cons.2.2
    simp [insortTree]
    split_ifs with h
    · rw [forest_consistent_cons_iff]
      refine ⟨by simp [consistent], ?_, ?_⟩
      · rw [forest_consistent_cons_iff]
        refine ⟨hcu, h_cons_us, hdisj_u⟩
      · intro w hw
        simp [alphabet] at hw ⊢
        cases hw with
        | inl h_eq => rw [h_eq]; exact h_fresh_u
        | inr h_mem => exact h_fresh_us w h_mem
    · rw [forest_consistent_cons_iff]
      refine ⟨hcu, ih h_fresh_us h_cons_us, ?_⟩
      intro w hw
      rw [mem_insortTree] at hw
      cases hw with
      | inl h_eq => rw [h_eq]; simp [alphabet]; exact h_fresh_u
      | inr h_mem => exact hdisj_u w h_memlemma forest_freq_eq_zero_of_not_mem (ts : List HuffTree) (s : ℕ)
    (h : s ∉ forest_alphabet ts) : forest_freq ts s = 0 := by
  simp [forest_freq]
  apply List.sum_eq_zero
  intro x hx
  rcases List.mem_map.mp hx with ⟨t, ht, rfl⟩
  exact freqOf_eq_zero_of_not_mem s t
    (fun h_mem => h ((mem_forest_alphabet ts s).mpr ⟨t, ht, h_mem⟩))

lemma forest_freq_eq_rootFreq_of_mem_leaf (ts : List HuffTree) (s : ℕ) (t : HuffTree)
    (h_leaves : ∀ u ∈ ts, height u = 0)
    (h_cons : forest_consistent ts)
    (ht : t ∈ ts)
    (hs : s ∈ alphabet t) :
    forest_freq ts s = rootFreq t := by
  induction ts generalizing t with
  | nil => simp at ht
  | cons u us ih =>
    by_cases h_eq : t = u
    ·
      subst h_eq
      simp [forest_freq]
      have h_zero : forest_freq us s = 0 := by
        apply forest_freq_eq_zero_of_not_mem
        rw [mem_forest_alphabet]
        rintro ⟨v, hv, h_mem⟩
        rw [forest_consistent_cons_iff] at h_cons
        exact (Finset.disjoint_left.mp (h_cons.2.2 v hv) hs) h_mem
      have h_freq_t : freqOf s t = rootFreq t := by
        rcases height_eq_zero_iff t |>.mp (h_leaves t (by simp)) with ⟨sym, f, rfl⟩
        simp [alphabet] at hs
        subst hs
        simp [freqOf, rootFreq]
      simp [h_freq_t, forest_freq] at h_zero ⊢
      omega
    ·
      have h_mem' : t ∈ us := by
        simpa [h_eq] using ht
      simp [forest_freq]
      have h_zero : freqOf s u = 0 :=
        freqOf_eq_zero_of_not_mem s u (by
          rw [forest_consistent_cons_iff] at h_cons
          intro h_su
          exact (Finset.disjoint_left.mp (h_cons.2.2 t h_mem') h_su) hs)
      have h_rec : forest_freq us s = rootFreq t :=
        ih t (fun v hv => h_leaves v (by simp [hv]))
          (forest_consistent_tail u us h_cons) h_mem' hs
      simp [forest_freq] at h_rec ⊢
      simp [h_zero, h_rec]lemma forest_sorted_tail (t : HuffTree) (ts : List HuffTree)
    (h_sorted : forest_sorted (t :: ts)) : forest_sorted ts := by
  cases ts with
  | nil => simp [forest_sorted]
  | cons u us => simpa [forest_sorted] using h_sorted.2

lemma forest_sorted_insortTree_of_sorted (t : HuffTree) (ts : List HuffTree)
    (h_sorted : forest_sorted ts) : forest_sorted (insortTree t ts) := by
  induction ts generalizing t with
  | nil => simp [insortTree, forest_sorted]
  | cons u us ih =>
    have h_sorted_us : forest_sorted us := forest_sorted_tail u us h_sorted
    simp [insortTree]
    by_cases h : rootFreq t ≤ rootFreq u
    · simp [h, forest_sorted, h_sorted]
    · simp [h]
      have h_ne : insortTree t us ≠ [] := insortTree_ne_nil t us
      have h1 : rootFreq u ≤ rootFreq ((insortTree t us).head h_ne) := by
        cases us with
        | nil =>
          simp [insortTree]
          omega
        | cons v vs =>
          simp [insortTree]
          by_cases h2 : rootFreq t ≤ rootFreq v
          · simp [h2]; omega
          · simp [h2]; simp [forest_sorted] at h_sorted; omega
      have ih' := ih t h_sorted_us
      cases h_r : insortTree t us with
      | nil =>
        exact False.elim (h_ne h_r)
      | cons x xs =>
        simp [h_r] at h1 ih'
        simpa [forest_sorted] using And.intro h1 ih'

lemma forest_consistent_insortTree (t : HuffTree) (ts : List HuffTree)
    (h_cons : forest_consistent (t :: ts)) :
  forest_consistent (insortTree t ts) := by
  induction ts generalizing t with
  | nil => simpa [insortTree]
  | cons u us ih =>
    have h_parts := (forest_consistent_cons_iff t (u :: us)).mp h_cons
    have h_cons_u_us : forest_consistent (u :: us) := h_parts.2.1
    have h_u_parts := (forest_consistent_cons_iff u us).mp h_cons_u_us
    have h_cons_t_us : forest_consistent (t :: us) := by
      rw [forest_consistent_cons_iff]
      exact ⟨h_parts.1, h_u_parts.2.1, fun w hw => h_parts.2.2 w (by simp [hw])⟩
    have ih' := ih t h_cons_t_us
    simp [insortTree]
    by_cases h : rootFreq t ≤ rootFreq u
    · simp [h]; exact h_cons
    · simp [h]
      rw [forest_consistent_cons_iff]
      refine ⟨h_u_parts.1, ih', ?_⟩
      intro w hw
      rw [mem_insortTree] at hw
      rcases hw with rfl | hw
      · exact Disjoint.symm (h_parts.2.2 u (by simp))
      · exact h_u_parts.2.2 w hw

lemma rootFreq_le_of_mem_sorted (t : HuffTree) (ts : List HuffTree)
    (h_sorted : forest_sorted (t :: ts)) :
    ∀ u ∈ ts, rootFreq t ≤ rootFreq u := by
  induction ts generalizing t with
  | nil => simp
  | cons v vs ih =>
    intro u hu
    simp [forest_sorted] at h_sorted
    by_cases huv : u = v
    · rw [huv]; exact h_sorted.1
    · have hu' : u ∈ vs := by simpa [huv] using hu
      have h_sorted_t_vs : forest_sorted (t :: vs) := by
        cases vs with
        | nil => simp [forest_sorted]
        | cons w ws =>
          simp [forest_sorted]
          constructor
          · have hvw : rootFreq v ≤ rootFreq w := by
              apply ih v h_sorted.2 w (by simp)
            omega
          · exact h_sorted.2.2
      exact ih t h_sorted_t_vs u hu'

Core exchange and split-leaf optimality theorem

              def deepestSiblingPair (t : HuffTree) : ℕ × ℕ :=
  match t with
  | htLeaf s _ => (s, s)
  | htInner l r =>
    match l, r with
    | htLeaf x _, htLeaf y _ => (x, y)
    | htLeaf _ _, _ => deepestSiblingPair r
    | _, htLeaf _ _ => deepestSiblingPair l
    | _, _ => if height l ≥ height r then deepestSiblingPair l else deepestSiblingPair r

lemma deepestSiblingPair_mem1 (t : HuffTree) : (deepestSiblingPair t).1 ∈ alphabet t := by
  induction t with
  | htLeaf s f => simp [deepestSiblingPair, alphabet]
  | htInner l r ihl ihr =>
    cases l with
    | htLeaf x fx => cases r with
      | htLeaf y fy => simp [deepestSiblingPair, alphabet]
      | htInner rl rr =>
        have h_dsp : deepestSiblingPair (htInner (htLeaf x fx) (htInner rl rr)) = deepestSiblingPair (htInner rl rr) := by simp [deepestSiblingPair]
        have h_alph : alphabet (htInner (htLeaf x fx) (htInner rl rr)) = {x} ∪ alphabet (htInner rl rr) := by simp [alphabet]
        rw [h_dsp, h_alph]; exact Finset.mem_union_right {x} ihr
    | htInner ll lr => cases r with
      | htLeaf y fy =>
        have h_dsp : deepestSiblingPair (htInner (htInner ll lr) (htLeaf y fy)) = deepestSiblingPair (htInner ll lr) := by simp [deepestSiblingPair]
        have h_alph : alphabet (htInner (htInner ll lr) (htLeaf y fy)) = alphabet (htInner ll lr) ∪ {y} := by simp [alphabet]
        rw [h_dsp, h_alph]; exact Finset.mem_union_left {y} ihl
      | htInner rl rr =>
        have h_dsp : deepestSiblingPair (htInner (htInner ll lr) (htInner rl rr)) = (if height (htInner ll lr) ≥ height (htInner rl rr) then deepestSiblingPair (htInner ll lr) else deepestSiblingPair (htInner rl rr)) := by simp [deepestSiblingPair]
        have h_alph : alphabet (htInner (htInner ll lr) (htInner rl rr)) = alphabet (htInner ll lr) ∪ alphabet (htInner rl rr) := by simp [alphabet]
        rw [h_dsp, h_alph]
        by_cases h_ge : height (htInner ll lr) ≥ height (htInner rl rr)
        · rw [if_pos h_ge]; exact Finset.mem_union_left (alphabet (htInner rl rr)) ihl
        · rw [if_neg h_ge]; exact Finset.mem_union_right (alphabet (htInner ll lr)) ihr

lemma deepestSiblingPair_mem2 (t : HuffTree) : (deepestSiblingPair t).2 ∈ alphabet t := by
  induction t with
  | htLeaf s f => simp [deepestSiblingPair, alphabet]
  | htInner l r ihl ihr =>
    cases l with
    | htLeaf x fx => cases r with
      | htLeaf y fy => simp [deepestSiblingPair, alphabet]
      | htInner rl rr =>
        have h_dsp : deepestSiblingPair (htInner (htLeaf x fx) (htInner rl rr)) = deepestSiblingPair (htInner rl rr) := by simp [deepestSiblingPair]
        have h_alph : alphabet (htInner (htLeaf x fx) (htInner rl rr)) = {x} ∪ alphabet (htInner rl rr) := by simp [alphabet]
        rw [h_dsp, h_alph]; exact Finset.mem_union_right {x} ihr
    | htInner ll lr => cases r with
      | htLeaf y fy =>
        have h_dsp : deepestSiblingPair (htInner (htInner ll lr) (htLeaf y fy)) = deepestSiblingPair (htInner ll lr) := by simp [deepestSiblingPair]
        have h_alph : alphabet (htInner (htInner ll lr) (htLeaf y fy)) = alphabet (htInner ll lr) ∪ {y} := by simp [alphabet]
        rw [h_dsp, h_alph]; exact Finset.mem_union_left {y} ihl
      | htInner rl rr =>
        have h_dsp : deepestSiblingPair (htInner (htInner ll lr) (htInner rl rr)) = (if height (htInner ll lr) ≥ height (htInner rl rr) then deepestSiblingPair (htInner ll lr) else deepestSiblingPair (htInner rl rr)) := by simp [deepestSiblingPair]
        have h_alph : alphabet (htInner (htInner ll lr) (htInner rl rr)) = alphabet (htInner ll lr) ∪ alphabet (htInner rl rr) := by simp [alphabet]
        rw [h_dsp, h_alph]
        by_cases h_ge : height (htInner ll lr) ≥ height (htInner rl rr)
        · rw [if_pos h_ge]; exact Finset.mem_union_left (alphabet (htInner rl rr)) ihl
        · rw [if_neg h_ge]; exact Finset.mem_union_right (alphabet (htInner ll lr)) ihrlemma depthOf_getD_inner_of_mem_left {s : ℕ} {l r : HuffTree} (h : s ∈ alphabet l) :
    (depthOf s (htInner l r)).getD 0 = (depthOf s l).getD 0 + 1 := by
  have ⟨d, hd⟩ := depthOf_some_of_mem s l h
  simp [depthOf, hd]lemma depthOf_getD_inner_of_mem_right {s : ℕ} {l r : HuffTree} (h : s ∈ alphabet r) (h_not : s ∉ alphabet l) :
    (depthOf s (htInner l r)).getD 0 = (depthOf s r).getD 0 + 1 := by
  have ⟨d, hd⟩ := depthOf_some_of_mem s r h
  simp [depthOf, depthOf_none_of_not_mem s l h_not, hd]

lemma deepestSiblingPair_depth (t : HuffTree) (h_cons : consistent t) :
    (depthOf (deepestSiblingPair t).1 t).getD 0 = height t ∧ (depthOf (deepestSiblingPair t).2 t).getD 0 = height t := by
  induction t with
  | htLeaf s f => simp [deepestSiblingPair, depthOf, height]
  | htInner l r ihl ihr =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    cases l with
    | htLeaf x fx =>
      cases r with
      | htLeaf y fy =>
        simp [deepestSiblingPair, height]
        have hx : (depthOf x (htInner (htLeaf x fx) (htLeaf y fy))).getD 0 = 1 := by
          simp [depthOf, Option.getD]
        have hy : (depthOf y (htInner (htLeaf x fx) (htLeaf y fy))).getD 0 = 1 := by
          by_cases h_eq : x = y
          · subst h_eq; simp [depthOf, Option.getD]
          · simp [depthOf, h_eq, Option.getD]
        exact And.intro hx hy
      | htInner rl rr =>
        have h_dsp : deepestSiblingPair (htInner (htLeaf x fx) (htInner rl rr)) = deepestSiblingPair (htInner rl rr) := by
          simp [deepestSiblingPair]
        have h_height : height (htInner (htLeaf x fx) (htInner rl rr)) = height (htInner rl rr) + 1 := by
          simp [height]
        rw [h_dsp, h_height]
        rcases ihr hcr with ⟨h1, h2⟩
        have h_mem1 : (deepestSiblingPair (htInner rl rr)).1 ∈ alphabet (htInner rl rr) :=
          deepestSiblingPair_mem1 (htInner rl rr)
        have h_not_mem_l1 : (deepestSiblingPair (htInner rl rr)).1 ∉ alphabet (htLeaf x fx) :=
          Finset.disjoint_right.mp hd h_mem1
        have h_mem2 : (deepestSiblingPair (htInner rl rr)).2 ∈ alphabet (htInner rl rr) :=
          deepestSiblingPair_mem2 (htInner rl rr)
        have h_not_mem_l2 : (deepestSiblingPair (htInner rl rr)).2 ∉ alphabet (htLeaf x fx) :=
          Finset.disjoint_right.mp hd h_mem2
        constructor
        · rw [depthOf_getD_inner_of_mem_right h_mem1 h_not_mem_l1, h1]
        · rw [depthOf_getD_inner_of_mem_right h_mem2 h_not_mem_l2, h2]
    | htInner ll lr =>
      cases r with
      | htLeaf y fy =>
        have h_dsp : deepestSiblingPair (htInner (htInner ll lr) (htLeaf y fy)) = deepestSiblingPair (htInner ll lr) := by
          simp [deepestSiblingPair]
        have h_height : height (htInner (htInner ll lr) (htLeaf y fy)) = height (htInner ll lr) + 1 := by
          simp [height]
        rw [h_dsp, h_height]
        rcases ihl hcl with ⟨h1, h2⟩
        have h_mem1 : (deepestSiblingPair (htInner ll lr)).1 ∈ alphabet (htInner ll lr) :=
          deepestSiblingPair_mem1 (htInner ll lr)
        have h_mem2 : (deepestSiblingPair (htInner ll lr)).2 ∈ alphabet (htInner ll lr) :=
          deepestSiblingPair_mem2 (htInner ll lr)
        constructor
        · rw [depthOf_getD_inner_of_mem_left h_mem1, h1]
        · rw [depthOf_getD_inner_of_mem_left h_mem2, h2]
      | htInner rl rr =>
        have h_height : height (htInner (htInner ll lr) (htInner rl rr)) = max (height (htInner ll lr)) (height (htInner rl rr)) + 1 := by
          simp [height]
        rw [h_height]
        by_cases h_ge : height (htInner ll lr) ≥ height (htInner rl rr)
        · have h_dsp : deepestSiblingPair (htInner (htInner ll lr) (htInner rl rr)) = deepestSiblingPair (htInner ll lr) := by
            simp [deepestSiblingPair, h_ge]
          have h_max : max (height (htInner ll lr)) (height (htInner rl rr)) = height (htInner ll lr) := by
            simp [h_ge]
          rw [h_dsp, h_max]
          rcases ihl hcl with ⟨h1, h2⟩
          have h_mem1 : (deepestSiblingPair (htInner ll lr)).1 ∈ alphabet (htInner ll lr) :=
            deepestSiblingPair_mem1 (htInner ll lr)
          have h_mem2 : (deepestSiblingPair (htInner ll lr)).2 ∈ alphabet (htInner ll lr) :=
            deepestSiblingPair_mem2 (htInner ll lr)
          constructor
          · rw [depthOf_getD_inner_of_mem_left h_mem1, h1]
          · rw [depthOf_getD_inner_of_mem_left h_mem2, h2]
        · have h_dsp : deepestSiblingPair (htInner (htInner ll lr) (htInner rl rr)) = deepestSiblingPair (htInner rl rr) := by
            simp [deepestSiblingPair, h_ge]
          have h_max : max (height (htInner ll lr)) (height (htInner rl rr)) = height (htInner rl rr) :=
            Nat.max_eq_right (by omega)
          rw [h_dsp, h_max]
          rcases ihr hcr with ⟨h1, h2⟩
          have h_mem1 : (deepestSiblingPair (htInner rl rr)).1 ∈ alphabet (htInner rl rr) :=
            deepestSiblingPair_mem1 (htInner rl rr)
          have h_not_mem_l1 : (deepestSiblingPair (htInner rl rr)).1 ∉ alphabet (htInner ll lr) :=
            Finset.disjoint_right.mp hd h_mem1
          have h_mem2 : (deepestSiblingPair (htInner rl rr)).2 ∈ alphabet (htInner rl rr) :=
            deepestSiblingPair_mem2 (htInner rl rr)
          have h_not_mem_l2 : (deepestSiblingPair (htInner rl rr)).2 ∉ alphabet (htInner ll lr) :=
            Finset.disjoint_right.mp hd h_mem2
          constructor
          · rw [depthOf_getD_inner_of_mem_right h_mem1 h_not_mem_l1, h1]
          · rw [depthOf_getD_inner_of_mem_right h_mem2 h_not_mem_l2, h2]

lemma deepestSiblingPair_areSiblings (t : HuffTree) (h_cons : consistent t)
    (h_height : height t ≥ 1) :
    areSiblings (deepestSiblingPair t).1 (deepestSiblingPair t).2 t := by
  induction t with
  | htLeaf s f => simp [height] at h_height
  | htInner l r ihl ihr =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    cases l with
    | htLeaf x fx =>
      cases r with
      | htLeaf y fy => exact areSiblings.here (a := x) (b := y) fx fy
      | htInner rl rr =>
        have hh_r : height (htInner rl rr) ≥ 1 := by simp [height]
        have hh := ihr hcr hh_r
        exact areSiblings.inRight (htLeaf x fx) (htInner rl rr) hh
    | htInner ll lr =>
      cases r with
      | htLeaf y fy =>
        have hh_l : height (htInner ll lr) ≥ 1 := by simp [height]
        have hh := ihl hcl hh_l
        exact areSiblings.inLeft (htInner ll lr) (htLeaf y fy) hh
      | htInner rl rr =>
        have hh_l : height (htInner ll lr) ≥ 1 := by simp [height]
        have hh_r : height (htInner rl rr) ≥ 1 := by simp [height]
        by_cases h_ge : height (htInner ll lr) ≥ height (htInner rl rr)
        · have hh := ihl hcl hh_l
          simpa [deepestSiblingPair, h_ge] using
            areSiblings.inLeft (htInner ll lr) (htInner rl rr) hh
        · have hh := ihr hcr hh_r
          simpa [deepestSiblingPair, h_ge] using
            areSiblings.inRight (htInner ll lr) (htInner rl rr) hhlemma areSiblings_exchangeLeft (t : HuffTree) (a x y : ℕ) (h_sib : areSiblings x y t)
    (h_ne_ax : a ≠ x) (h_ne_ay : a ≠ y) (h_ne_xy : x ≠ y) : areSiblings a y (swapLeaves a x t) := by
  induction h_sib with
  | here fa fb =>
    simp [swapLeaves, h_ne_ax.symm, h_ne_ay.symm, h_ne_xy.symm]
    refine areSiblings.here (a := a) (b := y) ?_ ?_ <;> simp
  | here' fa fb =>
    simp [swapLeaves, h_ne_ax.symm, h_ne_ay.symm, h_ne_xy, h_ne_xy.symm]
    refine areSiblings.here' (a := a) (b := y) ?_ ?_ <;> simp
  | inLeft l r h ih =>
    simp [swapLeaves]
    exact areSiblings.inLeft _ _ ih
  | inRight l r h ih =>
    simp [swapLeaves]
    exact areSiblings.inRight _ _ ihlemma areSiblings_replaceFreq (t : HuffTree) (a b sym freq : ℕ) (h_sib : areSiblings a b t) :
    areSiblings a b (replaceFreq sym freq t) := by
  induction h_sib with
  | here fa fb =>
    simp [replaceFreq]; split <;> split <;> apply areSiblings.here
  | here' fa fb =>
    simp [replaceFreq]; split <;> split <;> apply areSiblings.here'
  | inLeft l r h ih =>
    simp [replaceFreq]; exact areSiblings.inLeft _ _ ih
  | inRight l r h ih =>
    simp [replaceFreq]; exact areSiblings.inRight _ _ ihlemma areSiblings_swapFreqs_preserved (t : HuffTree) (a b x y : ℕ) (h_sib : areSiblings a b t) :
    areSiblings a b (swapFreqs x y t) := by
  dsimp [swapFreqs]
  apply areSiblings_replaceFreq _ _ _ _ _ (areSiblings_replaceFreq _ _ _ _ _ h_sib)lemma areSiblings_ne (t : HuffTree) (a b : ℕ) (h_cons : consistent t) (h_sib : areSiblings a b t) : a ≠ b := by
  induction h_sib with
  | here fa fb =>
    rcases h_cons with ⟨_, _, hd⟩
    intro heq; subst heq
    simp [alphabet, Finset.disjoint_iff_inter_eq_empty] at hd
  | here' fa fb =>
    rcases h_cons with ⟨_, _, hd⟩
    intro heq; subst heq
    simp [alphabet, Finset.disjoint_iff_inter_eq_empty] at hd
  | inLeft l r h_sib_l ih =>
    rcases h_cons with ⟨hcl, _, _⟩
    exact ih hcl
  | inRight l r h_sib_r ih =>
    rcases h_cons with ⟨_, hcr, _⟩
    exact ih hcr

lemma depthOf_getD_le_height (t : HuffTree) (s : ℕ) : (depthOf s t).getD 0 ≤ height t := by
  induction t with
  | htLeaf sym f => simp [depthOf, height]; split <;> simp
  | htInner l r ihl ihr =>
    simp [depthOf, height]
    cases h_l : depthOf s l with
    | none =>
      simp [h_l]
      cases h_r : depthOf s r with
      | none => simp
      | some d =>
        simp [h_r]
        have hd : d ≤ height r := by simpa [h_r] using ihr
        omega
    | some d =>
        simp [h_l]
        have hd : d ≤ height l := by simpa [h_l] using ihl
        omegalemma optimum_leaf (s f : ℕ) (h_f_pos : f > 0) : optimum (htLeaf s f) := by
  refine ⟨by simp [consistent], ?_, ?_⟩
  · simp [alphabet, freqOf, h_f_pos]
  · intro u _ h_sameFreqs
    exact Nat.zero_le (cost u)

private lemma swapLeaves_comm (a b : ℕ) (t : HuffTree) : swapLeaves a b t = swapLeaves b a t := by
  induction t with
  | htLeaf s f =>
    dsimp [swapLeaves]
    by_cases h1 : s = a
    · rw [h1]
      by_cases h2 : a = b
      · rw [h2]
      · simp [h2]
    · by_cases h2 : s = b
      · rw [h2]; simp [h1, Ne.symm h1]
      · simp [h1, h2]
  | htInner l r ihl ihr =>
    simp [swapLeaves, ihl, ihr]private lemma areSiblings_swap_siblings {a b : ℕ} {t : HuffTree} (h_sib : areSiblings a b t) (h_ne : a ≠ b) :
    areSiblings b a (swapLeaves a b t) := by
  induction h_sib with
  | here fa fb =>
    simp [swapLeaves, h_ne, h_ne.symm]
    exact areSiblings.here fa fb
  | here' fa fb =>
    simp [swapLeaves, h_ne, h_ne.symm]
    exact areSiblings.here' fa fb
  | inLeft l r h ih => simp [swapLeaves]; exact areSiblings.inLeft _ _ ih
  | inRight l r h ih => simp [swapLeaves]; exact areSiblings.inRight _ _ ihlemma areSiblings_exchangeRight (t : HuffTree) (a b x : ℕ) (h_sib : areSiblings a x t)
    (h_ne_ba : b ≠ a) (h_ne_bx : b ≠ x) (h_ne_ax : a ≠ x) : areSiblings a b (swapLeaves b x t) := by
  induction h_sib with
  | here fa fx =>
    simp [swapLeaves, h_ne_bx.symm, h_ne_ba.symm, h_ne_ax]
    refine areSiblings.here (a := a) (b := b) ?_ ?_ <;> simp
  | here' fa fx =>
    simp [swapLeaves, h_ne_bx.symm, h_ne_ba.symm, h_ne_ax, h_ne_ax.symm]
    refine areSiblings.here' (a := a) (b := b) ?_ ?_ <;> simp
  | inLeft l r h ih =>
    simp [swapLeaves]
    exact areSiblings.inLeft _ _ ih
  | inRight l r h ih =>
    simp [swapLeaves]
    exact areSiblings.inRight _ _ ih

private lemma freqOf_mergePair_same_sibling (t : HuffTree) (b z s : ℕ)
    (h_sib : areSiblings z b t) (h_cons : consistent t) (hz_ne_b : z ≠ b) :
    freqOf s (mergePair z b z (freqOf z t + freqOf b t) t) =
    if s = z then freqOf z t + freqOf b t else if s = b then 0 else freqOf s t := by
  induction h_sib with
  | here fa fb =>
    have h_freq_sum : freqOf z (htInner (htLeaf z fa) (htLeaf b fb)) +
                     freqOf b (htInner (htLeaf z fa) (htLeaf b fb)) = fa + fb := by
      simp [freqOf, hz_ne_b, hz_ne_b.symm]
    have h_merge_val : mergePair z b z (freqOf z (htInner (htLeaf z fa) (htLeaf b fb)) +
                                        freqOf b (htInner (htLeaf z fa) (htLeaf b fb)))
                                        (htInner (htLeaf z fa) (htLeaf b fb)) =
                       htLeaf z (fa + fb) := by
      rw [h_freq_sum]; simp [mergePair]
    rw [h_merge_val, freqOf, h_freq_sum]
    by_cases hsz : s = z
    · subst s; simp [hz_ne_b]
    · rw [if_neg (Ne.symm hsz), if_neg hsz]
      by_cases hsb : s = b
      · subst s; simp [hz_ne_b]
      · have h_freq_s : freqOf s (htInner (htLeaf z fa) (htLeaf b fb)) = 0 := by
          simp [freqOf, hsz, hsb, Ne.symm hsz, Ne.symm hsb]
        simp [hsz, hsb, h_freq_s]
  | here' fa fb =>
    have h_freq_sum : freqOf z (htInner (htLeaf b fb) (htLeaf z fa)) +
                     freqOf b (htInner (htLeaf b fb) (htLeaf z fa)) = fa + fb := by
      simp [freqOf, hz_ne_b, hz_ne_b.symm]
    have h_merge_val : mergePair z b z (freqOf z (htInner (htLeaf b fb) (htLeaf z fa)) +
                                        freqOf b (htInner (htLeaf b fb) (htLeaf z fa)))
                                        (htInner (htLeaf b fb) (htLeaf z fa)) =
                       htLeaf z (fa + fb) := by
      rw [h_freq_sum]; simp [mergePair]
    rw [h_merge_val, freqOf, h_freq_sum]
    by_cases hsz : s = z
    · subst s; simp [hz_ne_b]
    · rw [if_neg (Ne.symm hsz), if_neg hsz]
      by_cases hsb : s = b
      · subst s; simp [hz_ne_b]
      · have h_freq_s : freqOf s (htInner (htLeaf b fb) (htLeaf z fa)) = 0 := by
          simp [freqOf, hsz, hsb, Ne.symm hsz, Ne.symm hsb]
        simp [hsz, hsb, h_freq_s]
  | inLeft l r h_sib_l ih =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_l with ⟨hz_l, hb_l⟩
    have hz_r : z ∉ alphabet r := Finset.disjoint_left.mp hd hz_l
    have hb_r : b ∉ alphabet r := Finset.disjoint_left.mp hd hb_l
    have h_freq_zr : freqOf z r = 0 := freqOf_eq_zero_of_not_mem _ _ hz_r
    have h_freq_br : freqOf b r = 0 := freqOf_eq_zero_of_not_mem _ _ hb_r
    cases l with
    | htLeaf _ _ => exfalso; cases h_sib_l
    | htInner ll lr =>
      have h_freq_sum : freqOf z (htInner (htInner ll lr) r) + freqOf b (htInner (htInner ll lr) r) =
                       freqOf z (htInner ll lr) + freqOf b (htInner ll lr) := by
        simp [freqOf, h_freq_zr, h_freq_br]
      rw [h_freq_sum]
      have h_merge_r : mergePair z b z (freqOf z (htInner ll lr) + freqOf b (htInner ll lr)) r = r :=
        mergePair_eq_self_of_not_mem z b z (freqOf z (htInner ll lr) + freqOf b (htInner ll lr)) r hz_r hb_r
      have h_freq_l := ih hcl
      have h_mp : mergePair z b z (freqOf z (htInner ll lr) + freqOf b (htInner ll lr))
                                 (htInner (htInner ll lr) r) =
                 htInner (mergePair z b z (freqOf z (htInner ll lr) + freqOf b (htInner ll lr)) (htInner ll lr))
                        (mergePair z b z (freqOf z (htInner ll lr) + freqOf b (htInner ll lr)) r) := by
        simp [mergePair]
      rw [h_mp, h_merge_r]
      conv => lhs; rw [freqOf]
      rw [h_freq_l]
      by_cases hsz : s = z
      · subst s; simp [h_freq_zr]
      · by_cases hsb : s = b
        · subst s; simp [h_freq_br]
        · simp [hsz, hsb, freqOf]
  | inRight l r h_sib_r ih =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_r with ⟨hz_r, hb_r⟩
    have hz_l : z ∉ alphabet l := Finset.disjoint_right.mp hd hz_r
    have hb_l : b ∉ alphabet l := Finset.disjoint_right.mp hd hb_r
    have h_freq_zl : freqOf z l = 0 := freqOf_eq_zero_of_not_mem _ _ hz_l
    have h_freq_bl : freqOf b l = 0 := freqOf_eq_zero_of_not_mem _ _ hb_l
    cases r with
    | htLeaf _ _ => exfalso; cases h_sib_r
    | htInner rl rr =>
      have h_freq_sum : freqOf z (htInner l (htInner rl rr)) + freqOf b (htInner l (htInner rl rr)) =
                       freqOf z (htInner rl rr) + freqOf b (htInner rl rr) := by
        simp [freqOf, h_freq_zl, h_freq_bl]
      rw [h_freq_sum]
      have h_merge_l : mergePair z b z (freqOf z (htInner rl rr) + freqOf b (htInner rl rr)) l = l :=
        mergePair_eq_self_of_not_mem z b z (freqOf z (htInner rl rr) + freqOf b (htInner rl rr)) l hz_l hb_l
      have h_freq_r := ih hcr
      have h_mp : mergePair z b z (freqOf z (htInner rl rr) + freqOf b (htInner rl rr))
                                 (htInner l (htInner rl rr)) =
                 htInner (mergePair z b z (freqOf z (htInner rl rr) + freqOf b (htInner rl rr)) l)
                        (mergePair z b z (freqOf z (htInner rl rr) + freqOf b (htInner rl rr)) (htInner rl rr)) := by
        simp [mergePair]
      rw [h_mp, h_merge_l]
      conv => lhs; rw [freqOf]
      rw [h_freq_r]
      by_cases hsz : s = z
      · subst s; simp [h_freq_zl]
      · by_cases hsb : s = b
        · subst s; simp [h_freq_bl]
        · simp [hsz, hsb, freqOf]

private lemma consistent_mergePair_same_sibling (t : HuffTree) (b z fz : ℕ)
    (h_sib : areSiblings z b t) (h_cons : consistent t) (hz_ne_b : z ≠ b) :
    consistent (mergePair z b z fz t) := by
  induction h_sib with
  | here fa fb => simp [mergePair, consistent]
  | here' fa fb => simp [mergePair, consistent]
  | inLeft l r h_sib_l ih =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_l with ⟨hz_l, hb_l⟩
    have hz_not_r : z ∉ alphabet r := Finset.disjoint_left.mp hd hz_l
    have hb_not_r : b ∉ alphabet r := Finset.disjoint_left.mp hd hb_l
    have h_merge_r : mergePair z b z fz r = r :=
      mergePair_eq_self_of_not_mem z b z fz r hz_not_r hb_not_r
    have h_l : consistent (mergePair z b z fz l) := ih hcl
    have h_disjoint_merge : Disjoint (alphabet (mergePair z b z fz l)) (alphabet r) := by
      have h_sub : alphabet (mergePair z b z fz l) ⊆ alphabet l ∪ {z} :=
        alphabet_mergePair_subset z b z fz l
      have h_disj_sup : Disjoint (alphabet l ∪ {z}) (alphabet r) := by
        rw [Finset.disjoint_union_left]
        exact ⟨hd, by rw [Finset.disjoint_singleton_left]; exact hz_not_r⟩
      exact Finset.disjoint_of_subset_left h_sub h_disj_sup
    cases l with
    | htLeaf s f => exfalso; cases h_sib_l
    | htInner ll lr =>
      simp [mergePair, h_merge_r, consistent]
      exact ⟨h_l, hcr, h_disjoint_merge⟩
  | inRight l r h_sib_r ih =>
    rcases h_cons with ⟨hcl, hcr, hd⟩
    rcases areSiblings_mem_alphabet h_sib_r with ⟨hz_r, hb_r⟩
    have hz_not_l : z ∉ alphabet l := Finset.disjoint_right.mp hd hz_r
    have hb_not_l : b ∉ alphabet l := Finset.disjoint_right.mp hd hb_r
    have h_merge_l : mergePair z b z fz l = l :=
      mergePair_eq_self_of_not_mem z b z fz l hz_not_l hb_not_l
    have h_r : consistent (mergePair z b z fz r) := ih hcr
    have h_disjoint_merge : Disjoint (alphabet l) (alphabet (mergePair z b z fz r)) := by
      have h_sub : alphabet (mergePair z b z fz r) ⊆ alphabet r ∪ {z} :=
        alphabet_mergePair_subset z b z fz r
      have h_disj_sup : Disjoint (alphabet l) (alphabet r ∪ {z}) := by
        rw [Finset.disjoint_union_right]
        exact ⟨hd, by rw [Finset.disjoint_singleton_right]; exact hz_not_l⟩
      exact Finset.disjoint_of_subset_right h_sub h_disj_sup
    cases r with
    | htLeaf s f => exfalso; cases h_sib_r
    | htInner rl rr =>
      simp [mergePair, h_merge_l, consistent]
      exact ⟨hcl, h_r, h_disjoint_merge⟩private lemma mem_alphabet_splitLeaf_of_ne (t : HuffTree) (z b fa fb x : ℕ) (hx_ne_z : x ≠ z) (hx_ne_b : x ≠ b) :
    x ∈ alphabet (splitLeaf t z z b fa fb) → x ∈ alphabet t := by
  induction t with
  | htLeaf sym f =>
    by_cases hz : sym = z
    · subst hz; simp [splitLeaf, alphabet, hx_ne_z, hx_ne_b]
    · simp [splitLeaf, alphabet, hz]
  | htInner l r ihl ihr =>
    simp [splitLeaf, alphabet, Finset.mem_union]
    intro h
    rcases h with (h | h)
    · exact Or.inl (ihl h)
    · exact Or.inr (ihr h)private lemma freqOf_splitLeaf_of_ne (t : HuffTree) (z b fa fb x : ℕ) (hx_ne_z : x ≠ z) (hx_ne_b : x ≠ b) :
    freqOf x (splitLeaf t z z b fa fb) = freqOf x t := by
  induction t with
  | htLeaf sym f =>
    by_cases hz : sym = z
    · subst hz; simp [splitLeaf, freqOf, hx_ne_z, hx_ne_b, Ne.symm hx_ne_z, Ne.symm hx_ne_b]
    · simp [splitLeaf, freqOf, hz]
  | htInner l r ihl ihr =>
    simp [splitLeaf, freqOf, ihl, ihr]

private lemma freqOf_splitLeaf_left (t : HuffTree) (z b fa fb : ℕ) (h_cons : consistent t)
    (hz_in : z ∈ alphabet t) (hb_not : b ∉ alphabet t) (hz_ne_b : z ≠ b) :
    freqOf z (splitLeaf t z z b fa fb) = fa := by
  revert h_cons hz_in hb_not hz_ne_b
  induction t with
  | htLeaf sym f =>
    intro h_cons hz_in hb_not hz_ne_b
    have hz_sym : z = sym := by simpa [alphabet] using hz_in
    subst hz_sym
    simp [splitLeaf, freqOf, hz_ne_b, hz_ne_b.symm, add_zero]
  | htInner l r ihl ihr =>
    intro h_cons hz_in hb_not hz_ne_b
    rcases h_cons with ⟨hcl, hcr, hd⟩
    simp [splitLeaf, freqOf]
    have hz_union : z ∈ alphabet l ∨ z ∈ alphabet r := by simpa [alphabet] using hz_in
    rcases hz_union with (hz_l | hz_r)
    · have hz_not_r : z ∉ alphabet r := Finset.disjoint_left.mp hd hz_l
      rw [splitLeaf_eq_of_z_not_mem r z z b fa fb hz_not_r]
      have hz_freq_r : freqOf z r = 0 := freqOf_eq_zero_of_not_mem z r hz_not_r
      rw [hz_freq_r, add_zero]
      apply ihl hcl hz_l (by intro h; apply hb_not; simp [alphabet, h]) hz_ne_b
    · have hz_not_l : z ∉ alphabet l := Finset.disjoint_right.mp hd hz_r
      rw [splitLeaf_eq_of_z_not_mem l z z b fa fb hz_not_l]
      have hz_freq_l : freqOf z l = 0 := freqOf_eq_zero_of_not_mem z l hz_not_l
      rw [hz_freq_l, zero_add]
      apply ihr hcr hz_r (by intro h; apply hb_not; simp [alphabet, h]) hz_ne_b

private lemma freqOf_splitLeaf_right (t : HuffTree) (z b fa fb : ℕ) (h_cons : consistent t)
    (hz_in : z ∈ alphabet t) (hb_not : b ∉ alphabet t) (hz_ne_b : z ≠ b) :
    freqOf b (splitLeaf t z z b fa fb) = fb := by
  revert h_cons hz_in hb_not hz_ne_b
  induction t with
  | htLeaf sym f =>
    intro h_cons hz_in hb_not hz_ne_b
    have hz_sym : z = sym := by simpa [alphabet] using hz_in
    subst hz_sym
    simp [splitLeaf, freqOf, hz_ne_b, hz_ne_b.symm, add_zero]
  | htInner l r ihl ihr =>
    intro h_cons hz_in hb_not hz_ne_b
    rcases h_cons with ⟨hcl, hcr, hd⟩
    simp [splitLeaf, freqOf]
    have hz_union : z ∈ alphabet l ∨ z ∈ alphabet r := by simpa [alphabet] using hz_in
    rcases hz_union with (hz_l | hz_r)
    · have hz_not_r : z ∉ alphabet r := Finset.disjoint_left.mp hd hz_l
      rw [splitLeaf_eq_of_z_not_mem r z z b fa fb hz_not_r]
      have hb_freq_r : freqOf b r = 0 := freqOf_eq_zero_of_not_mem b r (by intro h; apply hb_not; simp [alphabet, h])
      rw [hb_freq_r, add_zero]
      apply ihl hcl hz_l (by intro h; apply hb_not; simp [alphabet, h]) hz_ne_b
    · have hz_not_l : z ∉ alphabet l := Finset.disjoint_right.mp hd hz_r
      rw [splitLeaf_eq_of_z_not_mem l z z b fa fb hz_not_l]
      have hb_freq_l : freqOf b l = 0 := freqOf_eq_zero_of_not_mem b l (by intro h; apply hb_not; simp [alphabet, h])
      rw [hb_freq_l, zero_add]
      apply ihr hcr hz_r (by intro h; apply hb_not; simp [alphabet, h]) hz_ne_b

private lemma consistent_splitLeaf_v2 (t : HuffTree) (z b fa fb : ℕ) (h_cons : consistent t)
    (hz_in : z ∈ alphabet t) (hb_not : b ∉ alphabet t) (hz_ne_b : z ≠ b) :
    consistent (splitLeaf t z z b fa fb) := by
  revert h_cons hz_in hb_not hz_ne_b
  induction t with
  | htLeaf sym f =>
    intro h_cons hz_in hb_not hz_ne_b
    by_cases hz : sym = z
    · subst hz; simp [splitLeaf, consistent, alphabet, hz_ne_b]
    · simp [splitLeaf, consistent, hz]
  | htInner l r ihl ihr =>
    intro h_cons hz_in hb_not hz_ne_b
    rcases h_cons with ⟨hcl, hcr, hd⟩
    have h_empty := Finset.disjoint_iff_inter_eq_empty.mp hd
    have hb_not_l : b ∉ alphabet l := by intro h; apply hb_not; simp [alphabet, h]
    have hb_not_r : b ∉ alphabet r := by intro h; apply hb_not; simp [alphabet, h]
    have hz_union : z ∈ alphabet l ∨ z ∈ alphabet r := by
      simpa [alphabet] using hz_in
    rcases hz_union with (hz_l | hz_r)
    · have hz_not_r : z ∉ alphabet r := Finset.disjoint_left.mp hd hz_l
      have h_split_r : splitLeaf r z z b fa fb = r :=
        splitLeaf_eq_of_z_not_mem r z z b fa fb hz_not_r
      rw [splitLeaf, consistent, h_split_r]
      have h_l := ihl hcl hz_l hb_not_l hz_ne_b
      have h_disjoint : Disjoint (alphabet (splitLeaf l z z b fa fb)) (alphabet r) := by
        rw [Finset.disjoint_iff_inter_eq_empty]
        by_contra h_ne
        have h_nonempty := Finset.nonempty_iff_ne_empty.mpr h_ne
        rcases h_nonempty with ⟨s, hs⟩
        rcases Finset.mem_inter.mp hs with ⟨hs_lsplit, hs_r⟩
        by_cases hsb : s = b
        · subst s; apply hb_not; simp [alphabet, hs_r]
        · by_cases hsz : s = z
          · subst s; exact hz_not_r hs_r
          · have hs_l : s ∈ alphabet l :=
              mem_alphabet_splitLeaf_of_ne l z b fa fb s hsz hsb hs_lsplit
            have hi := Finset.mem_inter.mpr ⟨hs_l, hs_r⟩
            rw [h_empty] at hi; simp at hi
      exact And.intro h_l (And.intro hcr h_disjoint)
    · have hz_not_l : z ∉ alphabet l := Finset.disjoint_right.mp hd hz_r
      have h_split_l : splitLeaf l z z b fa fb = l :=
        splitLeaf_eq_of_z_not_mem l z z b fa fb hz_not_l
      rw [splitLeaf, consistent, h_split_l]
      have h_r := ihr hcr hz_r hb_not_r hz_ne_b
      have h_disjoint : Disjoint (alphabet l) (alphabet (splitLeaf r z z b fa fb)) := by
        rw [Finset.disjoint_iff_inter_eq_empty]
        by_contra h_ne
        have h_nonempty := Finset.nonempty_iff_ne_empty.mpr h_ne
        rcases h_nonempty with ⟨s, hs⟩
        rcases Finset.mem_inter.mp hs with ⟨hs_l, hs_rsplit⟩
        by_cases hsb : s = b
        · subst s; apply hb_not; simp [alphabet, hs_l]
        · by_cases hsz : s = z
          · subst s; exact hz_not_l hs_l
          · have hs_r : s ∈ alphabet r :=
              mem_alphabet_splitLeaf_of_ne r z b fa fb s hsz hsb hs_rsplit
            have hi := Finset.mem_inter.mpr ⟨hs_l, hs_r⟩
            rw [h_empty] at hi; simp at hi
      exact And.intro hcl (And.intro h_r h_disjoint)

lemma splitLeaf_pos_of_pos (t : HuffTree) (z b fa fb : ℕ)
    (h_cons : consistent t) (h_z_in : z ∈ alphabet t)
    (hb_not_mem : b ∉ alphabet t) (hz_ne_b : z ≠ b)
    (h_fa_pos : fa > 0) (h_fb_pos : fb > 0)
    (h_pos : ∀ s ∈ alphabet t, freqOf s t > 0) :
    ∀ s ∈ alphabet (splitLeaf t z z b fa fb),
      freqOf s (splitLeaf t z z b fa fb) > 0 := by
  intro s hs
  by_cases hsz : s = z
  · subst s
    rw [freqOf_splitLeaf_left t z b fa fb h_cons h_z_in hb_not_mem hz_ne_b]
    exact h_fa_pos
  · by_cases hsb : s = b
    · subst s
      rw [freqOf_splitLeaf_right t z b fa fb h_cons h_z_in hb_not_mem hz_ne_b]
      exact h_fb_pos
    · rw [freqOf_splitLeaf_of_ne t z b fa fb s hsz hsb]
      exact h_pos s (mem_alphabet_splitLeaf_of_ne t z b fa fb s hsz hsb hs)structure SplitFreqCandidate (t base tree : HuffTree) (z b fa fb : ℕ) where
  cons : consistent tree
  freq_rel : ∀ s, freqOf s tree = freqOf s (splitLeaf t z z b fa fb)
  cost_le : (cost tree : ℤ) ≤ (cost base : ℤ)namespace SplitFreqCandidatetheorem ofBase {t base : HuffTree} {z b fa fb : ℕ}
    (h_cons : consistent base)
    (h_freq_rel : ∀ s, freqOf s base = freqOf s (splitLeaf t z z b fa fb)) :
    SplitFreqCandidate t base base z b fa fb :=
  { cons := h_cons
    freq_rel := h_freq_rel
    cost_le := le_refl _ }

theorem ofExchange {t base w : HuffTree} {z b fa fb a x : ℕ}
    (h_ne : a ≠ x) (ha_in : a ∈ alphabet w) (hx_in : x ∈ alphabet w)
    (h_cons_w : consistent w)
    (h_freq_rel_w : ∀ s, freqOf s w = freqOf s (splitLeaf t z z b fa fb))
    (h_cost_le : (cost (swapFreqs a x (swapLeaves a x w)) : ℤ) ≤ (cost base : ℤ)) :
    SplitFreqCandidate t base (swapFreqs a x (swapLeaves a x w)) z b fa fb :=
  { cons := by
      dsimp [swapFreqs]
      apply consistent_replaceFreq x _ (replaceFreq a _ (swapLeaves a x w))
      apply consistent_replaceFreq a _ (swapLeaves a x w)
      exact consistent_swapLeaves a x w h_cons_w
    freq_rel := by
      intro s
      rw [freqOf_exchangeLeaf w a x s h_ne ha_in hx_in h_cons_w]
      exact h_freq_rel_w s
    cost_le := h_cost_le }

theorem freq_left {t base tree : HuffTree} {z b fa fb : ℕ}
    (C : SplitFreqCandidate t base tree z b fa fb)
    (h_cons_t : consistent t) (h_z_in : z ∈ alphabet t)
    (hb_not_mem : b ∉ alphabet t) (hz_ne_b : z ≠ b) :
    freqOf z tree = fa := by
  rw [C.freq_rel z]
  exact freqOf_splitLeaf_left t z b fa fb h_cons_t h_z_in hb_not_mem hz_ne_b

theorem freq_right {t base tree : HuffTree} {z b fa fb : ℕ}
    (C : SplitFreqCandidate t base tree z b fa fb)
    (h_cons_t : consistent t) (h_z_in : z ∈ alphabet t)
    (hb_not_mem : b ∉ alphabet t) (hz_ne_b : z ≠ b) :
    freqOf b tree = fb := by
  rw [C.freq_rel b]
  exact freqOf_splitLeaf_right t z b fa fb h_cons_t h_z_in hb_not_mem hz_ne_b

theorem freq_left_le_of_min {t base tree : HuffTree} {z b fa fb s : ℕ}
    (C : SplitFreqCandidate t base tree z b fa fb)
    (h_cons_t : consistent t) (h_z_in : z ∈ alphabet t)
    (hb_not_mem : b ∉ alphabet t) (hz_ne_b : z ≠ b)
    (h_fa_min : ∀ s ∈ alphabet t, fa ≤ freqOf s t)
    (h_s_in_t : s ∈ alphabet t) (h_s_ne_z : s ≠ z) (h_s_ne_b : s ≠ b) :
    freqOf z tree ≤ freqOf s tree := by
  rw [C.freq_left h_cons_t h_z_in hb_not_mem hz_ne_b]
  rw [C.freq_rel s, freqOf_splitLeaf_of_ne t z b fa fb s h_s_ne_z h_s_ne_b]
  exact h_fa_min s h_s_in_t

theorem freq_right_le_of_min {t base tree : HuffTree} {z b fa fb s : ℕ}
    (C : SplitFreqCandidate t base tree z b fa fb)
    (h_cons_t : consistent t) (h_z_in : z ∈ alphabet t)
    (hb_not_mem : b ∉ alphabet t) (hz_ne_b : z ≠ b)
    (h_fb_min : ∀ s ∈ alphabet t, s ≠ z → fb ≤ freqOf s t)
    (h_s_in_t : s ∈ alphabet t) (h_s_ne_z : s ≠ z) (h_s_ne_b : s ≠ b) :
    freqOf b tree ≤ freqOf s tree := by
  rw [C.freq_right h_cons_t h_z_in hb_not_mem hz_ne_b]
  rw [C.freq_rel s, freqOf_splitLeaf_of_ne t z b fa fb s h_s_ne_z h_s_ne_b]
  exact h_fb_min s h_s_in_t h_s_ne_z

theorem freq_eq_zero_of_not_mem {t base tree : HuffTree} {z b fa fb s : ℕ}
    (C : SplitFreqCandidate t base tree z b fa fb)
    (h_s_not_mem : s ∉ alphabet t) (h_s_ne_z : s ≠ z) (h_s_ne_b : s ≠ b) :
    freqOf s tree = 0 := by
  rw [C.freq_rel s, freqOf_splitLeaf_of_ne t z b fa fb s h_s_ne_z h_s_ne_b]
  exact freqOf_eq_zero_of_not_mem s t h_s_not_mem

theorem freq_left_le_right {t base tree : HuffTree} {z b fa fb : ℕ}
    (C : SplitFreqCandidate t base tree z b fa fb)
    (h_cons_t : consistent t) (h_z_in : z ∈ alphabet t)
    (hb_not_mem : b ∉ alphabet t) (hz_ne_b : z ≠ b)
    (h_fa_le_fb : fa ≤ fb) :
    freqOf z tree ≤ freqOf b tree := by
  rw [C.freq_left h_cons_t h_z_in hb_not_mem hz_ne_b,
    C.freq_right h_cons_t h_z_in hb_not_mem hz_ne_b]
  exact h_fa_le_fb

theorem sameFreqs_prune_zero {t base tree : HuffTree} {z b fa fb keep drop : ℕ}
    (C : SplitFreqCandidate t base tree z b fa fb)
    (h_sib : areSiblings keep drop tree) (h_ne : keep ≠ drop)
    (h_drop_zero : freqOf drop tree = 0) :
    sameFreqs (splitLeaf t z z b fa fb)
      (mergePair keep drop keep (freqOf keep tree + freqOf drop tree) tree) := by
  intro s
  rw [freqOf_mergePair_same_sibling tree drop keep s h_sib C.cons h_ne,
    h_drop_zero, add_zero]
  by_cases h_keep : s = keep
  · subst s
    simpa using (C.freq_rel keep).symm
  · by_cases h_drop : s = drop
    · subst s
      simpa [h_ne.symm, h_drop_zero] using (C.freq_rel drop).symm
    · simp [h_keep, h_drop, (C.freq_rel s).symm]end SplitFreqCandidatestructure SplitMergeCandidate (t base : HuffTree) (z b fa fb : ℕ) where
  tree : HuffTree
  freq : SplitFreqCandidate t base tree z b fa fb
  sibling : areSiblings z b tree

theorem merge_split_siblings_cost_bound (t v v' : HuffTree) (z b fa fb : ℕ)
    (h_opt_t : ∀ u, consistent u → sameFreqs t u → cost t ≤ cost u)
    (hb_fb_t : freqOf b t = 0) (hz_ne_b : z ≠ b)
    (h_sum : freqOf z t = fa + fb)
    (h_sib_zb : areSiblings z b v') (h_cons_v' : consistent v')
    (h_fz_v' : freqOf z v' = fa) (h_fb_v' : freqOf b v' = fb)
    (h_freq_rel : ∀ s, freqOf s v' = freqOf s (splitLeaf t z z b fa fb))
    (h_cost_v'_le : (cost v' : ℤ) ≤ (cost v : ℤ)) :
    cost t + fa + fb ≤ cost v := by
  let v'' := mergePair z b z (fa + fb) v'
  have h_cost_v'' : (cost v'' : ℤ) = (cost v' : ℤ) - (fa : ℤ) - (fb : ℤ) :=
    cost_mergePair_of_areSiblings v' z b z fa fb h_sib_zb h_cons_v'
      hz_ne_b h_fz_v' h_fb_v' rfl
  have h_cons_v'' : consistent v'' :=
    consistent_mergePair_same_sibling v' b z (fa + fb) h_sib_zb h_cons_v' hz_ne_b
  have h_sameFreqs_v'' : sameFreqs t v'' := by
    intro s
    dsimp [v'']
    have h_freq_sum : freqOf z v' + freqOf b v' = fa + fb := by
      rw [h_fz_v', h_fb_v']
    have h_lemma := freqOf_mergePair_same_sibling v' b z s h_sib_zb h_cons_v' hz_ne_b
    have h_merge_eq : freqOf s (mergePair z b z (fa + fb) v') =
        freqOf s (mergePair z b z (freqOf z v' + freqOf b v') v') := by
      rw [← h_freq_sum]
    rw [h_merge_eq, h_lemma]
    split_ifs with hsz hsb
    · rw [hsz, h_fz_v', h_fb_v', h_sum]
    · rw [hsb, hb_fb_t]
    · rw [h_freq_rel s, freqOf_splitLeaf_of_ne t z b fa fb s hsz hsb]
  have h_t_le : (cost t : ℤ) ≤ (cost v'' : ℤ) := by
    exact_mod_cast h_opt_t v'' h_cons_v'' h_sameFreqs_v''
  exact_mod_cast (show (cost t : ℤ) + (fa : ℤ) + (fb : ℤ) ≤ (cost v : ℤ) from by
    linarith)namespace SplitMergeCandidatedef ofBase {t base : HuffTree} {z b fa fb : ℕ}
    (h_sib : areSiblings z b base) (h_cons : consistent base)
    (h_freq_rel : ∀ s, freqOf s base = freqOf s (splitLeaf t z z b fa fb)) :
    SplitMergeCandidate t base z b fa fb where
  tree := base
  freq := SplitFreqCandidate.ofBase h_cons h_freq_rel
  sibling := h_sibdef ofExchange {t base w : HuffTree} {z b fa fb a x : ℕ}
    (h_ne : a ≠ x) (ha_in : a ∈ alphabet w) (hx_in : x ∈ alphabet w)
    (h_cons_w : consistent w)
    (h_freq_rel_w : ∀ s, freqOf s w = freqOf s (splitLeaf t z z b fa fb))
    (h_sib : areSiblings z b (swapFreqs a x (swapLeaves a x w)))
    (h_cost_le : (cost (swapFreqs a x (swapLeaves a x w)) : ℤ) ≤ (cost base : ℤ)) :
    SplitMergeCandidate t base z b fa fb where
  tree := swapFreqs a x (swapLeaves a x w)
  freq := SplitFreqCandidate.ofExchange h_ne ha_in hx_in h_cons_w h_freq_rel_w h_cost_le
  sibling := h_sibdef ofFreqCandidate {t base tree : HuffTree} {z b fa fb : ℕ}
    (C : SplitFreqCandidate t base tree z b fa fb)
    (h_sib : areSiblings z b tree) :
    SplitMergeCandidate t base z b fa fb where
  tree := tree
  freq := C
  sibling := h_sibtheorem cost_bound {t base : HuffTree} {z b fa fb : ℕ}
    (C : SplitMergeCandidate t base z b fa fb)
    (h_opt_t : ∀ u, consistent u → sameFreqs t u → cost t ≤ cost u)
    (h_cons_t : consistent t) (h_z_in : z ∈ alphabet t)
    (hb_not_mem : b ∉ alphabet t) (hz_ne_b : z ≠ b)
    (hb_fb_t : freqOf b t = 0) (h_sum : freqOf z t = fa + fb) :
    cost t + fa + fb ≤ cost base :=
  merge_split_siblings_cost_bound t base C.tree z b fa fb h_opt_t hb_fb_t hz_ne_b
    h_sum C.sibling C.freq.cons
    (C.freq.freq_left h_cons_t h_z_in hb_not_mem hz_ne_b)
    (C.freq.freq_right h_cons_t h_z_in hb_not_mem hz_ne_b)
    C.freq.freq_rel C.freq.cost_leend SplitMergeCandidatenamespace SplitFreqCandidatedef exchangeToMerge {t base tree : HuffTree} {z b fa fb a x : ℕ}
    (C : SplitFreqCandidate t base tree z b fa fb)
    (h_ne : a ≠ x) (ha_in : a ∈ alphabet tree) (hx_in : x ∈ alphabet tree)
    (h_sib : areSiblings z b (swapFreqs a x (swapLeaves a x tree)))
    (h_cost_step : (cost (swapFreqs a x (swapLeaves a x tree)) : ℤ) ≤ (cost tree : ℤ)) :
    SplitMergeCandidate t base z b fa fb :=
  SplitMergeCandidate.ofFreqCandidate
    (SplitFreqCandidate.ofExchange (t := t) (base := base) (w := tree)
      (z := z) (b := b) (fa := fa) (fb := fb) (a := a) (x := x)
      h_ne ha_in hx_in C.cons C.freq_rel (le_trans h_cost_step C.cost_le))
    h_sibend SplitFreqCandidate

theorem optimum_splitLeaf (t : HuffTree) (z b fa fb : ℕ)
    (h_opt : optimum t) (h_z_in : z ∈ alphabet t)
    (hb_not_mem : b ∉ alphabet t) (hz_ne_b : z ≠ b)
    (h_fa_pos : fa > 0) (h_fb_pos : fb > 0) (h_fa_le_fb : fa ≤ fb)
    (h_fa_min : ∀ s ∈ alphabet t, fa ≤ freqOf s t)
    (h_fb_min : ∀ s ∈ alphabet t, s ≠ z → fb ≤ freqOf s t)
    (h_sum : freqOf z t = fa + fb) :
    optimum (splitLeaf t z z b fa fb) := by
  rcases h_opt with ⟨h_cons_t, h_pos_t, h_opt_t⟩
  have hb_fb_t : freqOf b t = 0 := freqOf_eq_zero_of_not_mem b t hb_not_mem
  refine ⟨consistent_splitLeaf_v2 t z b fa fb h_cons_t h_z_in hb_not_mem hz_ne_b,
    splitLeaf_pos_of_pos t z b fa fb h_cons_t h_z_in hb_not_mem hz_ne_b
      h_fa_pos h_fb_pos h_pos_t, ?_⟩
  intro u h_cons_u h_sameFreqs
  rw [cost_splitLeaf_eq t z z b fa fb h_cons_t h_z_in h_sum]
  let P (n : ℕ) : Prop := ∀ (v : HuffTree), nodeCount v = n → consistent v →
    sameFreqs (splitLeaf t z z b fa fb) v → cost t + fa + fb ≤ cost v
  have hP : ∀ n, (∀ m < n, P m) → P n := by
    intro n IH v hn h_cons_v h_sameFreqs_v
    have Cbase : SplitFreqCandidate t v v z b fa fb :=
      SplitFreqCandidate.ofBase h_cons_v (fun s => (h_sameFreqs_v s).symm)
    have h_freq_z_le_b_v : freqOf z v ≤ freqOf b v :=
      Cbase.freq_left_le_right h_cons_t h_z_in hb_not_mem hz_ne_b h_fa_le_fb
    have hz_in_v : z ∈ alphabet v :=
      mem_alphabet_of_freq_pos z v
        (by simpa [Cbase.freq_left h_cons_t h_z_in hb_not_mem hz_ne_b] using h_fa_pos)
    have hb_in_v : b ∈ alphabet v :=
      mem_alphabet_of_freq_pos b v
        (by simpa [Cbase.freq_right h_cons_t h_z_in hb_not_mem hz_ne_b] using h_fb_pos)
    have h_height : height v ≥ 1 :=
      height_pos_of_distinct_mem v hz_in_v hb_in_v hz_ne_b
    have h_dsp_sib : areSiblings (deepestSiblingPair v).1 (deepestSiblingPair v).2 v :=
      deepestSiblingPair_areSiblings v h_cons_v h_height
    set x := (deepestSiblingPair v).1 with hx_def
    set y := (deepestSiblingPair v).2 with hy_def
    have h_dsp_sib_xy : areSiblings x y v := by simpa [hx_def, hy_def] using h_dsp_sib
    have hx_in : x ∈ alphabet v := by simpa [hx_def] using deepestSiblingPair_mem1 v
    have hy_in : y ∈ alphabet v := by simpa [hy_def] using deepestSiblingPair_mem2 v
    rcases deepestSiblingPair_depth v h_cons_v with ⟨h_depth_x_raw, h_depth_y_raw⟩
    have h_depth_x : (depthOf x v).getD 0 = height v := by simpa [hx_def] using h_depth_x_raw
    have h_depth_y : (depthOf y v).getD 0 = height v := by simpa [hy_def] using h_depth_y_raw
    have h_depth_le_x (s : ℕ) : (depthOf s v).getD 0 ≤ (depthOf x v).getD 0 := by
      rw [h_depth_x]; exact depthOf_getD_le_height v s
    have h_depth_le_y (s : ℕ) : (depthOf s v).getD 0 ≤ (depthOf y v).getD 0 := by
      rw [h_depth_y]; exact depthOf_getD_le_height v s
    have h_depth_z_le_dx : (depthOf z v).getD 0 ≤ (depthOf x v).getD 0 := h_depth_le_x z
    have h_depth_b_le_dy : (depthOf b v).getD 0 ≤ (depthOf y v).getD 0 := h_depth_le_y b
    have h_depth_b_le_dx : (depthOf b v).getD 0 ≤ (depthOf x v).getD 0 := h_depth_le_x b
    have h_merge_conclude (C : SplitMergeCandidate t v z b fa fb) :
        cost t + fa + fb ≤ cost v :=
      C.cost_bound h_opt_t h_cons_t h_z_in hb_not_mem hz_ne_b hb_fb_t h_sum
    have h_exchange_leaf_conclude {tree : HuffTree} {a x' : ℕ}
        (C : SplitFreqCandidate t v tree z b fa fb)
        (h_ne : a ≠ x') (ha_in : a ∈ alphabet tree) (hx_in' : x' ∈ alphabet tree)
        (h_freq : freqOf a tree ≤ freqOf x' tree)
        (h_depth : (depthOf a tree).getD 0 ≤ (depthOf x' tree).getD 0)
        (h_sib_swap : areSiblings z b (swapLeaves a x' tree)) :
        cost t + fa + fb ≤ cost v := by
      exact h_merge_conclude
        (C.exchangeToMerge h_ne ha_in hx_in'
          (areSiblings_swapFreqs_preserved (swapLeaves a x' tree) z b a x' h_sib_swap)
          (cost_exchangeLeaf_le tree a x' C.cons ha_in hx_in' h_ne h_freq h_depth))
    have h_exchange_sibling_order_conclude {tree : HuffTree}
        (C : SplitFreqCandidate t v tree z b fa fb)
        (h_sib_bz : areSiblings b z tree)
        (h_depth : (depthOf z tree).getD 0 ≤ (depthOf b tree).getD 0) :
        cost t + fa + fb ≤ cost v := by
      exact h_exchange_leaf_conclude C hz_ne_b (areSiblings_mem_alphabet h_sib_bz).2
        (areSiblings_mem_alphabet h_sib_bz).1
        (C.freq_left_le_right h_cons_t h_z_in hb_not_mem hz_ne_b h_fa_le_fb)
        h_depth
        (by
          simpa [swapLeaves_comm b z tree] using
            areSiblings_swap_siblings h_sib_bz (Ne.symm hz_ne_b))
    have h_exchange_leaf_candidate {a x' : ℕ}
        (h_ne : a ≠ x') (ha_in : a ∈ alphabet v) (hx_in' : x' ∈ alphabet v)
        (h_freq : freqOf a v ≤ freqOf x' v)
        (h_depth : (depthOf a v).getD 0 ≤ (depthOf x' v).getD 0) :
        SplitFreqCandidate t v (swapFreqs a x' (swapLeaves a x' v)) z b fa fb :=
      SplitFreqCandidate.ofExchange (t := t) (base := v) (w := v)
        (z := z) (b := b) (fa := fa) (fb := fb) (a := a) (x := x')
        h_ne ha_in hx_in' h_cons_v (fun s => (h_sameFreqs_v s).symm)
        (cost_exchangeLeaf_le v a x' h_cons_v ha_in hx_in' h_ne h_freq h_depth)
    have h_prune_zero_candidate_conclude {w : HuffTree} {keep drop : ℕ}
        (C : SplitFreqCandidate t v w z b fa fb)
        (h_nodes_w : nodeCount w = nodeCount v)
        (h_sib : areSiblings keep drop w) (h_ne : keep ≠ drop)
        (h_drop_zero : freqOf drop w = 0) :
        cost t + fa + fb ≤ cost v := by
      let v_pruned := mergePair keep drop keep (freqOf keep w + freqOf drop w) w
      have h_sameFreqs_pruned : sameFreqs (splitLeaf t z z b fa fb) v_pruned := by
        simpa [v_pruned] using C.sameFreqs_prune_zero h_sib h_ne h_drop_zero
      have h_cost_pruned_le_v : cost v_pruned ≤ cost v := by
        have h_cost_int : (cost v_pruned : ℤ) = (cost w : ℤ) - (freqOf keep w : ℤ) := by
          have h := cost_mergePair_of_areSiblings w keep drop keep (freqOf keep w) 0
            (fz := freqOf keep w + freqOf drop w)
            h_sib C.cons h_ne rfl h_drop_zero (by rw [h_drop_zero, add_zero])
          simpa [v_pruned, h_drop_zero, add_zero] using h
        have h_goal : (cost v_pruned : ℤ) ≤ (cost v : ℤ) := by
          have h_fk_nonneg : (0 : ℤ) ≤ freqOf keep w := by exact_mod_cast Nat.zero_le (freqOf keep w)
          have h_cost_w_le_v := C.cost_le
          linarith
        exact_mod_cast h_goal
      have h_nodeCount_pruned_lt : nodeCount v_pruned < n := by
        simpa [v_pruned, h_nodes_w, hn] using
          nodeCount_mergePair_lt_of_areSiblings w keep drop keep
            (freqOf keep w + freqOf drop w) h_sib h_ne
      have h_cons_pruned : consistent v_pruned := by
        simpa [v_pruned] using
          consistent_mergePair_same_sibling w drop keep
            (freqOf keep w + freqOf drop w) h_sib C.cons h_ne
      exact le_trans
        (IH (nodeCount v_pruned) h_nodeCount_pruned_lt v_pruned rfl h_cons_pruned h_sameFreqs_pruned)
        h_cost_pruned_le_v
    have h_resolve_z_pair_conclude {tree : HuffTree} {y' : ℕ}
        (C : SplitFreqCandidate t v tree z b fa fb) (h_nodes_tree : nodeCount tree = nodeCount v)
        (h_sib_zy : areSiblings z y' tree)
        (h_depth : (depthOf b tree).getD 0 ≤ (depthOf y' tree).getD 0) :
        cost t + fa + fb ≤ cost v := by
      by_cases hy'_eq_b : y' = b
      · rw [hy'_eq_b] at h_sib_zy
        exact h_merge_conclude (SplitMergeCandidate.ofFreqCandidate C h_sib_zy)
      · have hz_ne_y' : z ≠ y' := areSiblings_ne tree z y' C.cons h_sib_zy
        by_cases hy'_in_t : y' ∈ alphabet t
        · have hb_in_tree : b ∈ alphabet tree :=
            mem_alphabet_of_freq_pos b tree
              (by simpa [C.freq_right h_cons_t h_z_in hb_not_mem hz_ne_b] using h_fb_pos)
          have h_freq_b_y' : freqOf b tree ≤ freqOf y' tree :=
            C.freq_right_le_of_min h_cons_t h_z_in hb_not_mem hz_ne_b
              h_fb_min hy'_in_t (Ne.symm hz_ne_y') hy'_eq_b
          exact h_exchange_leaf_conclude C (Ne.symm hy'_eq_b) hb_in_tree
            (areSiblings_mem_alphabet h_sib_zy).2
            h_freq_b_y' h_depth
            (areSiblings_exchangeRight tree z b y' h_sib_zy (Ne.symm hz_ne_b)
              (Ne.symm hy'_eq_b) hz_ne_y')
        · exact h_prune_zero_candidate_conclude C h_nodes_tree h_sib_zy hz_ne_y'
            (C.freq_eq_zero_of_not_mem hy'_in_t (Ne.symm hz_ne_y') hy'_eq_b)
    have h_exchange_z_then_resolve {x' y' : ℕ}
        (h_ne : z ≠ x') (hx'_in : x' ∈ alphabet v) (h_sib_x'y' : areSiblings x' y' v)
        (hz_ne_y' : z ≠ y') (hx'_ne_y' : x' ≠ y')
        (h_freq : freqOf z v ≤ freqOf x' v)
        (h_depth_exchange : (depthOf z v).getD 0 ≤ (depthOf x' v).getD 0)
        (h_depth_resolve : (depthOf b (swapFreqs z x' (swapLeaves z x' v))).getD 0 ≤
          (depthOf y' (swapFreqs z x' (swapLeaves z x' v))).getD 0) :
        cost t + fa + fb ≤ cost v := by
      let v1 := swapFreqs z x' (swapLeaves z x' v)
      exact h_resolve_z_pair_conclude
        (by simpa [v1] using h_exchange_leaf_candidate h_ne hz_in_v hx'_in h_freq h_depth_exchange)
        (by simpa [v1] using nodeCount_exchangeLeaf_eq z x' v)
        (by
          simpa [v1] using areSiblings_swapFreqs_preserved (swapLeaves z x' v) z y' z x'
            (areSiblings_exchangeLeft v z x' y' h_sib_x'y' h_ne hz_ne_y' hx'_ne_y'))
        (by simpa [v1] using h_depth_resolve)
    by_cases hxz : x = z
    ·
      rw [hxz] at h_dsp_sib_xy hx_in h_depth_x h_depth_z_le_dx h_depth_b_le_dx
      exact h_resolve_z_pair_conclude Cbase rfl h_dsp_sib_xy h_depth_b_le_dy
    · by_cases hxb : x = b
      ·
        rw [hxb] at h_dsp_sib_xy hx_in h_depth_x h_depth_z_le_dx h_depth_b_le_dx
        have hb_ne_y : b ≠ y := areSiblings_ne v b y h_cons_v h_dsp_sib_xy
        by_cases hyz : y = z
        ·
          rw [hyz] at h_dsp_sib_xy
          exact h_exchange_sibling_order_conclude Cbase h_dsp_sib_xy h_depth_z_le_dx
        ·
          exact h_exchange_z_then_resolve hz_ne_b hb_in_v h_dsp_sib_xy (Ne.symm hyz) hb_ne_y
            h_freq_z_le_b_v h_depth_z_le_dx
            (by
              simpa [depthOf_swapFreqs_eq, depthOf_swapLeaves_at_b z b v hz_ne_b,
                depthOf_swapLeaves_of_not_is z b y v hyz (Ne.symm hb_ne_y)]
                using h_depth_le_y z)
      ·
        have hx_ne_z : x ≠ z := hxz
        have hx_ne_b : x ≠ b := hxb
        have hz_ne_x : z ≠ x := Ne.symm hxz
        have hb_ne_x : b ≠ x := Ne.symm hxb
        have hx_ne_y : x ≠ y := areSiblings_ne v x y h_cons_v h_dsp_sib_xy
        have h_prune_absent_x_sibling_conclude {keep : ℕ}
            (h_sib : areSiblings x keep v) (h_ne : x ≠ keep)
            (h_keep_in : keep ∈ alphabet v) (hx_not_t : x ∉ alphabet t)
            (h_keep_depth : (depthOf keep v).getD 0 = height v) :
            cost t + fa + fb ≤ cost v := by
          let v_pre := swapFreqs x keep (swapLeaves x keep v)
          have h_zero_x : freqOf x v = 0 :=
            Cbase.freq_eq_zero_of_not_mem hx_not_t hx_ne_z hx_ne_b
          exact h_prune_zero_candidate_conclude
            (by
              simpa [v_pre] using h_exchange_leaf_candidate h_ne hx_in h_keep_in
                (by rw [h_zero_x]; omega) (by rw [h_depth_x, h_keep_depth]))
            (by simpa [v_pre] using nodeCount_exchangeLeaf_eq x keep v)
            (by
              simpa [v_pre] using areSiblings_swapFreqs_preserved (swapLeaves x keep v)
                keep x x keep (areSiblings_swap_siblings h_sib h_ne))
            (Ne.symm h_ne)
            (by
              simpa [v_pre, h_zero_x] using
                freqOf_exchangeLeaf v x keep x h_ne hx_in h_keep_in h_cons_v)
        by_cases hyz : y = z
        ·
          rw [hyz] at h_dsp_sib_xy
          by_cases hx_in_t' : x ∈ alphabet t
          ·
            have h_freq_b_x : freqOf b v ≤ freqOf x v :=
              Cbase.freq_right_le_of_min h_cons_t h_z_in hb_not_mem hz_ne_b
                h_fb_min hx_in_t' hx_ne_z hx_ne_b
            let v1 := swapFreqs b x (swapLeaves b x v)
            have h_sib_v1 : areSiblings b z v1 :=
              areSiblings_swapFreqs_preserved (swapLeaves b x v) b z b x
                (areSiblings_exchangeLeft v b x z h_dsp_sib_xy hb_ne_x (Ne.symm hz_ne_b) hx_ne_z)
            have C1 : SplitFreqCandidate t v v1 z b fa fb :=
              h_exchange_leaf_candidate hb_ne_x hb_in_v hx_in
                h_freq_b_x h_depth_b_le_dx
            exact h_exchange_sibling_order_conclude C1 h_sib_v1
              (by
                simpa [v1, depthOf_swapFreqs_eq, depthOf_swapLeaves_at_a b x v hb_ne_x,
                  depthOf_swapLeaves_of_not_is b x z v hz_ne_b (Ne.symm hx_ne_z)]
                  using h_depth_z_le_dx)
          ·
            exact h_prune_absent_x_sibling_conclude h_dsp_sib_xy hx_ne_z
              hz_in_v hx_in_t' (by rw [← hyz]; exact h_depth_y)
        ·
          by_cases hx_in_t : x ∈ alphabet t
          ·
            have h_freq_z_x : freqOf z v ≤ freqOf x v :=
              Cbase.freq_left_le_of_min h_cons_t h_z_in hb_not_mem hz_ne_b
                h_fa_min hx_in_t hx_ne_z hx_ne_b
            exact h_exchange_z_then_resolve hz_ne_x hx_in h_dsp_sib_xy (Ne.symm hyz) hx_ne_y
              h_freq_z_x h_depth_z_le_dx
              (by
                simpa [depthOf_getD_exchange_of_ne z x b v (Ne.symm hz_ne_b) hb_ne_x,
                  depthOf_getD_exchange_of_ne z x y v hyz (Ne.symm hx_ne_y)]
                  using h_depth_b_le_dy)
          ·
            exact h_prune_absent_x_sibling_conclude h_dsp_sib_xy hx_ne_y
              hy_in hx_in_t h_depth_y

  have h_node : P (nodeCount u) := Nat.strong_induction_on (nodeCount u) hP
  exact h_node u rfl h_cons_u h_sameFreqs

Split-leaf optimality interface

The long exchange proof above is intentionally hidden behind the following small certificate. The rest of the Huffman proof only needs to know that a merged symbol z can be split into two positive minimum-frequency symbols z and b, with the old frequency of z equal to their sum.

structure SplitLeafOptimalitySpec (t : HuffTree) (z b fa fb : ℕ) where
  z_mem : z ∈ alphabet t
  b_fresh : b ∉ alphabet t
  sym_ne : z ≠ b
  fa_pos : fa > 0
  fb_pos : fb > 0
  fa_le_fb : fa ≤ fb
  fa_min : ∀ s ∈ alphabet t, fa ≤ freqOf s t
  fb_min : ∀ s ∈ alphabet t, s ≠ z → fb ≤ freqOf s t
  freq_z : freqOf z t = fa + fb

theorem split_leaf_preserves_optimum {t : HuffTree} {z b fa fb : ℕ}
    (S : SplitLeafOptimalitySpec t z b fa fb) (h_opt : optimum t) :
    optimum (splitLeaf t z z b fa fb) :=
  optimum_splitLeaf t z b fa fb h_opt S.z_mem S.b_fresh S.sym_ne
    S.fa_pos S.fb_pos S.fa_le_fb S.fa_min S.fb_min S.freq_z

Bundled forest invariant and greedy-step certificate

              structure Forest where
  trees : List HuffTree
  sorted : forest_sorted trees
  consistent : forest_consistent trees
  allLeaves : ∀ t ∈ trees, height t = 0
  allPos : ∀ t ∈ trees, rootFreq t > 0
  nonempty : trees ≠ []namespace Forestdef length (F : Forest) : ℕ := F.trees.length

Greedy step on a raw list that already satisfies the forest invariant.


def mergeCheapestList (ts : List HuffTree)
    (h_sorted : forest_sorted ts)
    (h_cons : forest_consistent ts)
    (h_leaves : ∀ t ∈ ts, height t = 0)
    (h_pos : ∀ t ∈ ts, rootFreq t > 0)
    (h : ts.length ≥ 2) : Forest :=
  match h_eq : ts with
  | [] => by simp at h
  | [t] => by simp at h
  | t1 :: t2 :: rest =>
      have h1 : height t1 = 0 := h_leaves t1 (by simp)
      have h2 : height t2 = 0 := h_leaves t2 (by simp)
      match h1_eq : t1, h2_eq : t2 with
      | htLeaf sa fa, htLeaf sb fb =>
          let tNew := htLeaf sa (fa + fb)
          {
            trees := insortTree tNew rest,
            sorted := forest_sorted_insortTree_of_sorted tNew rest
              (forest_sorted_tail (htLeaf sb fb) rest
                (forest_sorted_tail (htLeaf sa fa) (htLeaf sb fb :: rest) h_sorted)),
            consistent := by
              have h_fresh : ∀ t ∈ rest, sa ∉ alphabet t := by
                intro t ht
                rw [forest_consistent_cons_iff] at h_cons
                have hdisj : Disjoint (alphabet (htLeaf sa fa)) (alphabet t) :=
                  h_cons.2.2 t (by simp [ht])
                simp [alphabet] at hdisj
                exact hdisj
              exact forest_consistent_insortTree_fresh sa (fa + fb) rest h_fresh
                (forest_consistent_tail (htLeaf sb fb) rest
                  (forest_consistent_tail (htLeaf sa fa) (htLeaf sb fb :: rest) h_cons)),
            allLeaves := forall_mem_insortTree (P := λ t => height t = 0)
              (by simp [tNew, height]) (fun t ht => h_leaves t (by simp [ht])),
            allPos := by
              have h_pos_new : rootFreq tNew > 0 := by
                have h_fa := h_pos (htLeaf sa fa) (by simp)
                have h_fb := h_pos (htLeaf sb fb) (by simp)
                simp [rootFreq, tNew] at h_fa h_fb ⊢
                omega
              exact forall_mem_insortTree (P := λ t => rootFreq t > 0)
                h_pos_new (fun t ht => h_pos t (by simp [ht])),
            nonempty := insortTree_ne_nil tNew rest
          }
      | htInner l r, _ => by simp [height] at h1
      | _, htInner l r => by simp [height] at h2

The bundled greedy reduction step.

def mergeCheapest (F : Forest) (h : F.length ≥ 2) : Forest :=
  mergeCheapestList F.trees F.sorted F.consistent F.allLeaves F.allPos (by simpa [length] using h)

Specification of `mergeCheapest`

              lemma mergeCheapestList_spec (ts : List HuffTree)
    (h_sorted : forest_sorted ts)
    (h_cons : forest_consistent ts)
    (h_leaves : ∀ t ∈ ts, height t = 0)
    (h_pos : ∀ t ∈ ts, rootFreq t > 0)
    (h : ts.length ≥ 2) :
    ∃ sa fa sb fb rest,
      ts = htLeaf sa fa :: htLeaf sb fb :: rest ∧
      (mergeCheapestList ts h_sorted h_cons h_leaves h_pos h).trees =
        insortTree (htLeaf sa (fa + fb)) rest := by
  cases ts with
  | nil => simp at h
  | cons t1 ts1 =>
      cases ts1 with
      | nil => simp at h
      | cons t2 rest =>
          rcases height_eq_zero_iff t1 |>.mp (h_leaves t1 (by simp)) with ⟨sa, fa, h1'⟩
          rcases height_eq_zero_iff t2 |>.mp (h_leaves t2 (by simp)) with ⟨sb, fb, h2'⟩
          subst h1' h2'
          use sa, fa, sb, fb, rest
          constructor
          · rfl
          · simp [mergeCheapestList]

lemma mergeCheapest_spec (F : Forest) (h : F.length ≥ 2) :
    ∃ sa fa sb fb ts,
      F.trees = htLeaf sa fa :: htLeaf sb fb :: ts ∧
      (F.mergeCheapest h).trees = insortTree (htLeaf sa (fa + fb)) ts ∧
      sa ≠ sb ∧
      (∀ t ∈ ts, sa ∉ alphabet t) := by
  rcases mergeCheapestList_spec F.trees F.sorted F.consistent F.allLeaves F.allPos
    (by simpa [length] using h) with ⟨sa, fa, sb, fb, ts, h_eq, h_eq'⟩
  have h_cons_parts :=
    (forest_consistent_cons_iff (htLeaf sa fa) (htLeaf sb fb :: ts)).mp
      (by simpa [h_eq] using F.consistent)
  have h_ne : sa ≠ sb := by
    simpa [alphabet] using h_cons_parts.2.2 (htLeaf sb fb) (by simp)
  have h_fresh : ∀ t ∈ ts, sa ∉ alphabet t := by
    intro t ht
    simpa [alphabet] using h_cons_parts.2.2 t (by simp [ht])
  exact ⟨sa, fa, sb, fb, ts, h_eq, h_eq', h_ne, h_fresh⟩lemma mergeCheapest_length_lt (F : Forest) (h : F.length ≥ 2) :
    (F.mergeCheapest h).length < F.length := by
  rcases mergeCheapest_spec F h with ⟨sa, fa, sb, fb, ts, h_eq, h_eq', _, _⟩
  simp [length, h_eq', h_eq, insortTree_length]

Named certificate for the facts produced by one bundled greedy step. It packages the exact hypotheses needed by optimum_splitLeaf plus the final commutation equality back to the original forest.

structure MergeCheapestSplitReady (F : Forest) (h : F.length ≥ 2) where
  sa : ℕ
  fa : ℕ
  sb : ℕ
  fb : ℕ
  fa_pos : fa > 0
  fb_pos : fb > 0
  sym_ne : sa ≠ sb
  sa_mem : sa ∈ alphabet (huffman (F.mergeCheapest h).trees)
  sb_not_mem : sb ∉ alphabet (huffman (F.mergeCheapest h).trees)
  freq_sa : freqOf sa (huffman (F.mergeCheapest h).trees) = fa + fb
  fa_le_fb : fa ≤ fb
  min_fa : ∀ s ∈ alphabet (huffman (F.mergeCheapest h).trees),
    fa ≤ freqOf s (huffman (F.mergeCheapest h).trees)
  min_fb : ∀ s ∈ alphabet (huffman (F.mergeCheapest h).trees),
    s ≠ sa → fb ≤ freqOf s (huffman (F.mergeCheapest h).trees)
  split_commute :
    splitLeaf (huffman (F.mergeCheapest h).trees) sa sa sb fa fb = huffman F.trees

The bundled greedy step exposes exactly the side conditions needed to split the merged leaf after the recursive Huffman call. This is the main V2 interface: callers do not inspect the forest plumbing directly.


lemma mergeCheapest_split_ready (F : Forest) (h : F.length ≥ 2) :
    Nonempty (MergeCheapestSplitReady F h) := by
  rcases mergeCheapest_spec F h with
    ⟨sa, fa, sb, fb, rest, h_eq_trees, h_eq_reduced, h_ne, h_fresh⟩
  let F' := F.mergeCheapest h
  have h_F'_trees : F'.trees = insortTree (htLeaf sa (fa + fb)) rest := h_eq_reduced
  have h_orig_cons : forest_consistent (htLeaf sa fa :: htLeaf sb fb :: rest) := by
    simpa [h_eq_trees] using F.consistent
  have h_sb_rest_cons : forest_consistent (htLeaf sb fb :: rest) :=
    forest_consistent_tail (htLeaf sa fa) (htLeaf sb fb :: rest) h_orig_cons
  have h_rest_cons : forest_consistent rest :=
    forest_consistent_tail (htLeaf sb fb) rest h_sb_rest_cons
  have h_orig_sorted : forest_sorted (htLeaf sa fa :: htLeaf sb fb :: rest) := by
    simpa [h_eq_trees] using F.sorted
  have h_fa_pos : fa > 0 := by
    simpa [rootFreq] using F.allPos (htLeaf sa fa) (by rw [h_eq_trees]; simp)
  have h_fb_pos : fb > 0 := by
    simpa [rootFreq] using F.allPos (htLeaf sb fb) (by rw [h_eq_trees]; simp)
  have h_a_in_reduced : sa ∈ alphabet (huffman F'.trees) := by
    rw [alphabet_huffman_eq_forest_alphabet F'.trees F'.nonempty, mem_forest_alphabet]
    exact ⟨htLeaf sa (fa + fb), by rw [h_F'_trees, mem_insortTree]; simp, by simp [alphabet]⟩
  have h_b_notin_reduced : sb ∉ alphabet (huffman F'.trees) := by
    rw [alphabet_huffman_eq_forest_alphabet F'.trees F'.nonempty, mem_forest_alphabet]
    rintro ⟨t, ht, h_mem⟩
    rw [h_F'_trees, mem_insortTree] at ht
    rcases ht with (rfl | ht)
    · simp [alphabet] at h_mem
      exact h_ne h_mem.symm
    · rw [forest_consistent_cons_iff] at h_sb_rest_cons
      exact (Finset.disjoint_left.mp (h_sb_rest_cons.2.2 t ht) (by simp [alphabet])) h_mem
  have h_freq_a : freqOf sa (huffman F'.trees) = fa + fb := by
    rw [freqOf_huffman_eq_forest_freq F'.trees sa F'.nonempty, h_F'_trees,
      forest_freq_insortTree, forest_freq_cons]
    have h_zero : forest_freq rest sa = 0 :=
      forest_freq_eq_zero_of_not_mem rest sa (by
        rw [mem_forest_alphabet]
        rintro ⟨t, ht, h_mem⟩
        exact h_fresh t ht h_mem)
    simp [freqOf, h_zero]
  have h_fa_le_fb : fa ≤ fb := by
    simpa [rootFreq] using h_orig_sorted.1
  have h_min : ∀ s ∈ alphabet (huffman F'.trees),
      fa ≤ freqOf s (huffman F'.trees) ∧
      (s ≠ sa → fb ≤ freqOf s (huffman F'.trees)) := by
    intro s hs
    rw [alphabet_huffman_eq_forest_alphabet F'.trees F'.nonempty, mem_forest_alphabet] at hs
    rcases hs with ⟨t, ht, h_mem⟩
    rw [h_F'_trees, mem_insortTree] at ht
    rcases ht with (rfl | ht)
    · have hs_eq : s = sa := by simpa [alphabet] using h_mem
      rw [hs_eq, h_freq_a]
      constructor
      · omega
      · intro _
        omega
    · have h_s_ne_a : s ≠ sa := fun h_eq => h_fresh t ht (by simpa [h_eq] using h_mem)
      have h_freq_leaf : freqOf s (htLeaf sa (fa + fb)) = 0 := by
        simp [freqOf, h_s_ne_a.symm]
      have h_freq_s : freqOf s (huffman F'.trees) = rootFreq t := by
        rw [freqOf_huffman_eq_forest_freq F'.trees s F'.nonempty, h_F'_trees,
          forest_freq_insortTree, forest_freq_cons, h_freq_leaf, zero_add]
        exact forest_freq_eq_rootFreq_of_mem_leaf rest s t
          (fun u hu => F.allLeaves u (by rw [h_eq_trees]; simp [hu]))
          h_rest_cons ht h_mem
      rw [h_freq_s]
      constructor
      · have h_le := rootFreq_le_of_mem_sorted (htLeaf sa fa) (htLeaf sb fb :: rest)
          h_orig_sorted t (by simp [ht])
        simpa [rootFreq] using h_le
      · intro _
        have h_le := rootFreq_le_of_mem_sorted (htLeaf sb fb) rest
          (forest_sorted_tail (htLeaf sa fa) (htLeaf sb fb :: rest) h_orig_sorted) t ht
        simpa [rootFreq] using h_le
  have h_split_commute : splitLeaf (huffman F'.trees) sa sa sb fa fb = huffman F.trees := by
    rw [h_eq_trees, h_F'_trees, splitLeaf_huffman_commute sa sb fa fb rest h_fresh]
    simp [huffman, unite]
  exact ⟨{
    sa := sa
    fa := fa
    sb := sb
    fb := fb
    fa_pos := h_fa_pos
    fb_pos := h_fb_pos
    sym_ne := h_ne
    sa_mem := h_a_in_reduced
    sb_not_mem := h_b_notin_reduced
    freq_sa := h_freq_a
    fa_le_fb := h_fa_le_fb
    min_fa := fun s hs => (h_min s hs).1
    min_fb := fun s hs h_s_ne_a => (h_min s hs).2 h_s_ne_a
    split_commute := h_split_commute
  }⟩

              namespace MergeCheapestSplitReadytheorem splitLeafSpec {F : Forest} {h : F.length ≥ 2} (R : MergeCheapestSplitReady F h) :
    SplitLeafOptimalitySpec (huffman (F.mergeCheapest h).trees) R.sa R.sb R.fa R.fb :=
  { z_mem := R.sa_mem
    b_fresh := R.sb_not_mem
    sym_ne := R.sym_ne
    fa_pos := R.fa_pos
    fb_pos := R.fb_pos
    fa_le_fb := R.fa_le_fb
    fa_min := R.min_fa
    fb_min := R.min_fb
    freq_z := R.freq_sa }

lemma optimum {F : Forest} {h : F.length ≥ 2} (R : MergeCheapestSplitReady F h)
    (h_opt_reduced : optimum (huffman (F.mergeCheapest h).trees)) :
    optimum (huffman F.trees) := by
  rw [← R.split_commute]
  exact split_leaf_preserves_optimum R.splitLeafSpec h_opt_reducedend MergeCheapestSplitReadytheorem mergeCheapest_preserves_optimum (F : Forest) (h : F.length ≥ 2)
    (h_opt_reduced : optimum (huffman (F.mergeCheapest h).trees)) :
    optimum (huffman F.trees) := by
  rcases mergeCheapest_split_ready F h with ⟨R⟩
  exact R.optimum h_opt_reducedend Forestnamespace OptimalV2

private theorem optimum_singleton_forest (F : Forest) (h_len : F.length = 1) :
    optimum (huffman F.trees) := by
  cases h_eq : F.trees with
  | nil => exact False.elim (F.nonempty (by rw [h_eq]))
  | cons t ts =>
      cases ts with
      | nil =>
          have h_leaf : height t = 0 := F.allLeaves t (by simp [h_eq])
          rcases height_eq_zero_iff t |>.mp h_leaf with ⟨s, f, ht⟩
          have h_f_pos : f > 0 := by
            simpa [rootFreq] using F.allPos (htLeaf s f) (by rw [h_eq, ht]; simp)
          rw [ht]
          simp [huffman]
          exact optimum_leaf s f h_f_pos
      | cons u us =>
          simp [Forest.length, h_eq] at h_len

Huffman's algorithm produces an optimum tree for every valid bundled forest.


theorem optimum_huffman_v2 (F : Forest) : optimum (huffman F.trees) := by
  generalize hlen : F.length = n
  induction n using Nat.strong_induction_on generalizing F with
  | h n ih =>
      by_cases h_len2 : F.length ≥ 2
      · apply Forest.mergeCheapest_preserves_optimum F h_len2
        exact ih (F.mergeCheapest h_len2).length
          (by rw [← hlen]; exact Forest.mergeCheapest_length_lt F h_len2)
          (F.mergeCheapest h_len2) rfl
      · exact optimum_singleton_forest F (by
          have h_pos : F.length > 0 := by simpa [Forest.length, List.length_pos_iff_ne_nil] using F.nonempty
          omega)

end OptimalV2

Frequency-table interface

The frequency assigned to a symbol by a raw frequency table.

def tableFreq (xs : List (ℕ × ℕ)) (s : ℕ) : ℕ :=
  (xs.map (fun p => if p.1 = s then p.2 else 0)).sum

Turn a frequency table into singleton Huffman leaves.

def leavesOfFreqs (xs : List (ℕ × ℕ)) : List HuffTree :=
  xs.map (fun p => htLeaf p.1 p.2)

Insertion-sort a forest by rootFreq, using the same order expected by huffman.

def sortForest : List HuffTree → List HuffTree
  | [] => []
  | t :: ts => insortTree t (sortForest ts)

Run Huffman's algorithm on an arbitrary frequency table.

def huffmanOfFreqs (xs : List (ℕ × ℕ)) : HuffTree :=
  huffman (sortForest (leavesOfFreqs xs))

              lemma sortForest_sorted (ts : List HuffTree) : forest_sorted (sortForest ts) := by
  induction ts with
  | nil => simp [sortForest, forest_sorted]
  | cons t ts ih => simpa [sortForest] using forest_sorted_insortTree_of_sorted t (sortForest ts) ihlemma sortForest_ne_nil {ts : List HuffTree} (h_nonempty : ts ≠ []) : sortForest ts ≠ [] := by
  cases ts with
  | nil => contradiction
  | cons t ts => simpa [sortForest] using insortTree_ne_nil t (sortForest ts)lemma mem_sortForest (t : HuffTree) (ts : List HuffTree) :
    t ∈ sortForest ts ↔ t ∈ ts := by
  induction ts with
  | nil => simp [sortForest]
  | cons u us ih => simp [sortForest, mem_insortTree, ih]

lemma forest_consistent_sortForest (ts : List HuffTree)
    (h_cons : forest_consistent ts) :
    forest_consistent (sortForest ts) := by
  induction ts with
  | nil => simpa [sortForest] using h_cons
  | cons t ts ih =>
    rw [forest_consistent_cons_iff] at h_cons
    simpa [sortForest] using forest_consistent_insortTree t (sortForest ts) (by
      rw [forest_consistent_cons_iff]
      exact ⟨h_cons.1, ih h_cons.2.1,
        fun u hu => h_cons.2.2 u ((mem_sortForest u ts).mp hu)⟩)

lemma forest_freq_sortForest (ts : List HuffTree) (s : ℕ) :
    forest_freq (sortForest ts) s = forest_freq ts s := by
  induction ts with
  | nil => simp [sortForest, forest_freq]
  | cons t ts ih => rw [sortForest, forest_freq_insortTree]; simpa [forest_freq] using ihlemma forest_freq_leavesOfFreqs (xs : List (ℕ × ℕ)) (s : ℕ) :
    forest_freq (leavesOfFreqs xs) s = tableFreq xs s := by
  induction xs with
  | nil => simp [leavesOfFreqs, tableFreq, forest_freq]
  | cons p ps ih =>
      simp [leavesOfFreqs, tableFreq, forest_freq, freqOf]
      simpa [leavesOfFreqs, tableFreq, forest_freq] using ih

lemma forest_consistent_leavesOfFreqs (xs : List (ℕ × ℕ))
    (h_nodup : (xs.map Prod.fst).Nodup) :
    forest_consistent (leavesOfFreqs xs) := by
  induction xs with
  | nil => simp [leavesOfFreqs, forest_consistent]
  | cons p ps ih =>
    rcases List.nodup_cons.mp
      (show (p.1 :: ps.map Prod.fst).Nodup by simpa using h_nodup) with
      ⟨h_not_mem, h_tail_nodup⟩
    change forest_consistent (htLeaf p.1 p.2 :: leavesOfFreqs ps)
    rw [forest_consistent_cons_iff]
    refine ⟨by simp [consistent], ih h_tail_nodup, ?_⟩
    intro u hu
    dsimp [leavesOfFreqs] at hu
    rcases List.mem_map.mp hu with ⟨q, hq, rfl⟩
    simpa [alphabet] using
      (fun h_eq => h_not_mem (List.mem_map.mpr ⟨q, hq, h_eq.symm⟩) : p.1 ≠ q.1)

theorem freqOf_huffmanOfFreqs_eq_tableFreq (xs : List (ℕ × ℕ)) (s : ℕ)
    (h_nonempty : xs ≠ []) :
    freqOf s (huffmanOfFreqs xs) = tableFreq xs s := by
  unfold huffmanOfFreqs
  rw [freqOf_huffman_eq_forest_freq, forest_freq_sortForest, forest_freq_leavesOfFreqs]
  exact sortForest_ne_nil (by simpa [leavesOfFreqs] using h_nonempty)

Huffman's algorithm is optimal for every nonempty positive frequency table with no duplicate symbols. The table may be in any order; it is sorted before calling the bundled V2 huffman optimality theorem.

theorem optimum_huffman_freqs (xs : List (ℕ × ℕ))
    (h_nodup : (xs.map Prod.fst).Nodup)
    (h_pos : ∀ p ∈ xs, p.2 > 0)
    (h_nonempty : xs ≠ []) :
    optimum (huffmanOfFreqs xs) := by
  unfold huffmanOfFreqs
  exact OptimalV2.optimum_huffman_v2
    { trees := sortForest (leavesOfFreqs xs)
      sorted := sortForest_sorted (leavesOfFreqs xs)
      consistent := forest_consistent_sortForest (leavesOfFreqs xs)
        (forest_consistent_leavesOfFreqs xs h_nodup)
      allLeaves := fun t ht => by
        rcases (by simpa [leavesOfFreqs] using
          (mem_sortForest t (leavesOfFreqs xs)).mp ht) with ⟨a, b, _, rfl⟩
        simp [height]
      allPos := fun t ht => by
        rcases (by simpa [leavesOfFreqs] using
          (mem_sortForest t (leavesOfFreqs xs)).mp ht) with ⟨a, b, hp, rfl⟩
        simpa [rootFreq] using h_pos (a, b) hp
      nonempty := sortForest_ne_nil (by simpa [leavesOfFreqs] using h_nonempty) }

Reader-facing correctness theorem for the frequency-table interface: Huffman preserves the input frequencies and returns an optimum tree for those frequencies.

theorem huffmanOfFreqs_correct (xs : List (ℕ × ℕ))
    (h_nodup : (xs.map Prod.fst).Nodup)
    (h_pos : ∀ p ∈ xs, p.2 > 0)
    (h_nonempty : xs ≠ []) :
    (∀ s, freqOf s (huffmanOfFreqs xs) = tableFreq xs s) ∧
      optimum (huffmanOfFreqs xs) := by
  exact ⟨fun s => freqOf_huffmanOfFreqs_eq_tableFreq xs s h_nonempty,
    optimum_huffman_freqs xs h_nodup h_pos h_nonempty⟩

Direct minimum-cost form of Huffman optimality for frequency tables. Any consistent tree with the same frequencies has cost at least the Huffman tree's cost.


theorem huffmanOfFreqs_cost_le (xs : List (ℕ × ℕ))
    (h_nodup : (xs.map Prod.fst).Nodup)
    (h_pos : ∀ p ∈ xs, p.2 > 0)
    (h_nonempty : xs ≠ []) {u : HuffTree}
    (h_consistent : consistent u)
    (h_freq : ∀ s, freqOf s u = tableFreq xs s) :
    cost (huffmanOfFreqs xs) ≤ cost u := by
  have hcorrect := huffmanOfFreqs_correct xs h_nodup h_pos h_nonempty
  exact hcorrect.2.2.2 u h_consistent (fun s => by
    rw [hcorrect.1 s, h_freq s])

end HuffmanV2end CLRS

Definitions and proofs

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.Complexity

Huffman comparison accounting

The verified executable uses sorted lists, while CLRS uses a binary min-heap. This module makes the distinction explicit: the executable list realization has a proved quadratic comparison bound; the textbook heap realization has the usual n log n operation envelope under logarithmic heap operations.

namespace CLRS.HuffmanV2

Comparisons performed by the executable insertion into a sorted forest.

def insortComparisons (t : HuffTree) : List HuffTree → Nat
  | [] => 0
  | u :: us =>
      1 + if rootFreq t ≤ rootFreq u then 0 else insortComparisons t us

theorem insortComparisons_le_length (t : HuffTree) (ts : List HuffTree) :
    insortComparisons t ts ≤ ts.length := by
  induction ts with
  | nil => simp [insortComparisons]
  | cons u us ih =>
      simp [insortComparisons]
      split <;> omega

Comparisons performed by the insertion-sort initialization.

def sortForestComparisons : List HuffTree → Nat
  | [] => 0
  | t :: ts =>
      sortForestComparisons ts + insortComparisons t (sortForest ts)

theorem sortForest_length (ts : List HuffTree) :
    (sortForest ts).length = ts.length := by
  induction ts with
  | nil => rfl
  | cons t ts ih => simp [sortForest, insortTree_length, ih]



theorem sortForestComparisons_le_sq (ts : List HuffTree) :
    sortForestComparisons ts ≤ ts.length ^ 2 := by
  induction ts with
  | nil => simp [sortForestComparisons]
  | cons t ts ih =>
      have hins := insortComparisons_le_length t (sortForest ts)
      rw [sortForest_length] at hins
      simp only [sortForestComparisons, List.length_cons]
      nlinarith

Comparisons used by repeated merge-and-reinsert after initialization.


def huffmanComparisons : List HuffTree → Nat
  | [] => 0
  | [_] => 0
  | t₁ :: t₂ :: rest =>
      insortComparisons (unite t₁ t₂) rest +
        huffmanComparisons (insortTree (unite t₁ t₂) rest)
termination_by ts => ts.length
decreasing_by
  rw [insortTree_length]
  simp



theorem huffmanComparisons_le_sq (ts : List HuffTree) :
    huffmanComparisons ts ≤ ts.length ^ 2 := by
  induction hlen : ts.length using Nat.strong_induction_on generalizing ts with
  | h n ih =>
      cases ts with
      | nil => simp [huffmanComparisons]
      | cons t₁ tail =>
          cases tail with
          | nil => simp [huffmanComparisons]
          | cons t₂ rest =>
              let next := insortTree (unite t₁ t₂) rest
              have hnextLen : next.length = rest.length + 1 := by
                simpa [next] using insortTree_length (unite t₁ t₂) rest
              have hnextLt : next.length < n := by
                rw [hnextLen, ← hlen]
                simp
              have hrec : huffmanComparisons next ≤ next.length ^ 2 :=
                ih next.length hnextLt next rfl
              have hins := insortComparisons_le_length (unite t₁ t₂) rest
              simp only [huffmanComparisons]
              change insortComparisons (unite t₁ t₂) rest +
                  huffmanComparisons next ≤ n ^ 2
              rw [hnextLen] at hrec
              have hn : n = rest.length + 2 := by
                simpa using hlen.symm
              nlinarith

Total comparisons of the verified list-based Huffman realization.

def huffmanOfFreqsComparisons (xs : List (Nat × Nat)) : Nat :=
  let leaves := leavesOfFreqs xs
  sortForestComparisons leaves + huffmanComparisons (sortForest leaves)

The verified list implementation uses at most 2 n² comparisons.


theorem huffmanOfFreqsComparisons_le_quadratic (xs : List (Nat × Nat)) :
    huffmanOfFreqsComparisons xs ≤ 2 * xs.length ^ 2 := by
  have hsort := sortForestComparisons_le_sq (leavesOfFreqs xs)
  have hmerge := huffmanComparisons_le_sq (sortForest (leavesOfFreqs xs))
  rw [sortForest_length] at hmerge
  simp [huffmanOfFreqsComparisons, leavesOfFreqs] at hsort hmerge ⊢
  omega

A conservative height bound for one binary-heap operation.

def heapHeightBudget (n : Nat) : Nat := Nat.log 2 n + 1

Textbook heap work envelope: each of the n - 1 merges performs at most three heap operations, each bounded by the current heap-height budget.

def textbookHeapHuffmanWork (n : Nat) : Nat :=
  3 * (n - 1) * heapHeightBudget n

Explicit O(n log n) envelope for the textbook priority-queue algorithm.

theorem textbookHeapHuffmanWork_le_nlogn (n : Nat) :
    textbookHeapHuffmanWork n ≤ 3 * n * (Nat.log 2 n + 1) := by
  simp [textbookHeapHuffmanWork, heapHeightBudget]

end CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.HeapExecution.ArrayHeap

List-backed binary heap execution

The executable array stores stamped Huffman entries. A numeric rank is used only for comparisons; the trees remain aligned with their cells through every swap. The proof layer maps the execution to Chapter 6's verified natural-key max-heap operations.

namespace CLRS.HuffmanV2

Swap two cells in an arbitrary list-backed array.

def swapEntries {α : Type} (a : List α) (i j : Nat) : List α :=
  match a[i]?, a[j]? with
  | some ai, some aj => (a.set i aj).set j ai
  | _, _ => a

Push one cell upward while its numeric rank exceeds its parent's rank.

def bubbleUpFuel (rank : HeapEntry → Nat) :
    Nat → List HeapEntry → Nat → Nat → List HeapEntry
  | 0, a, _heapSize, _i => a
  | fuel + 1, a, heapSize, i =>
      if _ : 0 < i then
        if CLRS.Chapter06.valAt (a.map rank) (CLRS.Chapter06.parent i) <
            CLRS.Chapter06.valAt (a.map rank) i then
          bubbleUpFuel rank fuel (swapEntries a i (CLRS.Chapter06.parent i))
            heapSize (CLRS.Chapter06.parent i)
        else
          a
      else
        a

Push one cell downward toward the larger-ranked child.

def bubbleDownFuel (rank : HeapEntry → Nat) :
    Nat → List HeapEntry → Nat → Nat → List HeapEntry
  | 0, a, _heapSize, _i => a
  | fuel + 1, a, heapSize, i =>
      let largest := CLRS.Chapter06.maxChildIndex (a.map rank) heapSize i
      if largest = i then
        a
      else
        bubbleDownFuel rank fuel (swapEntries a i largest) heapSize largest

Append an entry and execute the ordinary binary-heap upward repair.

def heapInsertRaw (rank : HeapEntry → Nat)
    (a : List HeapEntry) (e : HeapEntry) : List HeapEntry :=
  bubbleUpFuel rank a.length (a ++ [e]) (a.length + 1) a.length

Extract the root, move the last cell to the root, and repair downward.

def heapExtractMaxRaw (rank : HeapEntry → Nat) :
    List HeapEntry → Option (HeapEntry × List HeapEntry)
  | [] => none
  | root :: rest =>
      let newSize := rest.length
      let moved := swapEntries (root :: rest) 0 newSize
      let active := moved.take newSize
      some (root, bubbleDownFuel rank newSize active newSize 0)

Repeated insertion builds a heap while keeping the input element multiset.

def heapBuildRaw (rank : HeapEntry → Nat) (entries : List HeapEntry) :
    List HeapEntry :=
  entries.foldl (heapInsertRaw rank) []

The concrete array satisfies the Chapter 6 max-heap predicate after ranking.

def IsRankHeap (rank : HeapEntry → Nat) (a : List HeapEntry) : Prop :=
  CLRS.Chapter06.ArrayMaxHeap (a.map rank) a.length

end CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.HeapExecution.Cost

Costed binary-heap Huffman execution

The counter in this module is the Chapter 6 abstract heap-controller metric: one unit is charged for each visited upward- or downward-repair frame. List allocation, indexing, guards, and proof objects are deliberately outside this metric. Every charge is read from the same ranked array and the same branch conditions as the executable heap operation; it is not a detached envelope.

namespace CLRS.HuffmanV2

A value paired with the heap-controller work used to produce it.

structure Costed (α : Type) where
  value : α
  work : Nat

One global logarithmic allowance for a heap whose size is at most the input size.

def HeapParams.opBudget (params : HeapParams) : Nat :=
  Nat.log 2 (params.inputSize + 1) + 1

Actual upward-repair work performed by one heap insertion.

def MinHeap.insertWork {params : HeapParams} (h : MinHeap params)
    (e : HeapEntry) : Nat :=
  (CLRS.Chapter06.arrayHeapInsertWithCost
    (h.data.map params.rank) (params.rank e)).2

theorem MinHeap.insertWork_le_log {params : HeapParams} (h : MinHeap params)
    (e : HeapEntry) :
    h.insertWork e ≤ Nat.log 2 (h.data.length + 1) + 1 := by
  simpa [MinHeap.insertWork] using
    CLRS.Chapter06.arrayHeapInsertWithCost_cost_le_log
      (h.data.map params.rank) (params.rank e)



theorem MinHeap.insertWork_le_budget {params : HeapParams} (h : MinHeap params)
    (e : HeapEntry) (hsize : h.data.length ≤ params.inputSize) :
    h.insertWork e ≤ params.opBudget := by
  have hstep := h.insertWork_le_log e
  have hlog : Nat.log 2 (h.data.length + 1) ≤
      Nat.log 2 (params.inputSize + 1) :=
    Nat.log_mono_right (by omega)
  exact hstep.trans (Nat.add_le_add_right hlog 1)

Actual downward-repair work performed by extracting a nonempty heap root.

def MinHeap.extractWork {params : HeapParams} (h : MinHeap params) : Nat :=
  match h.data with
  | [] => 0
  | root :: rest =>
      let moved := swapEntries (root :: rest) 0 rest.length
      let active := moved.take rest.length
      (CLRS.Chapter06.maxHeapifyFuelWithCost rest.length
        (active.map params.rank) rest.length 0).2



theorem MinHeap.extractWork_le_log {params : HeapParams} (h : MinHeap params) :
    h.extractWork ≤ Nat.log 2 (h.data.length + 1) + 1 := by
  unfold MinHeap.extractWork
  cases hdata : h.ranked.data with
  | nil => simp [MinHeap.data, hdata]
  | cons root rest =>
      by_cases hrest : rest.length = 0
      · simp [MinHeap.data, hdata, hrest,
          CLRS.Chapter06.maxHeapifyFuelWithCost]
      · have hpos : 0 < rest.length := Nat.pos_of_ne_zero hrest
        let moved := swapEntries (root :: rest) 0 rest.length
        let active := moved.take rest.length
        have hstep := CLRS.Chapter06.maxHeapifyFuelWithCost_cost_le_log
          rest.length (active.map params.rank) rest.length 0 hpos
        have hlog : Nat.log 2 rest.length ≤
            Nat.log 2 ((root :: rest).length + 1) :=
          Nat.log_mono_right (by simp; omega)
        simp only [MinHeap.data, hdata]
        change
          (CLRS.Chapter06.maxHeapifyFuelWithCost rest.length
            (active.map params.rank) rest.length 0).2 ≤
              Nat.log 2 ((root :: rest).length + 1) + 1
        exact hstep.trans (Nat.add_le_add_right hlog 1)



theorem MinHeap.extractWork_le_budget {params : HeapParams} (h : MinHeap params)
    (hsize : h.data.length ≤ params.inputSize) :
    h.extractWork ≤ params.opBudget := by
  have hstep := h.extractWork_le_log
  have hlog : Nat.log 2 (h.data.length + 1) ≤
      Nat.log 2 (params.inputSize + 1) :=
    Nat.log_mono_right (by omega)
  exact hstep.trans (Nat.add_le_add_right hlog 1)

Costed heap construction

Repeated insertion paired with the exact sum of its upward-repair work.

def MinHeap.buildWithCost (params : HeapParams) :
    (entries : List HeapEntry) →
      (∀ e ∈ entries, params.Bounded e) → MinHeap params × Nat
  | [], _ => (MinHeap.empty params, 0)
  | e :: entries, hbounded =>
      let htail : ∀ u ∈ entries, params.Bounded u :=
        fun u hu => hbounded u (by simp [hu])
      let tail := buildWithCost params entries htail
      let he : params.Bounded e := hbounded e (by simp)
      (tail.1.insert e he, tail.2 + tail.1.insertWork e)



@[simp] theorem MinHeap.buildWithCost_size (params : HeapParams)
    (entries : List HeapEntry) (hbounded : ∀ e ∈ entries, params.Bounded e) :
    (MinHeap.buildWithCost params entries hbounded).1.data.length = entries.length := by
  induction entries with
  | nil => simp [MinHeap.buildWithCost, MinHeap.empty, MinHeap.data,
      RankedHeap.empty]
  | cons e entries ih =>
      simp only [MinHeap.buildWithCost, MinHeap.insert_size]
      let htail : ∀ u ∈ entries, params.Bounded u :=
        fun u hu => hbounded u (by simp [hu])
      simpa using congrArg Nat.succ (ih htail)

Erasing construction cost recovers the verified executable heap data.


theorem MinHeap.buildWithCost_data (params : HeapParams)
    (entries : List HeapEntry) (hbounded : ∀ e ∈ entries, params.Bounded e) :
    (MinHeap.buildWithCost params entries hbounded).1.data =
      (MinHeap.build params entries hbounded).data := by
  induction entries with
  | nil => rfl
  | cons e entries ih =>
      simp only [MinHeap.buildWithCost, MinHeap.build]
      let htail : ∀ u ∈ entries, params.Bounded u :=
        fun u hu => hbounded u (by simp [hu])
      change
        heapInsertRaw params.rank
            (MinHeap.buildWithCost params entries htail).1.data e =
          heapInsertRaw params.rank (MinHeap.build params entries htail).data e
      rw [ih htail]



theorem MinHeap.buildWithCost_work_le (params : HeapParams)
    (entries : List HeapEntry) (hbounded : ∀ e ∈ entries, params.Bounded e)
    (hsize : entries.length ≤ params.inputSize) :
    (MinHeap.buildWithCost params entries hbounded).2 ≤
      entries.length * params.opBudget := by
  induction entries with
  | nil => simp [MinHeap.buildWithCost]
  | cons e entries ih =>
      let htail : ∀ u ∈ entries, params.Bounded u :=
        fun u hu => hbounded u (by simp [hu])
      have htailSize : entries.length ≤ params.inputSize := by
        simp only [List.length_cons] at hsize
        omega
      have hrec := ih htail htailSize
      have hentrySize :
          (MinHeap.buildWithCost params entries htail).1.data.length ≤
            params.inputSize := by
        rw [MinHeap.buildWithCost_size]
        exact htailSize
      have hstep := MinHeap.insertWork_le_budget
        (MinHeap.buildWithCost params entries htail).1 e hentrySize
      simp only [MinHeap.buildWithCost]
      change
        (MinHeap.buildWithCost params entries htail).2 +
            (MinHeap.buildWithCost params entries htail).1.insertWork e ≤
          (entries.length + 1) * params.opBudget
      rw [Nat.add_mul]
      omega

Costed Huffman merge loop

Exact repair-frame count along the executable Huffman loop's control path.

def heapHuffmanLoopWork {params : HeapParams} :
    Nat → HeapHuffmanState params → Nat
  | 0, _ => 0
  | fuel + 1, s =>
      let work₁ := s.heap.extractWork
      match hextract₁ : s.heap.extractMin with
      | none => work₁
      | some (e₁, h₁) =>
          let work₂ := h₁.extractWork
          match hextract₂ : h₁.extractMin with
          | none => work₁ + work₂
          | some (e₂, h₂) =>
              let next := HeapHuffmanState.mergeState s hextract₁ hextract₂
              let newEntry := mergedEntry s.heap.data.length e₁ e₂
              let insertWork := h₂.insertWork newEntry
              work₁ + work₂ + insertWork + heapHuffmanLoopWork fuel next

The heap execution paired with its exact repair-frame count.

def heapHuffmanLoopWithCost {params : HeapParams}
    (fuel : Nat) (s : HeapHuffmanState params) : Costed HuffTree :=
  ⟨heapHuffmanLoop fuel s, heapHuffmanLoopWork fuel s⟩

Removing the counter yields the complete uninstrumented heap execution.

theorem heapHuffmanLoopWithCost_value {params : HeapParams}
    (fuel : Nat) (s : HeapHuffmanState params) :
    (heapHuffmanLoopWithCost fuel s).value = heapHuffmanLoop fuel s := rfl



theorem heapHuffmanLoopWithCost_work_le {params : HeapParams}
    (fuel : Nat) (s : HeapHuffmanState params) :
    (heapHuffmanLoopWithCost fuel s).work ≤
      fuel * (3 * params.opBudget) := by
  induction fuel generalizing s with
  | zero => simp [heapHuffmanLoopWithCost, heapHuffmanLoopWork]
  | succ fuel ih =>
      change heapHuffmanLoopWork (fuel + 1) s ≤
        (fuel + 1) * (3 * params.opBudget)
      simp only [heapHuffmanLoopWork]
      split
      next hextract₁ =>
        have hwork₁ := s.heap.extractWork_le_budget s.size_le_input
        change s.heap.extractWork ≤ (fuel + 1) * (3 * params.opBudget)
        rw [Nat.succ_mul]
        omega
      next e₁ h₁ hextract₁ =>
        rcases MinHeap.extractMin_spec hextract₁ with
          ⟨_hperm₁, hlen₁, _hmin₁⟩
        have hsize := s.size_le_input
        have hsize₁ : h₁.data.length ≤ params.inputSize := by
          omega
        have hwork₁ := s.heap.extractWork_le_budget s.size_le_input
        have hwork₂ := h₁.extractWork_le_budget hsize₁
        split
        next hextract₂ =>
          change s.heap.extractWork + h₁.extractWork ≤
            (fuel + 1) * (3 * params.opBudget)
          rw [Nat.succ_mul]
          omega
        next e₂ h₂ hextract₂ =>
          rcases MinHeap.extractMin_spec hextract₂ with
            ⟨_hperm₂, hlen₂, _hmin₂⟩
          have hsize₂ : h₂.data.length ≤ params.inputSize := by
            omega
          have hinsert := h₂.insertWork_le_budget
            (mergedEntry s.heap.data.length e₁ e₂) hsize₂
          have hrec := ih (HeapHuffmanState.mergeState s hextract₁ hextract₂)
          change
            heapHuffmanLoopWork fuel
                (HeapHuffmanState.mergeState s hextract₁ hextract₂) ≤
              fuel * (3 * params.opBudget) at hrec
          change
            s.heap.extractWork + h₁.extractWork +
                h₂.insertWork (mergedEntry s.heap.data.length e₁ e₂) +
                heapHuffmanLoopWork fuel
                  (HeapHuffmanState.mergeState s hextract₁ hextract₂) ≤
              (fuel + 1) * (3 * params.opBudget)
          rw [Nat.succ_mul]
          omega

Public costed program

Verified heap Huffman paired with construction and merge-controller work.

def heapHuffmanOfFreqsWithCost (xs : List (Nat × Nat)) : Costed HuffTree :=
  let params := HeapParams.ofFreqs xs
  let entries := initialEntries (leavesOfFreqs xs)
  let hbounded := initialEntries_bounded xs
  let buildRun := MinHeap.buildWithCost params entries hbounded
  let mergeRun := heapHuffmanLoopWithCost xs.length (HeapHuffmanState.ofFreqs xs)
  ⟨mergeRun.value, buildRun.2 + mergeRun.work⟩

theorem heapHuffmanOfFreqsWithCost_value (xs : List (Nat × Nat)) :
    (heapHuffmanOfFreqsWithCost xs).value = heapHuffmanOfFreqs xs := by
  unfold heapHuffmanOfFreqsWithCost heapHuffmanOfFreqs
  exact heapHuffmanLoopWithCost_value xs.length (HeapHuffmanState.ofFreqs xs)

Explicit O(n log n) controller-work envelope for the actual heap run.


theorem heapHuffmanOfFreqs_work_le_nlogn (xs : List (Nat × Nat)) :
    (heapHuffmanOfFreqsWithCost xs).work ≤
      xs.length * (4 * (Nat.log 2 (xs.length + 1) + 1)) := by
  let params := HeapParams.ofFreqs xs
  let entries := initialEntries (leavesOfFreqs xs)
  let hbounded := initialEntries_bounded xs
  have hentries : entries.length = xs.length := by
    simp [entries, leavesOfFreqs]
  have hbuild := MinHeap.buildWithCost_work_le params entries hbounded (by
    rw [hentries]
    rfl)
  have hmerge := heapHuffmanLoopWithCost_work_le xs.length
    (HeapHuffmanState.ofFreqs xs)
  change
    (MinHeap.buildWithCost params entries hbounded).2 +
        (heapHuffmanLoopWithCost xs.length (HeapHuffmanState.ofFreqs xs)).work ≤
      xs.length * (4 * (Nat.log 2 (xs.length + 1) + 1))
  have hbudget : params.opBudget = Nat.log 2 (xs.length + 1) + 1 := by
    rfl
  rw [hentries, hbudget] at hbuild
  rw [hbudget] at hmerge
  calc
    _ ≤ xs.length * (Nat.log 2 (xs.length + 1) + 1) +
        xs.length * (3 * (Nat.log 2 (xs.length + 1) + 1)) :=
      Nat.add_le_add hbuild hmerge
    _ = xs.length * (4 * (Nat.log 2 (xs.length + 1) + 1)) := by ring

end CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.HeapExecution.Entry

Stable entries for the executable Huffman heap

The existing list implementation inserts a newly created tree before older trees of the same frequency. A distinct stamp records that tie-breaking rule inside the heap priority.

namespace CLRS.HuffmanV2

A Huffman tree together with its stable priority-queue stamp.

structure HeapEntry where
  tree : HuffTree
  stamp : Nat
  deriving Repr, DecidableEq

namespace HeapEntry

The observable priority components of a heap entry.

def priority (e : HeapEntry) : Nat × Nat :=
  (rootFreq e.tree, e.stamp)

Lexicographic non-strict priority order: frequency first, stamp second.

def PriorityLE (a b : HeapEntry) : Prop :=
  rootFreq a.tree < rootFreq b.tree ∨
    (rootFreq a.tree = rootFreq b.tree ∧ a.stamp ≤ b.stamp)

Lexicographic strict priority order: frequency first, stamp second.

def PriorityLT (a b : HeapEntry) : Prop :=
  rootFreq a.tree < rootFreq b.tree ∨
    (rootFreq a.tree = rootFreq b.tree ∧ a.stamp < b.stamp)

              instance (a b : HeapEntry) : Decidable (PriorityLE a b) := by
  unfold PriorityLE
  infer_instanceinstance (a b : HeapEntry) : Decidable (PriorityLT a b) := by
  unfold PriorityLT
  infer_instancetheorem priorityLE_refl (a : HeapEntry) : PriorityLE a a := by
  right
  exact ⟨rfl, Nat.le_refl _⟩theorem priorityLE_trans {a b c : HeapEntry}
    (hab : PriorityLE a b) (hbc : PriorityLE b c) : PriorityLE a c := by
  rcases hab with hab | ⟨habFreq, habStamp⟩
  · rcases hbc with hbc | ⟨hbcFreq, _⟩
    · left; omega
    · left; omega
  · rcases hbc with hbc | ⟨hbcFreq, hbcStamp⟩
    · left; omega
    · right
      exact ⟨habFreq.trans hbcFreq, Nat.le_trans habStamp hbcStamp⟩theorem priorityLE_total (a b : HeapEntry) :
    PriorityLE a b ∨ PriorityLE b a := by
  by_cases hfreq : rootFreq a.tree = rootFreq b.tree
  · rcases Nat.le_total a.stamp b.stamp with hab | hba
    · exact Or.inl (Or.inr ⟨hfreq, hab⟩)
    · exact Or.inr (Or.inr ⟨hfreq.symm, hba⟩)
  · rcases Nat.lt_or_gt_of_ne hfreq with hab | hba
    · exact Or.inl (Or.inl hab)
    · exact Or.inr (Or.inl hba)theorem priorityLE_antisymm_components {a b : HeapEntry}
    (hab : PriorityLE a b) (hba : PriorityLE b a) :
    rootFreq a.tree = rootFreq b.tree ∧ a.stamp = b.stamp := by
  rcases hab with hab | ⟨habFreq, habStamp⟩
  · rcases hba with hba | ⟨hbaFreq, _⟩ <;> omega
  · rcases hba with hba | ⟨hbaFreq, hbaStamp⟩
    · omega
    · exact ⟨habFreq, Nat.le_antisymm habStamp hbaStamp⟩theorem priorityLT_iff_le_not_le (a b : HeapEntry) :
    PriorityLT a b ↔ PriorityLE a b ∧ ¬ PriorityLE b a := by
  constructor
  · intro h
    constructor
    · rcases h with h | ⟨hfreq, hstamp⟩
      · exact Or.inl h
      · exact Or.inr ⟨hfreq, Nat.le_of_lt hstamp⟩
    · intro hba
      rcases h with h | ⟨hfreq, hstamp⟩
      · rcases hba with hba | ⟨hbaFreq, _⟩ <;> omega
      · rcases hba with hba | ⟨hbaFreq, hbaStamp⟩ <;> omega
  · rintro ⟨hab, hnba⟩
    rcases hab with hab | ⟨hfreq, hstamp⟩
    · exact Or.inl hab
    · right
      refine ⟨hfreq, Nat.lt_of_le_of_ne hstamp ?_⟩
      intro heq
      apply hnba
      exact Or.inr ⟨hfreq.symm, Nat.le_of_eq heq.symm⟩theorem priorityLT_irrefl (a : HeapEntry) : ¬ PriorityLT a a := by
  intro h
  rcases h with h | ⟨_, h⟩ <;> omegatheorem priorityLT_trans {a b c : HeapEntry}
    (hab : PriorityLT a b) (hbc : PriorityLT b c) : PriorityLT a c := by
  rcases hab with hab | ⟨habFreq, habStamp⟩
  · rcases hbc with hbc | ⟨hbcFreq, _⟩
    · left; omega
    · left; omega
  · rcases hbc with hbc | ⟨hbcFreq, hbcStamp⟩
    · left; omega
    · right
      exact ⟨habFreq.trans hbcFreq, Nat.lt_trans habStamp hbcStamp⟩theorem priorityLT_of_not_le {a b : HeapEntry}
    (h : ¬ PriorityLE b a) : PriorityLT a b := by
  have hab := priorityLE_total a b
  rcases hab with hab | hba
  · exact (priorityLT_iff_le_not_le a b).2 ⟨hab, h⟩
  · exact False.elim (h hba)theorem priorityLE_of_not_lt {a b : HeapEntry}
    (h : ¬ PriorityLT b a) : PriorityLE a b := by
  rcases priorityLE_total a b with hab | hba
  · exact hab
  · by_contra hnab
    exact h (priorityLT_of_not_le hnab)end HeapEntry

Decorate a list with consecutive stamps starting at the supplied base.

def decorateFrom : Nat → List HuffTree → List HeapEntry
  | _, [] => []
  | base, t :: ts =>
      { tree := t, stamp := base } :: decorateFrom (base + 1) ts

Initial leaves use stamps at least the input length.

def initialEntries (ts : List HuffTree) : List HeapEntry :=
  decorateFrom ts.length ts

A merge uses the current queue size to obtain the next decreasing stamp.

def mergedEntry (queueSize : Nat) (a b : HeapEntry) : HeapEntry :=
  { tree := unite a.tree b.tree, stamp := queueSize - 2 }

              @[simp] theorem decorateFrom_length (base : Nat) (ts : List HuffTree) :
    (decorateFrom base ts).length = ts.length := by
  induction ts generalizing base with
  | nil => rfl
  | cons t ts ih => simp [decorateFrom, ih]@[simp] theorem decorateFrom_map_tree (base : Nat) (ts : List HuffTree) :
    (decorateFrom base ts).map HeapEntry.tree = ts := by
  induction ts generalizing base with
  | nil => rfl
  | cons t ts ih => simp [decorateFrom, ih]@[simp] theorem decorateFrom_map_stamp (base : Nat) (ts : List HuffTree) :
    (decorateFrom base ts).map HeapEntry.stamp = List.range' base ts.length := by
  induction ts generalizing base with
  | nil => simp [decorateFrom]
  | cons t ts ih =>
      simp [decorateFrom, ih, List.range'_succ]@[simp] theorem initialEntries_length (ts : List HuffTree) :
    (initialEntries ts).length = ts.length := by
  simp [initialEntries]@[simp] theorem initialEntries_map_tree (ts : List HuffTree) :
    (initialEntries ts).map HeapEntry.tree = ts := by
  simp [initialEntries]theorem decorateFrom_stamp_ge {base : Nat} {ts : List HuffTree} {e : HeapEntry}
    (he : e ∈ decorateFrom base ts) : base ≤ e.stamp := by
  induction ts generalizing base with
  | nil => simp [decorateFrom] at he
  | cons t ts ih =>
      simp only [decorateFrom, List.mem_cons] at he
      rcases he with rfl | he
      · exact Nat.le_refl _
      · exact Nat.le_trans (Nat.le_succ base) (ih he)theorem decorateFrom_stamp_lt {base : Nat} {ts : List HuffTree} {e : HeapEntry}
    (he : e ∈ decorateFrom base ts) : e.stamp < base + ts.length := by
  induction ts generalizing base with
  | nil => simp [decorateFrom] at he
  | cons t ts ih =>
      simp only [decorateFrom, List.mem_cons] at he
      rcases he with rfl | he
      · simp
      · have h := ih he
        simp only [List.length_cons]
        omegatheorem initialEntries_stamp_ge {ts : List HuffTree} {e : HeapEntry}
    (he : e ∈ initialEntries ts) : ts.length ≤ e.stamp := by
  exact decorateFrom_stamp_ge he

theorem initialEntries_stamps_nodup (ts : List HuffTree) :
    ((initialEntries ts).map HeapEntry.stamp).Nodup := by
  rw [initialEntries, decorateFrom_map_stamp]
  exact List.nodup_range'@[simp] theorem mergedEntry_tree (queueSize : Nat) (a b : HeapEntry) :
    (mergedEntry queueSize a b).tree = unite a.tree b.tree := rfl@[simp] theorem mergedEntry_stamp (queueSize : Nat) (a b : HeapEntry) :
    (mergedEntry queueSize a b).stamp = queueSize - 2 := rflend CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.HeapExecution.Execution

Complete heap-based Huffman execution

This module joins the verified binary heap to the existing Huffman recursion. The state invariant supplies the global frequency and stable-stamp facts needed to construct every newly merged entry inside the fixed heap bounds.

namespace CLRS.HuffmanV2

Sum of root frequencies in an active heap forest.

def entryRootSum (entries : List HeapEntry) : Nat :=
  (entries.map (fun e => rootFreq e.tree)).sum

              theorem entryRootSum_eq_of_perm {as bs : List HeapEntry} (h : as.Perm bs) :
    entryRootSum as = entryRootSum bs := by
  unfold entryRootSum
  exact (h.map (fun e => rootFreq e.tree)).sum_eq@[simp] theorem entryRootSum_cons (e : HeapEntry) (es : List HeapEntry) :
    entryRootSum (e :: es) = rootFreq e.tree + entryRootSum es := by
  simp [entryRootSum]

theorem entryRootSum_decorateFrom (base : Nat) (ts : List HuffTree) :
    entryRootSum (decorateFrom base ts) = (ts.map rootFreq).sum := by
  induction ts generalizing base with
  | nil => rfl
  | cons t ts ih =>
      rw [decorateFrom, entryRootSum]
      simp only [List.map_cons, List.sum_cons]
      change rootFreq t + entryRootSum (decorateFrom (base + 1) ts) =
        rootFreq t + (ts.map rootFreq).sum
      rw [ih]theorem tableFreq_le_tableTotal_of_mem {p : Nat × Nat}
    {xs : List (Nat × Nat)} (hp : p ∈ xs) : p.2 ≤ HeapParams.tableTotal xs := by
  induction xs with
  | nil => simp at hp
  | cons q qs ih =>
      simp only [List.mem_cons] at hp
      rcases hp with hpq | hp
      · subst p
        simp [HeapParams.tableTotal]
      · have htail := ih hp
        exact htail.trans (by simp [HeapParams.tableTotal])

All initial decorated leaves lie inside the fixed execution envelope.


theorem initialEntries_bounded (xs : List (Nat × Nat)) :
    ∀ e ∈ initialEntries (leavesOfFreqs xs),
      (HeapParams.ofFreqs xs).Bounded e := by
  intro e he
  constructor
  · have htree : e.tree ∈ leavesOfFreqs xs := by
      have : e.tree ∈ (initialEntries (leavesOfFreqs xs)).map HeapEntry.tree :=
        List.mem_map.mpr ⟨e, he, rfl⟩
      simpa using this
    rcases List.mem_map.mp htree with ⟨p, hp, htree⟩
    rw [← htree]
    simpa [HeapParams.ofFreqs, rootFreq] using
      tableFreq_le_tableTotal_of_mem hp
  · have hstamp := decorateFrom_stamp_lt
      (base := (leavesOfFreqs xs).length) (ts := leavesOfFreqs xs) he
    simp [HeapParams.ofFreqs, HeapParams.base,
      leavesOfFreqs] at hstamp ⊢
    omega

The initial forest's aggregate root frequency is the table total.


theorem initialEntries_rootSum (xs : List (Nat × Nat)) :
    entryRootSum (initialEntries (leavesOfFreqs xs)) =
      HeapParams.tableTotal xs := by
  rw [initialEntries, entryRootSum_decorateFrom]
  unfold HeapParams.tableTotal
  induction xs with
  | nil => rfl
  | cons p ps ih =>
      change p.2 + (List.map rootFreq (leavesOfFreqs ps)).sum =
        p.2 + (List.map Prod.snd ps).sum
      rw [ih]

Execution invariant maintained across every two-extract/one-insert merge.

structure HeapHuffmanState (params : HeapParams) where
  heap : MinHeap params
  stampsNodup : (heap.data.map HeapEntry.stamp).Nodup
  stampFloor : ∀ e ∈ heap.data, heap.data.length - 1 ≤ e.stamp
  rootSum : entryRootSum heap.data = params.totalFreq
  size_le_input : heap.data.length ≤ params.inputSize

namespace HeapHuffmanState

Initialize the complete verified state from a raw frequency table.


def ofFreqs (xs : List (Nat × Nat)) : HeapHuffmanState (HeapParams.ofFreqs xs) :=
  let entries := initialEntries (leavesOfFreqs xs)
  let hbounded := initialEntries_bounded xs
  let heap := MinHeap.build (HeapParams.ofFreqs xs) entries hbounded
  { heap := heap
    stampsNodup := by
      exact (map_stamp_perm_of_perm
        (MinHeap.build_perm (HeapParams.ofFreqs xs) entries hbounded)).nodup_iff.mpr
          (initialEntries_stamps_nodup (leavesOfFreqs xs))
    stampFloor := by
      intro e he
      have he' : e ∈ entries :=
        (List.Perm.mem_iff
          (MinHeap.build_perm (HeapParams.ofFreqs xs) entries hbounded)).mp he
      have hge := initialEntries_stamp_ge he'
      rw [MinHeap.build_size]
      simp [entries, leavesOfFreqs] at hge ⊢
      omega
    rootSum := by
      rw [entryRootSum_eq_of_perm
        (MinHeap.build_perm (HeapParams.ofFreqs xs) entries hbounded)]
      exact initialEntries_rootSum xs
    size_le_input := by
      rw [MinHeap.build_size]
      simp [entries, HeapParams.ofFreqs, leavesOfFreqs] }



@[simp] theorem ofFreqs_size (xs : List (Nat × Nat)) :
    (ofFreqs xs).heap.data.length = xs.length := by
  unfold ofFreqs
  rw [MinHeap.build_size]
  simp [leavesOfFreqs]



theorem ofFreqs_ordered_trees (xs : List (Nat × Nat)) :
    (ofFreqs xs).heap.orderedView.map HeapEntry.tree =
      sortForest (leavesOfFreqs xs) := by
  unfold ofFreqs MinHeap.orderedView
  let entries := initialEntries (leavesOfFreqs xs)
  let hbounded := initialEntries_bounded xs
  rw [orderedEntries_eq_of_perm
    ((map_stamp_perm_of_perm
      (MinHeap.build_perm (HeapParams.ofFreqs xs) entries hbounded)).nodup_iff.mpr
        (initialEntries_stamps_nodup (leavesOfFreqs xs)))
    (MinHeap.build_perm (HeapParams.ofFreqs xs) entries hbounded)]
  exact orderedEntries_initial_trees (leavesOfFreqs xs)

One verified merge transition

Two successful extractions followed by insertion of their joined tree.


def mergeState {params : HeapParams} (s : HeapHuffmanState params)
    {e₁ e₂ : HeapEntry} {h₁ h₂ : MinHeap params}
    (hextract₁ : s.heap.extractMin = some (e₁, h₁))
    (hextract₂ : h₁.extractMin = some (e₂, h₂)) :
    HeapHuffmanState params := by
  let oldSize := s.heap.data.length
  let newEntry := mergedEntry oldSize e₁ e₂
  have hspec₁ := MinHeap.extractMin_spec hextract₁
  have hspec₂ := MinHeap.extractMin_spec hextract₂
  have hsize₁ : h₁.data.length + 1 = oldSize := by simpa [oldSize] using hspec₁.2.1
  have hsize₂ : h₂.data.length + 1 = h₁.data.length := hspec₂.2.1
  have holdSize : oldSize = h₂.data.length + 2 := by omega
  have hsum₁ : rootFreq e₁.tree + entryRootSum h₁.data = params.totalFreq := by
    calc
      rootFreq e₁.tree + entryRootSum h₁.data = entryRootSum (e₁ :: h₁.data) := by simp
      _ = entryRootSum s.heap.data := entryRootSum_eq_of_perm hspec₁.1
      _ = params.totalFreq := s.rootSum
  have hsum₂ : rootFreq e₂.tree + entryRootSum h₂.data = entryRootSum h₁.data := by
    calc
      rootFreq e₂.tree + entryRootSum h₂.data = entryRootSum (e₂ :: h₂.data) := by simp
      _ = entryRootSum h₁.data := entryRootSum_eq_of_perm hspec₂.1
  have hboundedNew : params.Bounded newEntry := by
    constructor
    · change rootFreq e₁.tree + rootFreq e₂.tree ≤ params.totalFreq
      omega
    · change oldSize - 2 < params.base
      have hsizeBound : oldSize ≤ params.inputSize := by
        simpa [oldSize] using s.size_le_input
      simp only [HeapParams.base]
      omega
  let heap' := h₂.insert newEntry hboundedNew
  have hinsertPerm : heap'.data.Perm (newEntry :: h₂.data) :=
    MinHeap.insert_perm h₂ newEntry hboundedNew
  have hnodup₁ : ((e₁ :: h₁.data).map HeapEntry.stamp).Nodup :=
    (map_stamp_perm_of_perm hspec₁.1).nodup_iff.mpr s.stampsNodup
  have hnodupH₁ : (h₁.data.map HeapEntry.stamp).Nodup :=
    (List.nodup_cons.mp hnodup₁).2
  have hnodup₂ : ((e₂ :: h₂.data).map HeapEntry.stamp).Nodup :=
    (map_stamp_perm_of_perm hspec₂.1).nodup_iff.mpr hnodupH₁
  have hnodupH₂ : (h₂.data.map HeapEntry.stamp).Nodup :=
    (List.nodup_cons.mp hnodup₂).2
  have hnewFresh : ∀ u ∈ h₂.data, newEntry.stamp < u.stamp := by
    intro u hu
    have huH₁ : u ∈ h₁.data :=
      (List.Perm.mem_iff hspec₂.1).mp (List.mem_cons_of_mem e₂ hu)
    have huOld : u ∈ s.heap.data :=
      (List.Perm.mem_iff hspec₁.1).mp (List.mem_cons_of_mem e₁ huH₁)
    have hfloor := s.stampFloor u huOld
    change oldSize - 2 < u.stamp
    change oldSize - 1 ≤ u.stamp at hfloor
    omega
  refine
    { heap := heap'
      stampsNodup := ?_
      stampFloor := ?_
      rootSum := ?_
      size_le_input := ?_ }
  · apply (map_stamp_perm_of_perm hinsertPerm).nodup_iff.mpr
    rw [List.map_cons, List.nodup_cons]
    refine ⟨?_, hnodupH₂⟩
    intro hmem
    rcases List.mem_map.mp hmem with ⟨u, hu, hstamp⟩
    have hfresh := hnewFresh u hu
    omega
  · intro u hu
    have hu' : u ∈ newEntry :: h₂.data :=
      (List.Perm.mem_iff hinsertPerm).mp hu
    simp only [List.mem_cons] at hu'
    rcases hu' with hueq | huOld
    · subst u
      rw [MinHeap.insert_size]
      change h₂.data.length + 1 - 1 ≤ oldSize - 2
      omega
    · have huH₁ : u ∈ h₁.data :=
        (List.Perm.mem_iff hspec₂.1).mp (List.mem_cons_of_mem e₂ huOld)
      have huSource : u ∈ s.heap.data :=
        (List.Perm.mem_iff hspec₁.1).mp (List.mem_cons_of_mem e₁ huH₁)
      have hfloor := s.stampFloor u huSource
      rw [MinHeap.insert_size]
      omega
  · calc
      entryRootSum heap'.data = entryRootSum (newEntry :: h₂.data) :=
        entryRootSum_eq_of_perm hinsertPerm
      _ = rootFreq e₁.tree + rootFreq e₂.tree + entryRootSum h₂.data := by
        simp [newEntry, mergedEntry, unite, rootFreq]
      _ = params.totalFreq := by omega
  · rw [MinHeap.insert_size]
    have holdBound : oldSize ≤ params.inputSize := by
      simpa [oldSize] using s.size_le_input
    omega

theorem stampsNodup_after_extract {params : HeapParams}
    {h h' : MinHeap params} {e : HeapEntry}
    (hnodup : (h.data.map HeapEntry.stamp).Nodup)
    (hextract : h.extractMin = some (e, h')) :
    (h'.data.map HeapEntry.stamp).Nodup := by
  have hspec := MinHeap.extractMin_spec hextract
  have hcons : ((e :: h'.data).map HeapEntry.stamp).Nodup :=
    (map_stamp_perm_of_perm hspec.1).nodup_iff.mpr hnodup
  exact (List.nodup_cons.mp hcons).2

@[simp] theorem mergeState_size {params : HeapParams}
    (s : HeapHuffmanState params) {e₁ e₂ : HeapEntry} {h₁ h₂ : MinHeap params}
    (hextract₁ : s.heap.extractMin = some (e₁, h₁))
    (hextract₂ : h₁.extractMin = some (e₂, h₂)) :
    (mergeState s hextract₁ hextract₂).heap.data.length + 1 =
      s.heap.data.length := by
  have hspec₁ := MinHeap.extractMin_spec hextract₁
  have hspec₂ := MinHeap.extractMin_spec hextract₂
  unfold mergeState
  simp only [MinHeap.insert_size]
  omega

The merge transition implements exactly the sorted-list reinsertion step.


theorem mergeState_ordered_trees {params : HeapParams}
    (s : HeapHuffmanState params) {e₁ e₂ : HeapEntry} {h₁ h₂ : MinHeap params}
    (hextract₁ : s.heap.extractMin = some (e₁, h₁))
    (hextract₂ : h₁.extractMin = some (e₂, h₂)) :
    (mergeState s hextract₁ hextract₂).heap.orderedView.map HeapEntry.tree =
      insortTree (unite e₁.tree e₂.tree) (h₂.orderedView.map HeapEntry.tree) := by
  let oldSize := s.heap.data.length
  let newEntry := mergedEntry oldSize e₁ e₂
  have hnodup₁ := stampsNodup_after_extract s.stampsNodup hextract₁
  have hnodup₂ := stampsNodup_after_extract hnodup₁ hextract₂
  have hspec₁ := MinHeap.extractMin_spec hextract₁
  have hspec₂ := MinHeap.extractMin_spec hextract₂
  have hsize₁ : h₁.data.length + 1 = oldSize := by simpa [oldSize] using hspec₁.2.1
  have hsize₂ : h₂.data.length + 1 = h₁.data.length := hspec₂.2.1
  have hboundedNew : params.Bounded newEntry := by
    constructor
    · change rootFreq e₁.tree + rootFreq e₂.tree ≤ params.totalFreq
      have hsum₁ : rootFreq e₁.tree + entryRootSum h₁.data = params.totalFreq := by
        calc
          _ = entryRootSum (e₁ :: h₁.data) := by simp
          _ = entryRootSum s.heap.data := entryRootSum_eq_of_perm hspec₁.1
          _ = params.totalFreq := s.rootSum
      have hsum₂ : rootFreq e₂.tree + entryRootSum h₂.data = entryRootSum h₁.data := by
        calc
          _ = entryRootSum (e₂ :: h₂.data) := by simp
          _ = entryRootSum h₁.data := entryRootSum_eq_of_perm hspec₂.1
      omega
    · change oldSize - 2 < params.base
      have holdBound : oldSize ≤ params.inputSize := by
        simpa [oldSize] using s.size_le_input
      simp only [HeapParams.base]
      omega
  have hconsNodup : ((newEntry :: h₂.data).map HeapEntry.stamp).Nodup := by
    rw [List.map_cons, List.nodup_cons]
    refine ⟨?_, hnodup₂⟩
    intro hmem
    rcases List.mem_map.mp hmem with ⟨u, hu, hstamp⟩
    have huH₁ : u ∈ h₁.data :=
      (List.Perm.mem_iff hspec₂.1).mp (List.mem_cons_of_mem e₂ hu)
    have huOld : u ∈ s.heap.data :=
      (List.Perm.mem_iff hspec₁.1).mp (List.mem_cons_of_mem e₁ huH₁)
    have hfloor := s.stampFloor u huOld
    have hlt : newEntry.stamp < u.stamp := by
      change oldSize - 2 < u.stamp
      change oldSize - 1 ≤ u.stamp at hfloor
      omega
    omega
  have hviewInsert := MinHeap.orderedView_insert h₂ newEntry hboundedNew hconsNodup
  have hstampLt : ∀ u ∈ h₂.orderedView, newEntry.stamp < u.stamp := by
    intro u hu
    have huData := (mem_orderedEntries u h₂.data).mp hu
    have huH₁ : u ∈ h₁.data :=
      (List.Perm.mem_iff hspec₂.1).mp (List.mem_cons_of_mem e₂ huData)
    have huOld : u ∈ s.heap.data :=
      (List.Perm.mem_iff hspec₁.1).mp (List.mem_cons_of_mem e₁ huH₁)
    have hfloor := s.stampFloor u huOld
    change oldSize - 2 < u.stamp
    change oldSize - 1 ≤ u.stamp at hfloor
    omega
  unfold mergeState
  rw [hviewInsert]
  simpa [newEntry, mergedEntry] using
    map_tree_insertEntry_of_stamp_lt newEntry h₂.orderedView hstampLt

end HeapHuffmanState

Total heap execution

Execute at most one merge per unit of fuel.

def heapHuffmanLoop {params : HeapParams} :
    Nat → HeapHuffmanState params → HuffTree
  | 0, _ => HuffTree.htLeaf 0 0
  | fuel + 1, s =>
      match hextract₁ : s.heap.extractMin with
      | none => HuffTree.htLeaf 0 0
      | some (e₁, h₁) =>
          match hextract₂ : h₁.extractMin with
          | none => e₁.tree
          | some (_e₂, _h₂) =>
              heapHuffmanLoop fuel
                (HeapHuffmanState.mergeState s hextract₁ hextract₂)

Textbook Huffman using the verified binary min-heap.

def heapHuffmanOfFreqs (xs : List (Nat × Nat)) : HuffTree :=
  heapHuffmanLoop xs.length (HeapHuffmanState.ofFreqs xs)



theorem MinHeap.orderedView_eq_nil_iff {params : HeapParams}
    (h : MinHeap params) : h.orderedView = [] ↔ h.data = [] := by
  constructor
  · intro hview
    change h.ranked.data = []
    apply List.eq_nil_of_length_eq_zero
    rw [← orderedEntries_length h.ranked.data]
    simpa [MinHeap.orderedView] using congrArg List.length hview
  · intro hdata
    change h.ranked.data = [] at hdata
    change orderedEntries h.ranked.data = []
    simp [hdata, orderedEntries]

The complete heap loop refines the existing sorted-list recursion exactly.


theorem heapHuffmanLoop_eq_huffman {params : HeapParams}
    (s : HeapHuffmanState params) :
    heapHuffmanLoop s.heap.data.length s =
      huffman (s.heap.orderedView.map HeapEntry.tree) := by
  induction hlen : s.heap.data.length using Nat.strong_induction_on generalizing s with
  | h n ih =>
      cases n with
      | zero =>
          have hdata : s.heap.data = [] := List.eq_nil_of_length_eq_zero hlen
          have hview : s.heap.orderedView = [] :=
            (MinHeap.orderedView_eq_nil_iff s.heap).2 hdata
          simp [heapHuffmanLoop, hview, huffman]
      | succ n =>
          simp only [heapHuffmanLoop]
          split
          next hextract₁ =>
            have hdata : s.heap.data = [] :=
              (MinHeap.extractMin_eq_none_iff s.heap).1 hextract₁
            change s.heap.ranked.data = [] at hdata
            change s.heap.ranked.data.length = n + 1 at hlen
            simp [hdata] at hlen
          next e₁ h₁ hextract₁ =>
            have hview₁ := MinHeap.orderedView_extractMin
              s.stampsNodup hextract₁
            have hnodup₁ := HeapHuffmanState.stampsNodup_after_extract
              s.stampsNodup hextract₁
            split
            next hextract₂ =>
              have hdata₁ : h₁.data = [] :=
                (MinHeap.extractMin_eq_none_iff h₁).1 hextract₂
              have hviewEmpty : h₁.orderedView = [] :=
                (MinHeap.orderedView_eq_nil_iff h₁).2 hdata₁
              have htrees :
                  s.heap.orderedView.map HeapEntry.tree = [e₁.tree] := by
                rw [hview₁, hviewEmpty]
                rfl
              rw [htrees]
              simp [huffman]
            next e₂ h₂ hextract₂ =>
              let next := HeapHuffmanState.mergeState s hextract₁ hextract₂
              have hnextSize : next.heap.ranked.data.length = n := by
                have hdrop := HeapHuffmanState.mergeState_size
                  s hextract₁ hextract₂
                change next.heap.ranked.data.length + 1 =
                  s.heap.ranked.data.length at hdrop
                change s.heap.ranked.data.length = n + 1 at hlen
                omega
              have hnextLt : next.heap.ranked.data.length < n + 1 := by omega
              have hrec := ih next.heap.ranked.data.length hnextLt next rfl
              have hrec' :
                  heapHuffmanLoop n next =
                    huffman (next.heap.orderedView.map HeapEntry.tree) := by
                rw [hnextSize] at hrec
                exact hrec
              have hview₂ := MinHeap.orderedView_extractMin hnodup₁ hextract₂
              have holdTrees :
                  s.heap.orderedView.map HeapEntry.tree =
                    e₁.tree :: e₂.tree :: h₂.orderedView.map HeapEntry.tree := by
                rw [hview₁, hview₂]
                rfl
              have hnextTrees := HeapHuffmanState.mergeState_ordered_trees
                s hextract₁ hextract₂
              calc
                heapHuffmanLoop n next =
                    huffman (next.heap.orderedView.map HeapEntry.tree) := hrec'
                _ = huffman
                    (insortTree (unite e₁.tree e₂.tree)
                      (h₂.orderedView.map HeapEntry.tree)) := by rw [hnextTrees]
                _ = huffman (s.heap.orderedView.map HeapEntry.tree) := by
                  rw [holdTrees]
                  symm
                  simp [huffman]

Exact erasure/refinement theorem for the public frequency-table program.


theorem heapHuffmanOfFreqs_eq (xs : List (Nat × Nat)) :
    heapHuffmanOfFreqs xs = huffmanOfFreqs xs := by
  let s := HeapHuffmanState.ofFreqs xs
  calc
    heapHuffmanOfFreqs xs = heapHuffmanLoop s.heap.data.length s := by
      have hs := HeapHuffmanState.ofFreqs_size xs
      change s.heap.ranked.data.length = xs.length at hs
      unfold heapHuffmanOfFreqs
      change heapHuffmanLoop xs.length s =
        heapHuffmanLoop s.heap.ranked.data.length s
      rw [hs]
    _ = huffman (s.heap.orderedView.map HeapEntry.tree) :=
      heapHuffmanLoop_eq_huffman s
    _ = huffman (sortForest (leavesOfFreqs xs)) := by
      rw [HeapHuffmanState.ofFreqs_ordered_trees]
    _ = huffmanOfFreqs xs := rfl

Frequency semantics and optimality transported to the genuine heap run.


theorem heapHuffmanOfFreqs_semantic_correct (xs : List (Nat × Nat))
    (h_nodup : (xs.map Prod.fst).Nodup)
    (h_pos : ∀ p ∈ xs, p.2 > 0)
    (h_nonempty : xs ≠ []) :
    (∀ symbol, freqOf symbol (heapHuffmanOfFreqs xs) = tableFreq xs symbol) ∧
      optimum (heapHuffmanOfFreqs xs) := by
  rw [heapHuffmanOfFreqs_eq]
  exact huffmanOfFreqs_correct xs h_nodup h_pos h_nonempty

end CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.HeapExecution.Operations

Verified structural operations for the Huffman binary heap

The central reuse theorem says that mapping entries to ranks commutes with every heap controller. Chapter 6 can therefore discharge the indexed heap invariant while this module separately proves preservation of the actual tree multiset.

              namespace CLRS.HuffmanV2section Swapvariable {α β : Type}

Auxiliary permutation lemma for a generic head/cell exchange.

theorem cons_set_perm_of_get?_generic {xs : List α} {j : Nat} {x y : α}
    (h : xs[j]? = some y) : (y :: xs.set j x).Perm (x :: xs) := by
  induction xs generalizing j with
  | nil => simp at h
  | cons z zs ih =>
      cases j with
      | zero =>
          simp at h
          subst y
          simp [List.set]
          exact List.Perm.swap x z zs
      | succ j =>
          simp at h
          have ih' := ih h
          simp [List.set]
          exact ((List.Perm.swap y z (zs.set j x)).symm.trans
            (List.Perm.cons z ih')).trans (List.Perm.swap z x zs).symm

@[simp] theorem swapEntries_length (a : List α) (i j : Nat) :
    (swapEntries a i j).length = a.length := by
  unfold swapEntries
  cases a[i]? <;> cases a[j]? <;> simp

theorem swapEntries_perm (a : List α) (i j : Nat) :
    (swapEntries a i j).Perm a := by
  induction a generalizing i j with
  | nil => simp [swapEntries]
  | cons x xs ih =>
      cases i with
      | zero =>
          cases j with
          | zero => simp [swapEntries]
          | succ j =>
              unfold swapEntries
              simp
              cases h : xs[j]? with
              | none => simp
              | some y =>
                  simpa [h, List.set] using
                    cons_set_perm_of_get?_generic (xs := xs) (j := j) (x := x) h
      | succ i =>
          cases j with
          | zero =>
              unfold swapEntries
              simp
              cases h : xs[i]? with
              | none => simp
              | some y =>
                  simpa [h, List.set] using
                    cons_set_perm_of_get?_generic (xs := xs) (j := i) (x := x) h
          | succ j =>
              cases hi : xs[i]? with
              | none => simp [swapEntries, hi]
              | some ai =>
                  cases hj : xs[j]? with
                  | none => simp [swapEntries, hi, hj]
                  | some aj =>
                      simpa [swapEntries, hi, hj, List.set] using ih i j

Mapping a generic swap is exactly Chapter 6's natural-key swap.

theorem map_swapEntries (f : α → Nat) (a : List α) (i j : Nat) :
    (swapEntries a i j).map f =
      CLRS.Chapter06.swapAt (a.map f) i j := by
  unfold swapEntries CLRS.Chapter06.swapAt
  simp only [List.getElem?_map]
  cases hi : a[i]? <;> cases hj : a[j]? <;>
    simp [List.map_set]

The right destination of an in-bounds generic swap contains the old left value.


theorem getElem?_swapEntries_right {a : List α} {i j : Nat}
    (hi : i < a.length) (hj : j < a.length) :
    (swapEntries a i j)[j]? = a[i]? := by
  by_cases hij : i = j
  · subst j
    simp [swapEntries, List.getElem?_eq_getElem hi]
  · unfold swapEntries
    rw [List.getElem?_eq_getElem hi, List.getElem?_eq_getElem hj]
    simp
    rw [List.getElem?_set_self']
    have hjset : j < (a.set i a[j]).length := by simpa using hj
    simp [List.getElem?_eq_getElem hjset]

end Swap

Controller erasure and structural laws

              

theorem bubbleUpFuel_map_rank (rank : HeapEntry → Nat) (fuel : Nat)
    (a : List HeapEntry) (heapSize i : Nat) :
    (bubbleUpFuel rank fuel a heapSize i).map rank =
      CLRS.Chapter06.arrayHeapIncreaseKeyBubbleUpFuel fuel (a.map rank)
        heapSize i := by
  induction fuel generalizing a i with
  | zero => rfl
  | succ fuel ih =>
      simp only [bubbleUpFuel,
        CLRS.Chapter06.arrayHeapIncreaseKeyBubbleUpFuel]
      split_ifs
      · rw [ih, map_swapEntries]
      · rfl
      · rfl

@[simp] theorem bubbleUpFuel_length (rank : HeapEntry → Nat) (fuel : Nat)
    (a : List HeapEntry) (heapSize i : Nat) :
    (bubbleUpFuel rank fuel a heapSize i).length = a.length := by
  induction fuel generalizing a i with
  | zero => rfl
  | succ fuel ih =>
      simp only [bubbleUpFuel]
      split_ifs
      · rw [ih, swapEntries_length]
      · rfl
      · rfltheorem bubbleUpFuel_perm (rank : HeapEntry → Nat) (fuel : Nat)
    (a : List HeapEntry) (heapSize i : Nat) :
    (bubbleUpFuel rank fuel a heapSize i).Perm a := by
  induction fuel generalizing a i with
  | zero => rfl
  | succ fuel ih =>
      simp only [bubbleUpFuel]
      split_ifs
      · exact (ih _ _).trans (swapEntries_perm _ _ _)
      · rfl
      · rfl

theorem bubbleDownFuel_map_rank (rank : HeapEntry → Nat) (fuel : Nat)
    (a : List HeapEntry) (heapSize i : Nat) :
    (bubbleDownFuel rank fuel a heapSize i).map rank =
      CLRS.Chapter06.maxHeapifyFuel fuel (a.map rank) heapSize i := by
  induction fuel generalizing a i with
  | zero => rfl
  | succ fuel ih =>
      simp only [bubbleDownFuel, CLRS.Chapter06.maxHeapifyFuel]
      split
      · rfl
      · rw [ih, map_swapEntries]

@[simp] theorem bubbleDownFuel_length (rank : HeapEntry → Nat) (fuel : Nat)
    (a : List HeapEntry) (heapSize i : Nat) :
    (bubbleDownFuel rank fuel a heapSize i).length = a.length := by
  induction fuel generalizing a i with
  | zero => rfl
  | succ fuel ih =>
      simp only [bubbleDownFuel]
      split
      · rfl
      · rw [ih, swapEntries_length]theorem bubbleDownFuel_perm (rank : HeapEntry → Nat) (fuel : Nat)
    (a : List HeapEntry) (heapSize i : Nat) :
    (bubbleDownFuel rank fuel a heapSize i).Perm a := by
  induction fuel generalizing a i with
  | zero => rfl
  | succ fuel ih =>
      simp only [bubbleDownFuel]
      split
      · rfl
      · exact (ih _ _).trans (swapEntries_perm _ _ _)@[simp] theorem heapInsertRaw_length (rank : HeapEntry → Nat)
    (a : List HeapEntry) (e : HeapEntry) :
    (heapInsertRaw rank a e).length = a.length + 1 := by
  simp [heapInsertRaw]theorem heapInsertRaw_perm (rank : HeapEntry → Nat)
    (a : List HeapEntry) (e : HeapEntry) :
    (heapInsertRaw rank a e).Perm (e :: a) := by
  exact (bubbleUpFuel_perm rank a.length (a ++ [e]) (a.length + 1) a.length).trans
    (by
      convert (List.perm_append_comm (l₁ := a) (l₂ := [e])) using 1
      all_goals simp)

theorem heapInsertRaw_map_rank (rank : HeapEntry → Nat)
    (a : List HeapEntry) (e : HeapEntry) :
    (heapInsertRaw rank a e).map rank =
      CLRS.Chapter06.arrayHeapInsert (a.map rank) (rank e) := by
  simp only [heapInsertRaw, CLRS.Chapter06.arrayHeapInsert]
  rw [bubbleUpFuel_map_rank]
  simp

Heap invariant preservation



theorem heapInsertRaw_isRankHeap {rank : HeapEntry → Nat}
    {a : List HeapEntry} (e : HeapEntry) (hheap : IsRankHeap rank a) :
    IsRankHeap rank (heapInsertRaw rank a e) := by
  unfold IsRankHeap at hheap ⊢
  rw [heapInsertRaw_map_rank]
  have hheap' :
      CLRS.Chapter06.ArrayMaxHeap (a.map rank) (a.map rank).length := by
    simpa using hheap
  simpa [heapInsertRaw_length] using
    CLRS.Chapter06.arrayHeapInsert_isMaxHeap (rank e) hheap'

Taking the active prefix preserves an except-at-one-node heap predicate.

theorem arrayMaxHeapExcept_take {a : List Nat} {heapSize bad : Nat}
    (hheap : CLRS.Chapter06.ArrayMaxHeapExcept a heapSize bad) :
    CLRS.Chapter06.ArrayMaxHeapExcept (a.take heapSize) heapSize bad := by
  have hlen : (a.take heapSize).length = heapSize :=
    List.length_take_of_le hheap.heapSize_le_length
  refine ⟨by simp [hlen], ?_, ?_⟩
  · intro i hi hne hl
    simpa only [List.getElem_take] using hheap.left_le hi hne hl
  · intro i hi hne hr
    simpa only [List.getElem_take] using hheap.right_le hi hne hr

One raw extraction removes exactly the returned root entry.


theorem heapExtractMaxRaw_perm {rank : HeapEntry → Nat}
    {a rest : List HeapEntry} {root : HeapEntry}
    (h : heapExtractMaxRaw rank a = some (root, rest)) :
    (root :: rest).Perm a := by
  cases a with
  | nil => simp [heapExtractMaxRaw] at h
  | cons x xs =>
      simp only [heapExtractMaxRaw, Option.some.injEq, Prod.mk.injEq] at h
      rcases h with ⟨rfl, rfl⟩
      let moved := swapEntries (x :: xs) 0 xs.length
      let active := moved.take xs.length
      have hlenMoved : moved.length = xs.length + 1 := by
        simp [moved]
      have hlast : xs.length < moved.length := by omega
      have hlastValue : moved[xs.length]'hlast = x := by
        have hread :=
          getElem?_swapEntries_right (a := x :: xs) (i := 0) (j := xs.length)
            (by simp) (by simp)
        rw [List.getElem?_eq_getElem hlast] at hread
        simpa [moved] using hread
      have hsplit : active ++ [x] = moved := by
        calc
          active ++ [x] = moved.take xs.length ++ [moved[xs.length]] := by
            simp [active, hlastValue]
          _ = moved.take (xs.length + 1) := by simp
          _ = moved := by simp [hlenMoved]
      have hactive : (x :: active).Perm (x :: xs) := by
        have hrotate : (x :: active).Perm (active ++ [x]) := by
          simpa using (List.perm_append_comm (l₁ := [x]) (l₂ := active))
        exact hrotate.trans (by rw [hsplit]; exact swapEntries_perm _ _ _)
      exact (List.Perm.cons x
        (bubbleDownFuel_perm rank xs.length active xs.length 0)).trans hactive

theorem heapExtractMaxRaw_length {rank : HeapEntry → Nat}
    {a rest : List HeapEntry} {root : HeapEntry}
    (h : heapExtractMaxRaw rank a = some (root, rest)) :
    rest.length + 1 = a.length := by
  have hp := heapExtractMaxRaw_perm h
  simpa using hp.length_eq

theorem heapExtractMaxRaw_eq_none_iff (rank : HeapEntry → Nat)
    (a : List HeapEntry) : heapExtractMaxRaw rank a = none ↔ a = [] := by
  cases a <;> simp [heapExtractMaxRaw]

Extraction from a ranked heap returns a ranked heap of one smaller size.


theorem heapExtractMaxRaw_isRankHeap {rank : HeapEntry → Nat}
    {a rest : List HeapEntry} {root : HeapEntry}
    (hheap : IsRankHeap rank a)
    (h : heapExtractMaxRaw rank a = some (root, rest)) :
    IsRankHeap rank rest := by
  cases a with
  | nil => simp [heapExtractMaxRaw] at h
  | cons x xs =>
      simp only [heapExtractMaxRaw, Option.some.injEq, Prod.mk.injEq] at h
      rcases h with ⟨rfl, rfl⟩
      let scores := (x :: xs).map rank
      let moved := CLRS.Chapter06.swapAt scores 0 xs.length
      let active := moved.take xs.length
      have hheapScores : CLRS.Chapter06.ArrayMaxHeap scores (xs.length + 1) := by
        simpa [IsRankHeap, scores] using hheap
      have hexceptFull :
          CLRS.Chapter06.ArrayMaxHeapExcept moved xs.length 0 := by
        exact CLRS.Chapter06.ArrayMaxHeapExcept.of_swap_root_last hheapScores
      have hexceptActive :
          CLRS.Chapter06.ArrayMaxHeapExcept active xs.length 0 :=
        arrayMaxHeapExcept_take hexceptFull
      have hvalidNat :
          CLRS.Chapter06.ArrayMaxHeap
            (CLRS.Chapter06.maxHeapifyFuel xs.length active xs.length 0)
            xs.length := by
        by_cases hpos : 0 < xs.length
        · exact CLRS.Chapter06.maxHeapifyFuel_root_isMaxHeap
            hexceptActive hpos (Nat.le_refl _)
        · have hzero : xs.length = 0 := by omega
          rw [hzero]
          exact ⟨by simp [active], by intro i hi; omega, by intro i hi; omega⟩
      unfold IsRankHeap
      rw [bubbleDownFuel_map_rank]
      have hmapActive :
          ((swapEntries (x :: xs) 0 xs.length).take xs.length).map rank = active := by
        simp [active, moved, scores, map_swapEntries]
      rw [hmapActive]
      simpa using hvalidNat

The extracted root has maximum rank among all entries in the old heap.


theorem heapExtractMaxRaw_rank_max {rank : HeapEntry → Nat}
    {a rest : List HeapEntry} {root : HeapEntry}
    (hheap : IsRankHeap rank a)
    (h : heapExtractMaxRaw rank a = some (root, rest)) :
    ∀ e ∈ a, rank e ≤ rank root := by
  intro e he
  cases a with
  | nil => simp at he
  | cons x xs =>
      simp only [heapExtractMaxRaw, Option.some.injEq, Prod.mk.injEq] at h
      have hx : root = x := h.1.symm
      subst root
      have heMap : rank e ∈ (x :: xs).map rank := List.mem_map.mpr ⟨e, he, rfl⟩
      rcases List.get_of_mem heMap with ⟨i, hi⟩
      have hheap' :
          CLRS.Chapter06.ArrayMaxHeap ((x :: xs).map rank)
            ((x :: xs).map rank).length := by
        simpa [IsRankHeap] using hheap
      have hbound := hheap'.getElem_le_root i.isLt
      change ((x :: xs).map rank).get i ≤ rank x at hbound
      rw [hi] at hbound
      exact hbound

Packaged ranked heap

A concrete binary heap bundled with its verified ranked-array invariant.

structure RankedHeap (rank : HeapEntry → Nat) where
  data : List HeapEntry
  valid : IsRankHeap rank data

              namespace RankedHeapdef empty (rank : HeapEntry → Nat) : RankedHeap rank :=
  ⟨[], by
    unfold IsRankHeap
    refine ⟨by simp, ?_, ?_⟩
    · intro i hi hl
      simp at hi
    · intro i hi hr
      simp at hi⟩def insert {rank : HeapEntry → Nat} (h : RankedHeap rank)
    (e : HeapEntry) : RankedHeap rank :=
  ⟨heapInsertRaw rank h.data e, heapInsertRaw_isRankHeap e h.valid⟩def extractMax {rank : HeapEntry → Nat} (h : RankedHeap rank) :
    Option (HeapEntry × RankedHeap rank) :=
  match hextract : heapExtractMaxRaw rank h.data with
  | none => none
  | some (e, data) => some (e, ⟨data, heapExtractMaxRaw_isRankHeap h.valid hextract⟩)

Erasing the invariant package recovers the raw extraction exactly.

theorem extractMax_erases {rank : HeapEntry → Nat} (h : RankedHeap rank) :
    h.extractMax.map (fun p => (p.1, p.2.data)) =
      heapExtractMaxRaw rank h.data := by
  unfold extractMax
  split <;> simp_all

              

theorem extractMax_eq_none_iff {rank : HeapEntry → Nat} (h : RankedHeap rank) :
    h.extractMax = none ↔ h.data = [] := by
  constructor
  · intro hnone
    have hmapped :
        h.extractMax.map (fun p => (p.1, p.2.data)) = none := by simp [hnone]
    rw [extractMax_erases] at hmapped
    exact (heapExtractMaxRaw_eq_none_iff rank h.data).mp hmapped
  · intro hempty
    have hraw : heapExtractMaxRaw rank h.data = none :=
      (heapExtractMaxRaw_eq_none_iff rank h.data).mpr hempty
    cases hextract : h.extractMax with
    | none => rfl
    | some result =>
        have hmapped :
            h.extractMax.map (fun p => (p.1, p.2.data)) = none := by
          rw [extractMax_erases, hraw]
        simp [hextract] at hmapped@[simp] theorem empty_data (rank : HeapEntry → Nat) :
    (empty rank).data = [] := rfl@[simp] theorem insert_data {rank : HeapEntry → Nat} (h : RankedHeap rank)
    (e : HeapEntry) : (h.insert e).data = heapInsertRaw rank h.data e := rfl@[simp] theorem insert_size {rank : HeapEntry → Nat} (h : RankedHeap rank)
    (e : HeapEntry) : (h.insert e).data.length = h.data.length + 1 := by
  simp [insert]theorem insert_perm {rank : HeapEntry → Nat} (h : RankedHeap rank)
    (e : HeapEntry) : (h.insert e).data.Perm (e :: h.data) :=
  heapInsertRaw_perm rank h.data e

theorem extractMax_spec {rank : HeapEntry → Nat} {h : RankedHeap rank}
    {e : HeapEntry} {h' : RankedHeap rank}
    (hextract : h.extractMax = some (e, h')) :
    (e :: h'.data).Perm h.data ∧
      h'.data.length + 1 = h.data.length ∧
      ∀ u ∈ h.data, rank u ≤ rank e := by
  have hmapped := congrArg (Option.map (fun p => (p.1, p.2.data))) hextract
  rw [extractMax_erases] at hmapped
  have hraw : heapExtractMaxRaw rank h.data = some (e, h'.data) := by
    simpa using hmapped
  exact ⟨heapExtractMaxRaw_perm hraw, heapExtractMaxRaw_length hraw,
    heapExtractMaxRaw_rank_max h.valid hraw⟩end RankedHeap

Bounded binary min-heap for Huffman priorities

Parent/child invariant stated directly in Huffman's lexicographic order.

def IsMinHeap (a : List HeapEntry) : Prop :=
  (∀ {i : Nat}, (hi : i < a.length) →
      (hl : CLRS.Chapter06.left i < a.length) →
      HeapEntry.PriorityLE a[i] a[CLRS.Chapter06.left i]) ∧
    (∀ {i : Nat}, (hi : i < a.length) →
      (hr : CLRS.Chapter06.right i < a.length) →
      HeapEntry.PriorityLE a[i] a[CLRS.Chapter06.right i])

A ranked array together with the bounds that make its rank order faithful.

structure MinHeap (params : HeapParams) where
  ranked : RankedHeap params.rank
  bounded : ∀ e ∈ ranked.data, params.Bounded e

              namespace MinHeapdef data {params : HeapParams} (h : MinHeap params) : List HeapEntry :=
  h.ranked.data@[simp] theorem data_eq {params : HeapParams} (h : MinHeap params) :
    h.data = h.ranked.data := rfl

The inherited numeric max-heap is genuinely a binary min-heap on entries.

theorem valid {params : HeapParams} (h : MinHeap params) : IsMinHeap h.data := by
  change IsMinHeap h.ranked.data
  constructor
  · intro i hi hl
    have hrank := h.ranked.valid.left_le hi hl
    apply (HeapParams.priorityLE_iff_rank_ge
      (h.bounded h.ranked.data[i] (List.getElem_mem hi))
      (h.bounded h.ranked.data[CLRS.Chapter06.left i] (List.getElem_mem hl))).2
    simpa only [List.getElem_map] using hrank
  · intro i hi hr
    have hrank := h.ranked.valid.right_le hi hr
    apply (HeapParams.priorityLE_iff_rank_ge
      (h.bounded h.ranked.data[i] (List.getElem_mem hi))
      (h.bounded h.ranked.data[CLRS.Chapter06.right i] (List.getElem_mem hr))).2
    simpa only [List.getElem_map] using hrank

def empty (params : HeapParams) : MinHeap params :=
  ⟨RankedHeap.empty params.rank, by simp⟩

def insert {params : HeapParams} (h : MinHeap params) (e : HeapEntry)
    (he : params.Bounded e) : MinHeap params :=
  ⟨h.ranked.insert e, by
    intro u hu
    have hu' : u ∈ e :: h.ranked.data :=
      (List.Perm.mem_iff (RankedHeap.insert_perm h.ranked e)).mp hu
    simp only [List.mem_cons] at hu'
    rcases hu' with hue | hu'
    · subst u
      exact he
    · exact h.bounded u hu'⟩

Initialize a verified heap by repeated executable insertion.

def build (params : HeapParams) :
    (entries : List HeapEntry) →
      (∀ e ∈ entries, params.Bounded e) → MinHeap params
  | [], _ => empty params
  | e :: entries, hbounded =>
      let tailHeap := build params entries (fun u hu => hbounded u (by simp [hu]))
      tailHeap.insert e (hbounded e (by simp))

              

def extractMin {params : HeapParams} (h : MinHeap params) :
    Option (HeapEntry × MinHeap params) :=
  match hextract : h.ranked.extractMax with
  | none => none
  | some (e, ranked') =>
      some (e, ⟨ranked', by
        intro u hu
        have hspec := RankedHeap.extractMax_spec hextract
        have hu' : u ∈ e :: ranked'.data := by simp [hu]
        exact h.bounded u ((List.Perm.mem_iff hspec.1).mp hu')⟩)@[simp] theorem empty_data (params : HeapParams) :
    (empty params).data = [] := rfl@[simp] theorem insert_data {params : HeapParams} (h : MinHeap params)
    (e : HeapEntry) (he : params.Bounded e) :
    (h.insert e he).data = (h.ranked.insert e).data := rfltheorem insert_perm {params : HeapParams} (h : MinHeap params)
    (e : HeapEntry) (he : params.Bounded e) :
    (h.insert e he).data.Perm (e :: h.data) :=
  RankedHeap.insert_perm h.ranked e

theorem build_perm (params : HeapParams) (entries : List HeapEntry)
    (hbounded : ∀ e ∈ entries, params.Bounded e) :
    (build params entries hbounded).data.Perm entries := by
  induction entries with
  | nil => rfl
  | cons e entries ih =>
      simp only [build]
      let htail : ∀ u ∈ entries, params.Bounded u :=
        fun u hu => hbounded u (by simp [hu])
      exact (insert_perm (build params entries htail) e (hbounded e (by simp))).trans
        (List.Perm.cons e (ih htail))@[simp] theorem build_size (params : HeapParams) (entries : List HeapEntry)
    (hbounded : ∀ e ∈ entries, params.Bounded e) :
    (build params entries hbounded).data.length = entries.length := by
  exact (build_perm params entries hbounded).length_eq@[simp] theorem insert_size {params : HeapParams} (h : MinHeap params)
    (e : HeapEntry) (he : params.Bounded e) :
    (h.insert e he).data.length = h.data.length + 1 := by
  exact RankedHeap.insert_size h.ranked e

Erasing the bounded package recovers ranked extraction.

theorem extractMin_erases {params : HeapParams} (h : MinHeap params) :
    h.extractMin.map (fun p => (p.1, p.2.ranked)) = h.ranked.extractMax := by
  unfold extractMin
  split <;> simp_all

Complete minimum, multiset, and size contract for one extraction.


theorem extractMin_spec {params : HeapParams} {h : MinHeap params}
    {e : HeapEntry} {h' : MinHeap params}
    (hextract : h.extractMin = some (e, h')) :
    (e :: h'.data).Perm h.data ∧
      h'.data.length + 1 = h.data.length ∧
      ∀ u ∈ h.data, HeapEntry.PriorityLE e u := by
  have hmapped := congrArg (Option.map (fun p => (p.1, p.2.ranked))) hextract
  rw [extractMin_erases] at hmapped
  have hranked : h.ranked.extractMax = some (e, h'.ranked) := by
    simpa using hmapped
  have hspec := RankedHeap.extractMax_spec hranked
  refine ⟨hspec.1, hspec.2.1, ?_⟩
  intro u hu
  exact (HeapParams.priorityLE_iff_rank_ge
    (h.bounded e ((List.Perm.mem_iff hspec.1).mp (by simp)))
    (h.bounded u hu)).2 (hspec.2.2 u hu)

              

theorem extractMin_eq_none_iff {params : HeapParams} (h : MinHeap params) :
    h.extractMin = none ↔ h.data = [] := by
  constructor
  · intro hnone
    have hmapped :
        h.extractMin.map (fun p => (p.1, p.2.ranked)) = none := by simp [hnone]
    rw [extractMin_erases] at hmapped
    exact (RankedHeap.extractMax_eq_none_iff h.ranked).mp hmapped
  · intro hempty
    have hranked : h.ranked.extractMax = none :=
      (RankedHeap.extractMax_eq_none_iff h.ranked).mpr hempty
    have hmapped :
        h.extractMin.map (fun p => (p.1, p.2.ranked)) = none := by
      rw [extractMin_erases, hranked]
    cases hextract : h.extractMin with
    | none => rfl
    | some result => simp [hextract] at hmappedend MinHeapend CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.HeapExecution.Ranking

Order-preserving finite ranks for Huffman heap entries

Chapter 6 verifies max-heaps of natural keys. On one Huffman input, all active frequencies and stamps have explicit finite bounds. Complementing the bounded lexicographic code turns the smallest Huffman priority into the largest natural rank and permits direct reuse of those max-heap theorems.

namespace CLRS.HuffmanV2

Bounds fixed for one complete Huffman execution.

structure HeapParams where
  inputSize : Nat
  totalFreq : Nat
  deriving Repr, DecidableEq

namespace HeapParams

The stamp base is strictly larger than every initial or merge stamp.

def base (p : HeapParams) : Nat := 2 * p.inputSize + 1

Lexicographic priority encoded with the bounded stamp as the low digit.

def code (p : HeapParams) (e : HeapEntry) : Nat :=
  rootFreq e.tree * p.base + e.stamp

One-past-frequency capacity for complementing a bounded code.

def capacity (p : HeapParams) : Nat :=
  (p.totalFreq + 1) * p.base

Natural max-heap rank: a smaller frequency/stamp pair means a larger rank.

def rank (p : HeapParams) (e : HeapEntry) : Nat :=
  p.capacity - p.code e

The entry lies inside the fixed frequency and stamp envelope.

def Bounded (p : HeapParams) (e : HeapEntry) : Prop :=
  rootFreq e.tree ≤ p.totalFreq ∧ e.stamp < p.base

              theorem base_pos (p : HeapParams) : 0 < p.base := by
  simp [base]theorem code_lt_capacity {p : HeapParams} {e : HeapEntry}
    (he : p.Bounded e) : p.code e < p.capacity := by
  have hmul : rootFreq e.tree * p.base ≤ p.totalFreq * p.base :=
    Nat.mul_le_mul_right p.base he.1
  have hadd :
      rootFreq e.tree * p.base + e.stamp <
        p.totalFreq * p.base + p.base :=
    Nat.add_lt_add_of_le_of_lt hmul he.2
  simpa [code, capacity, Nat.add_mul] using haddtheorem code_le_capacity {p : HeapParams} {e : HeapEntry}
    (he : p.Bounded e) : p.code e ≤ p.capacity :=
  Nat.le_of_lt (code_lt_capacity he)private theorem code_lt_of_freq_lt {p : HeapParams} {a b : HeapEntry}
    (ha : p.Bounded a) (hfreq : rootFreq a.tree < rootFreq b.tree) :
    p.code a < p.code b := by
  have hstamp :
      rootFreq a.tree * p.base + a.stamp <
        rootFreq a.tree * p.base + p.base :=
    Nat.add_lt_add_left ha.2 _
  have hfreqMul :
      (rootFreq a.tree + 1) * p.base ≤ rootFreq b.tree * p.base :=
    Nat.mul_le_mul_right p.base (Nat.succ_le_of_lt hfreq)
  calc
    p.code a < (rootFreq a.tree + 1) * p.base := by
      simpa [code, Nat.add_mul] using hstamp
    _ ≤ rootFreq b.tree * p.base := hfreqMul
    _ ≤ p.code b := by simp [code]

Bounded mixed-radix encoding exactly reflects lexicographic priority.

theorem priorityLE_iff_code_le {p : HeapParams} {a b : HeapEntry}
    (ha : p.Bounded a) (hb : p.Bounded b) :
    HeapEntry.PriorityLE a b ↔ p.code a ≤ p.code b := by
  constructor
  · intro hab
    rcases hab with hfreq | ⟨hfreq, hstamp⟩
    · exact Nat.le_of_lt (code_lt_of_freq_lt ha hfreq)
    · simpa [code, hfreq] using Nat.add_le_add_left hstamp
  · intro hcode
    by_cases hfreq : rootFreq a.tree < rootFreq b.tree
    · exact Or.inl hfreq
    · have hba : rootFreq b.tree ≤ rootFreq a.tree := Nat.le_of_not_gt hfreq
      by_cases heq : rootFreq a.tree = rootFreq b.tree
      · right
        refine ⟨heq, ?_⟩
        simpa [code, heq] using hcode
      · have hrev : rootFreq b.tree < rootFreq a.tree :=
          Nat.lt_of_le_of_ne hba (Ne.symm heq)
        have hstrict : p.code b < p.code a := code_lt_of_freq_lt hb hrev
        omega

Complemented rank reverses the bounded priority order exactly.


theorem priorityLE_iff_rank_ge {p : HeapParams} {a b : HeapEntry}
    (ha : p.Bounded a) (hb : p.Bounded b) :
    HeapEntry.PriorityLE a b ↔ p.rank b ≤ p.rank a := by
  rw [priorityLE_iff_code_le ha hb]
  unfold rank
  have hca := code_le_capacity ha
  have hcb := code_le_capacity hb
  omega

The frequency total attached to a raw table.

def tableTotal (xs : List (Nat × Nat)) : Nat :=
  (xs.map Prod.snd).sum

Fixed heap bounds used by the execution on a frequency table.

def ofFreqs (xs : List (Nat × Nat)) : HeapParams :=
  { inputSize := xs.length, totalFreq := tableTotal xs }

end HeapParamsend CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.HeapExecution.Refinement

The ordered entry list is a proof-only observation. The executable operations use only the array heap; sorting appears solely in the refinement specification.

namespace CLRS.HuffmanV2

Insert one entry into a priority-sorted proof view.

def insertEntry (e : HeapEntry) : List HeapEntry → List HeapEntry
  | [] => [e]
  | u :: us =>
      if HeapEntry.PriorityLE e u then e :: u :: us
      else u :: insertEntry e us

Canonical priority-sorted observation of an entry multiset.

def orderedEntries : List HeapEntry → List HeapEntry
  | [] => []
  | e :: es => insertEntry e (orderedEntries es)

              @[simp] theorem insertEntry_length (e : HeapEntry) (es : List HeapEntry) :
    (insertEntry e es).length = es.length + 1 := by
  induction es with
  | nil => rfl
  | cons u us ih => simp [insertEntry]; split <;> simp [ih]theorem insertEntry_perm (e : HeapEntry) (es : List HeapEntry) :
    (insertEntry e es).Perm (e :: es) := by
  induction es with
  | nil => rfl
  | cons u us ih =>
      simp only [insertEntry]
      split
      · rfl
      · exact (List.Perm.cons u ih).trans (List.Perm.swap u e us).symm@[simp] theorem orderedEntries_length (es : List HeapEntry) :
    (orderedEntries es).length = es.length := by
  induction es with
  | nil => rfl
  | cons e es ih => simp [orderedEntries, ih]theorem orderedEntries_perm (es : List HeapEntry) :
    (orderedEntries es).Perm es := by
  induction es with
  | nil => rfl
  | cons e es ih =>
      exact (insertEntry_perm e (orderedEntries es)).trans (List.Perm.cons e ih)theorem mem_insertEntry (x e : HeapEntry) (es : List HeapEntry) :
    x ∈ insertEntry e es ↔ x = e ∨ x ∈ es := by
  simpa only [List.mem_cons] using List.Perm.mem_iff (insertEntry_perm e es)theorem mem_orderedEntries (x : HeapEntry) (es : List HeapEntry) :
    x ∈ orderedEntries es ↔ x ∈ es :=
  List.Perm.mem_iff (orderedEntries_perm es)

theorem pairwise_insertEntry {e : HeapEntry} {es : List HeapEntry}
    (hsorted : es.Pairwise HeapEntry.PriorityLE) :
    (insertEntry e es).Pairwise HeapEntry.PriorityLE := by
  induction es with
  | nil => simp [insertEntry]
  | cons u us ih =>
      rw [List.pairwise_cons] at hsorted
      simp only [insertEntry]
      by_cases heu : HeapEntry.PriorityLE e u
      · rw [if_pos heu, List.pairwise_cons]
        refine ⟨?_, (List.pairwise_cons.mpr hsorted)⟩
        intro x hx
        simp only [List.mem_cons] at hx
        rcases hx with hxu | hx
        · subst x
          exact heu
        · exact HeapEntry.priorityLE_trans heu (hsorted.1 x hx)
      · rw [if_neg heu, List.pairwise_cons]
        refine ⟨?_, ih hsorted.2⟩
        intro x hx
        rw [mem_insertEntry] at hx
        rcases hx with hxe | hx
        · subst x
          rcases HeapEntry.priorityLE_total u e with hue | heu'
          · exact hue
          · exact False.elim (heu heu')
        · exact hsorted.1 x hxtheorem orderedEntries_pairwise (es : List HeapEntry) :
    (orderedEntries es).Pairwise HeapEntry.PriorityLE := by
  induction es with
  | nil => simp [orderedEntries]
  | cons e es ih => exact pairwise_insertEntry ihtheorem map_stamp_perm_of_perm {as bs : List HeapEntry} (h : as.Perm bs) :
    (as.map HeapEntry.stamp).Perm (bs.map HeapEntry.stamp) := h.map _private theorem eq_of_same_stamp_mem_cons
    {a b : HeapEntry} {as : List HeapEntry}
    (hnodup : (HeapEntry.stamp a :: as.map HeapEntry.stamp).Nodup)
    (hb : b ∈ a :: as) (hstamp : b.stamp = a.stamp) : b = a := by
  simp only [List.mem_cons] at hb
  rcases hb with hba | hb
  · exact hba
  · have hmem : b.stamp ∈ as.map HeapEntry.stamp :=
      List.mem_map.mpr ⟨b, hb, rfl⟩
    have hnot := (List.nodup_cons.mp hnodup).1
    exact False.elim (hnot (hstamp ▸ hmem))

A sorted permutation with distinct stamps is unique.


theorem eq_of_pairwise_priority_of_perm :
    ∀ {as bs : List HeapEntry},
      as.Pairwise HeapEntry.PriorityLE →
      bs.Pairwise HeapEntry.PriorityLE →
      (as.map HeapEntry.stamp).Nodup →
      as.Perm bs → as = bs
  | [], bs, _, _, _, hperm => by
      cases bs with
      | nil => rfl
      | cons b bs => simpa using hperm.length_eq
  | a :: as, [], _, _, _, hperm => by simpa using hperm.length_eq
  | a :: as, b :: bs, has, hbs, hnodup, hperm => by
      rw [List.pairwise_cons] at has hbs
      have hbIn : b ∈ a :: as :=
        (List.Perm.mem_iff hperm).mpr (by simp)
      have haIn : a ∈ b :: bs :=
        (List.Perm.mem_iff hperm).mp (by simp)
      have hab : HeapEntry.PriorityLE a b := by
        simp only [List.mem_cons] at hbIn
        rcases hbIn with hba | hbTail
        · subst b
          exact HeapEntry.priorityLE_refl _
        · exact has.1 b hbTail
      have hba : HeapEntry.PriorityLE b a := by
        simp only [List.mem_cons] at haIn
        rcases haIn with hab | haTail
        · subst a
          exact HeapEntry.priorityLE_refl _
        · exact hbs.1 a haTail
      have hcomponents := HeapEntry.priorityLE_antisymm_components hab hba
      have habEq : b = a :=
        eq_of_same_stamp_mem_cons hnodup hbIn hcomponents.2.symm
      subst b
      have htailPerm : as.Perm bs := hperm.cons_inv
      have htailNodup : (as.map HeapEntry.stamp).Nodup :=
        (List.nodup_cons.mp hnodup).2
      rw [eq_of_pairwise_priority_of_perm has.2 hbs.2 htailNodup htailPerm]

Priority sorting is invariant under permutations with distinct stamps.

theorem orderedEntries_eq_of_perm {as bs : List HeapEntry}
    (hnodup : (as.map HeapEntry.stamp).Nodup) (hperm : as.Perm bs) :
    orderedEntries as = orderedEntries bs := by
  apply eq_of_pairwise_priority_of_perm
    (orderedEntries_pairwise as) (orderedEntries_pairwise bs)
  · exact (map_stamp_perm_of_perm (orderedEntries_perm as)).nodup_iff.mpr hnodup
  · exact (orderedEntries_perm as).trans (hperm.trans (orderedEntries_perm bs).symm)

theorem orderedEntries_stamps_nodup {es : List HeapEntry}
    (h : (es.map HeapEntry.stamp).Nodup) :
    ((orderedEntries es).map HeapEntry.stamp).Nodup :=
  (map_stamp_perm_of_perm (orderedEntries_perm es)).nodup_iff.mpr h

Heap operation observations

              def MinHeap.orderedView {params : HeapParams} (h : MinHeap params) :
    List HeapEntry := orderedEntries h.datatheorem MinHeap.orderedView_insert {params : HeapParams} (h : MinHeap params)
    (e : HeapEntry) (he : params.Bounded e)
    (hnodup : ((e :: h.data).map HeapEntry.stamp).Nodup) :
    (h.insert e he).orderedView = insertEntry e h.orderedView := by
  change orderedEntries (h.insert e he).data =
    orderedEntries (e :: h.data)
  exact orderedEntries_eq_of_perm
    ((map_stamp_perm_of_perm (MinHeap.insert_perm h e he)).nodup_iff.mpr hnodup)
    (MinHeap.insert_perm h e he)

theorem MinHeap.orderedView_extractMin {params : HeapParams}
    {h h' : MinHeap params} {e : HeapEntry}
    (hnodup : (h.data.map HeapEntry.stamp).Nodup)
    (hextract : h.extractMin = some (e, h')) :
    h.orderedView = e :: h'.orderedView := by
  have hspec := MinHeap.extractMin_spec hextract
  apply eq_of_pairwise_priority_of_perm
    (orderedEntries_pairwise h.data) ?_ ?_ ?_
  · rw [List.pairwise_cons]
    refine ⟨?_, orderedEntries_pairwise h'.data⟩
    intro u hu
    have hu' : u ∈ h'.data := (mem_orderedEntries u h'.data).mp hu
    have huOld : u ∈ h.data :=
      (List.Perm.mem_iff hspec.1).mp (List.mem_cons_of_mem e hu')
    exact hspec.2.2 u huOld
  · exact (map_stamp_perm_of_perm (orderedEntries_perm h.data)).nodup_iff.mpr hnodup
  · exact (orderedEntries_perm h.data).trans
      (hspec.1.symm.trans (List.Perm.cons e (orderedEntries_perm h'.data).symm))

Erasing stable entries to the existing sorted forest

              

theorem map_tree_insertEntry_of_stamp_lt (e : HeapEntry) (es : List HeapEntry)
    (hstamps : ∀ u ∈ es, e.stamp < u.stamp) :
    (insertEntry e es).map HeapEntry.tree =
      insortTree e.tree (es.map HeapEntry.tree) := by
  induction es with
  | nil => rfl
  | cons u us ih =>
      simp only [insertEntry, insortTree, List.map_cons]
      have hstamp := hstamps u (by simp)
      by_cases hfreq : rootFreq e.tree ≤ rootFreq u.tree
      · have hpriority : HeapEntry.PriorityLE e u := by
          rcases Nat.lt_or_eq_of_le hfreq with hlt | heq
          · exact Or.inl hlt
          · exact Or.inr ⟨heq, Nat.le_of_lt hstamp⟩
        simp [hpriority, hfreq]
      · have hpriority : ¬ HeapEntry.PriorityLE e u := by
          intro h
          rcases h with hlt | ⟨heq, _⟩
          · exact hfreq (Nat.le_of_lt hlt)
          · exact hfreq (Nat.le_of_eq heq)
        simp [hpriority, hfreq, ih (fun v hv => hstamps v (by simp [hv]))]

theorem orderedEntries_decorateFrom_trees (base : Nat) (ts : List HuffTree) :
    (orderedEntries (decorateFrom base ts)).map HeapEntry.tree = sortForest ts := by
  induction ts generalizing base with
  | nil => rfl
  | cons t ts ih =>
      simp only [decorateFrom, orderedEntries, sortForest]
      rw [map_tree_insertEntry_of_stamp_lt, ih]
      intro u hu
      have hu' : u ∈ decorateFrom (base + 1) ts :=
        (mem_orderedEntries u (decorateFrom (base + 1) ts)).mp hu
      have hge := decorateFrom_stamp_ge hu'
      change base < u.stamp
      omegatheorem orderedEntries_initial_trees (ts : List HuffTree) :
    (orderedEntries (initialEntries ts)).map HeapEntry.tree = sortForest ts := by
  exact orderedEntries_decorateFrom_trees ts.length tsend CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.HeapExecution

Verified binary-heap Huffman interface

This facade exposes the textbook implementation result in one place: a stable list-backed binary min-heap, exact refinement to the existing Huffman semantics, frequency preservation and optimality, and an execution-attached O(n log n) heap-controller bound.

namespace CLRS.HuffmanV2

The costed heap program erases exactly to the established Huffman function.


theorem heapHuffmanOfFreqsWithCost_eq (xs : List (Nat × Nat)) :
    (heapHuffmanOfFreqsWithCost xs).value = huffmanOfFreqs xs := by
  rw [heapHuffmanOfFreqsWithCost_value, heapHuffmanOfFreqs_eq]

Bundled public contract for the genuine binary-heap Huffman implementation. The first three conclusions concern the returned tree; the final conclusion is the explicit controller-work bound for that same execution.


theorem heapHuffmanOfFreqs_correct (xs : List (Nat × Nat))
    (h_nodup : (xs.map Prod.fst).Nodup)
    (h_pos : ∀ p ∈ xs, p.2 > 0)
    (h_nonempty : xs ≠ []) :
    (heapHuffmanOfFreqsWithCost xs).value = huffmanOfFreqs xs ∧
      (∀ symbol,
        freqOf symbol (heapHuffmanOfFreqsWithCost xs).value =
          tableFreq xs symbol) ∧
      optimum (heapHuffmanOfFreqsWithCost xs).value ∧
      (heapHuffmanOfFreqsWithCost xs).work ≤
        xs.length * (4 * (Nat.log 2 (xs.length + 1) + 1)) := by
  have hvalue := heapHuffmanOfFreqsWithCost_value xs
  have hsem := heapHuffmanOfFreqs_semantic_correct xs h_nodup h_pos h_nonempty
  refine ⟨heapHuffmanOfFreqsWithCost_eq xs, ?_, ?_,
    heapHuffmanOfFreqs_work_le_nlogn xs⟩
  · intro symbol
    rw [hvalue]
    exact hsem.1 symbol
  · rw [hvalue]
    exact hsem.2

end CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.TextbookCost

Huffman textbook cost

CLRS equation (15.4) defines the cost of a prefix-code tree as the sum of each character's frequency times its depth. The core development uses the equivalent internal-node-frequency recurrence. This module proves the bridge.

open scoped BigOperatorsnamespace CLRS.HuffmanV2

CLRS equation (15.4): B(T) = ∑ c.freq * d_T(c).

def textbookCost (t : HuffTree) : Nat :=
  ∑ s ∈ alphabet t, freqOf s t * (depthOf s t).getD 0



theorem rootFreq_eq_sum_freqOf (t : HuffTree) (hcons : consistent t) :
    rootFreq t = ∑ s ∈ alphabet t, freqOf s t := by
  induction t with
  | htLeaf s f => simp [rootFreq, alphabet, freqOf]
  | htInner l r ihl ihr =>
      rcases hcons with ⟨hcl, hcr, hdisj⟩
      have hleft :
          (∑ s ∈ alphabet l, freqOf s (HuffTree.htInner l r)) =
            ∑ s ∈ alphabet l, freqOf s l := by
        apply Finset.sum_congr rfl
        intro s hs
        have hnot : s ∉ alphabet r := Finset.disjoint_left.mp hdisj hs
        simp [freqOf, freqOf_eq_zero_of_not_mem s r hnot]
      have hright :
          (∑ s ∈ alphabet r, freqOf s (HuffTree.htInner l r)) =
            ∑ s ∈ alphabet r, freqOf s r := by
        apply Finset.sum_congr rfl
        intro s hs
        have hnot : s ∉ alphabet l := Finset.disjoint_right.mp hdisj hs
        simp [freqOf, freqOf_eq_zero_of_not_mem s l hnot]
      rw [rootFreq, alphabet, Finset.sum_union hdisj, hleft, hright,
        ← ihl hcl, ← ihr hcr]



private theorem textbookCost_inner
    (l r : HuffTree) (hcl : consistent l) (hcr : consistent r)
    (hdisj : Disjoint (alphabet l) (alphabet r)) :
    textbookCost (HuffTree.htInner l r) =
      textbookCost l + textbookCost r + rootFreq l + rootFreq r := by
  have hleft :
      (∑ s ∈ alphabet l,
          freqOf s (HuffTree.htInner l r) *
            (depthOf s (HuffTree.htInner l r)).getD 0) =
        textbookCost l + rootFreq l := by
    calc
      _ = ∑ s ∈ alphabet l,
          (freqOf s l * (depthOf s l).getD 0 + freqOf s l) := by
            apply Finset.sum_congr rfl
            intro s hs
            have hnot : s ∉ alphabet r := Finset.disjoint_left.mp hdisj hs
            rw [depthOf_getD_inner_of_mem_left hs]
            simp [freqOf, freqOf_eq_zero_of_not_mem s r hnot,
              Nat.mul_add]
      _ = (∑ s ∈ alphabet l, freqOf s l * (depthOf s l).getD 0) +
          ∑ s ∈ alphabet l, freqOf s l := Finset.sum_add_distrib
      _ = textbookCost l + rootFreq l := by
          rw [rootFreq_eq_sum_freqOf l hcl]
          rfl
  have hright :
      (∑ s ∈ alphabet r,
          freqOf s (HuffTree.htInner l r) *
            (depthOf s (HuffTree.htInner l r)).getD 0) =
        textbookCost r + rootFreq r := by
    calc
      _ = ∑ s ∈ alphabet r,
          (freqOf s r * (depthOf s r).getD 0 + freqOf s r) := by
            apply Finset.sum_congr rfl
            intro s hs
            have hnot : s ∉ alphabet l := Finset.disjoint_right.mp hdisj hs
            rw [depthOf_getD_inner_of_mem_right hs hnot]
            simp [freqOf, freqOf_eq_zero_of_not_mem s l hnot,
              Nat.mul_add]
      _ = (∑ s ∈ alphabet r, freqOf s r * (depthOf s r).getD 0) +
          ∑ s ∈ alphabet r, freqOf s r := Finset.sum_add_distrib
      _ = textbookCost r + rootFreq r := by
          rw [rootFreq_eq_sum_freqOf r hcr]
          rfl
  rw [textbookCost, alphabet, Finset.sum_union hdisj, hleft, hright]
  omega

The internal-node recurrence used by the executable development is exactly CLRS equation (15.4) on every consistent prefix-code tree.


theorem textbookCost_eq_cost (t : HuffTree) (hcons : consistent t) :
    textbookCost t = cost t := by
  induction t with
  | htLeaf s f => simp [textbookCost, alphabet, freqOf, depthOf, cost]
  | htInner l r ihl ihr =>
      rcases hcons with ⟨hcl, hcr, hdisj⟩
      rw [textbookCost_inner l r hcl hcr hdisj, cost, ihl hcl, ihr hcr]

The public Huffman optimum theorem can be read directly with equation (15.4).


theorem huffmanOfFreqs_textbookCost_le (xs : List (Nat × Nat))
    (h_nodup : (xs.map Prod.fst).Nodup)
    (h_pos : ∀ p ∈ xs, p.2 > 0)
    (h_nonempty : xs ≠ [])
    (u : HuffTree) (h_cons_u : consistent u)
    (h_same : sameFreqs (huffmanOfFreqs xs) u) :
    textbookCost (huffmanOfFreqs xs) ≤ textbookCost u := by
  have hopt := optimum_huffman_freqs xs h_nodup h_pos h_nonempty
  rw [textbookCost_eq_cost _ hopt.1, textbookCost_eq_cost _ h_cons_u]
  exact hopt.2.2 u h_cons_u h_same

end CLRS.HuffmanV2

CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.TextbookLemmas

Textbook interfaces for Huffman Lemmas 15.2 and 15.3

The core exchange proof is intentionally packaged behind SplitLeafOptimalitySpec. These short corollaries expose the two textbook ideas under stable, searchable names.

namespace CLRS.HuffmanV2



theorem areSiblings_splitLeaf (t : HuffTree) (z b fa fb : Nat)
    (hz : z ∈ alphabet t) :
    areSiblings z b (splitLeaf t z z b fa fb) := by
  induction t with
  | htLeaf s f =>
      simp [alphabet] at hz
      subst s
      simp [splitLeaf]
      exact areSiblings.here fa fb
  | htInner l r ihl ihr =>
      rw [alphabet, Finset.mem_union] at hz
      rcases hz with hz | hz
      · exact areSiblings.inLeft _ _ (ihl hz)
      · exact areSiblings.inRight _ _ (ihr hz)

CLRS Lemma 15.2 (greedy-choice property): the two minimum-frequency symbols occur as sibling leaves in an optimal expanded tree.

theorem lemma15_2_greedy_choice {t : HuffTree} {z b fa fb : Nat}
    (S : SplitLeafOptimalitySpec t z b fa fb) (hopt : optimum t) :
    ∃ u, optimum u ∧ areSiblings z b u := by
  refine ⟨splitLeaf t z z b fa fb,
    split_leaf_preserves_optimum S hopt, ?_⟩
  exact areSiblings_splitLeaf t z b fa fb S.z_mem

CLRS Lemma 15.3 (optimal substructure): expanding an optimal code for the merged alphabet at its merged leaf yields an optimal code for the original alphabet.

theorem lemma15_3_optimal_substructure {t : HuffTree} {z b fa fb : Nat}
    (S : SplitLeafOptimalitySpec t z b fa fb) (hopt : optimum t) :
    optimum (splitLeaf t z z b fa fb) :=
  split_leaf_preserves_optimum S hopt

end CLRS.HuffmanV2

Imports

import Mathlib
import CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.S1_Cache_Model
import CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.S2_Farthest_In_Future
import CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.S3_Optimality
import CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.EmptyStart

15.4. Offline caching

This section formalizes the offline caching problem of CLRS §15.4 and the farthest-in-future (Belady) eviction policy: the cache model with policies, hits and misses, the next-use function, the farthest-in-future selection, and the finite-trace exchange proof that the policy is optimal.

Main results:

Policy / Policy.step / misses: the caching model (CLRS §15.4)
nextUse: the next request position of a page at or after a position
Farther: the "at least as far in the future" order
farthestInFuture cache σ i: the resident page whose next use is farthest
fifoPolicy σ: the farthest-in-future eviction policy
fifo_step_of_mem / fifo_step_fault: the policy's cache transitions
LegalTrace: a policy-independent certificate for a legal cache execution
fifo_optimal: optimality for every nonempty eviction-phase cache
fifo_optimal_from_empty: optimality from the literal empty cache in the capacity-one core execution, including the compulsory first miss
fifo_optimal_after_compulsory_fill: the capacity-independent bridge from a common compulsory-fill phase to the verified eviction phase

Completion boundary:

The mathematical offline-caching optimality theorem is complete for finite request lists. Both a nonempty eviction-phase cache and the literal empty start of the core transition semantics are covered. The latter has capacity one after the first load. For larger capacities, compulsoryFillCost only adds a supplied common cost to a supplied nonempty resident set and remaining suffix; no general capacity-parametric empty-start fill execution is proved here. Pointer-level cache mutation, RAM costs, and hardware caching behavior are separate implementation refinements and are not claimed here.

Notation conventions used in this section:

C : cache (a Finset Page of resident pages)
σ : request sequence
i : position of the fault
π : eviction policy

Implementation details

The section is split into the following sub-modules:

Definitions and proofs

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.S1_Cache_Model

S1. Cache model

The eviction-cache model for the offline caching problem of CLRS §15.4 ("Offline caching"): a request sequence is a list of pages, the cache is a finite set of resident pages, and an eviction policy is a total function that decides, at each fault, which resident page to evict. Misses and hits are counted position by position over the request list, and nextUse locates the next request of a given page at or after a given position.

Main results:

Policy: an eviction policy (a total eviction function, validity bundled)
Policy.step: the cache transition induced by a policy on a request
cacheSeq: the cache after each prefix of the request list
faultAt / misses / hits: per-request miss indicator and the total miss and hit counts over the request list
misses_add_hits: every request is a hit or a miss
step_card / cacheSeq_card: policies preserve the cache size, so a cache of size k stays of size k throughout the run
nextUse: the offset of the first request of a page at or after a given position, none when the page is never requested again

Notation conventions used in this section:

C : cache (a finite set of resident pages)
σ : request sequence
p, q : pages
i, t : positions in the request sequence

              namespace CLRSopen Finsetopen scoped BigOperatorsnamespace Caching

Pages are natural numbers; any countably infinite page universe is equivalent.

abbrev Page := ℕ

A cache of size k holds exactly k pages (CLRS §15.4).

def CacheSize (k : ℕ) (C : Finset Page) : Prop :=
  C.card = k

An eviction policy is a total function that, at each request position i, given the current cache C and the requested page p, returns the page to evict when p is not resident. The bundled evict_mem field records that a fault evicts a resident page; on a hit the eviction value is junk. Policies are offline: they may use the position i (and hence the full request sequence) when making the decision (CLRS §15.4).

structure Policy where
  evict : ℕ → Finset Page → Page → Page
  evict_mem : ∀ i C p, p ∉ C → C.Nonempty → evict i C p ∈ C

The cache transition of a policy: a hit keeps the cache unchanged, a fault evicts the policy's chosen page and loads the requested page.

def Policy.step (π : Policy) (i : ℕ) (C : Finset Page) (p : Page) : Finset Page :=
  if p ∈ C then C else insert p (C.erase (π.evict i C p))

The cache after the first t requests (requests beyond the end of the list are junk, so the sequence extends arbitrarily).

def cacheSeq (π : Policy) (C₀ : Finset Page) (σ : List Page) : ℕ → Finset Page
  | 0 => C₀
  | t + 1 => π.step t (cacheSeq π C₀ σ t) (σ.getD t 0)

The transition preserves the number of resident pages.


lemma step_card (π : Policy) (i : ℕ) (C : Finset Page) (p : Page) (hC : C.Nonempty) :
    (π.step i C p).card = C.card := by
  unfold Policy.step
  by_cases hp : p ∈ C
  · rw [if_pos hp]
  · rw [if_neg hp]
    have he := π.evict_mem i C p hp hC
    rw [Finset.card_insert_of_notMem (by
      intro hmem
      exact hp (Finset.mem_erase.mp hmem).2)]
    rw [Finset.card_erase_of_mem he]
    have hcard : 0 < C.card := Finset.card_pos.mpr ⟨π.evict i C p, he⟩
    omega

Every cache in the run of a policy has the same size as the initial cache, so a cache of size k stays of size k throughout (CLRS §15.4).


lemma cacheSeq_card (π : Policy) (C₀ : Finset Page) (σ : List Page) (t : ℕ)
    (hC₀ : C₀.Nonempty) :
    (cacheSeq π C₀ σ t).card = C₀.card := by
  induction t with
  | zero => rfl
  | succ t ih =>
      unfold cacheSeq
      rw [step_card]
      · exact ih
      · have hcard : 0 < (cacheSeq π C₀ σ t).card := by
          rw [ih]
          exact Finset.card_pos.mpr hC₀
        exact Finset.card_pos.mp hcard

Caches in a run starting from a nonempty cache are nonempty.


lemma cacheSeq_nonempty (π : Policy) (C₀ : Finset Page) (σ : List Page) (t : ℕ)
    (hC₀ : C₀.Nonempty) :
    (cacheSeq π C₀ σ t).Nonempty := by
  have hcard : 0 < (cacheSeq π C₀ σ t).card := by
    rw [cacheSeq_card π C₀ σ t hC₀]
    exact Finset.card_pos.mpr hC₀
  exact Finset.card_pos.mp hcard

Whether the request at position t is a miss for the run of π from C₀ on σ (0 or 1).

def faultAt (π : Policy) (C₀ : Finset Page) (σ : List Page) (t : ℕ) : ℕ :=
  if σ.getD t 0 ∈ cacheSeq π C₀ σ t then 0 else 1

The number of misses (faults) incurred by policy π on the request list σ starting from the initial cache C₀ (CLRS §15.4).

def misses (π : Policy) (C₀ : Finset Page) (σ : List Page) : ℕ :=
  ∑ t ∈ Finset.range σ.length, faultAt π C₀ σ t

The number of hits (requests served from the cache) incurred by policy π on the request list σ starting from the initial cache C₀.

def hits (π : Policy) (C₀ : Finset Page) (σ : List Page) : ℕ :=
  ∑ t ∈ Finset.range σ.length, if σ.getD t 0 ∈ cacheSeq π C₀ σ t then 1 else 0

A sum over a shifted range splits into its first term and the shifted tail.


lemma sum_range_shift {n : ℕ} (f : ℕ → ℕ) :
    (∑ t ∈ Finset.range (n + 1), f t) = f 0 + ∑ t ∈ Finset.range n, f (t + 1) := by
  induction n with
  | zero => simp
  | succ n ih =>
      rw [Finset.sum_range_succ, ih]
      rw [Finset.sum_range_succ]
      omega

Every request is either a hit or a miss, so the two counts add up to the length of the request list.


lemma misses_add_hits (π : Policy) (C₀ : Finset Page) (σ : List Page) :
    misses π C₀ σ + hits π C₀ σ = σ.length := by
  unfold misses hits
  rw [← Finset.sum_add_distrib]
  have hterm : ∀ t ∈ Finset.range σ.length,
      faultAt π C₀ σ t + (if σ.getD t 0 ∈ cacheSeq π C₀ σ t then 1 else 0) = 1 := by
    intro t _
    unfold faultAt
    split <;> omega
  rw [Finset.sum_congr rfl hterm]
  simp

The offset of the first request of p at or after position i in σ: nextUse σ i p = some j means the request at absolute position i + j is the first request of p at or after i; none means p is never requested again (CLRS §15.4).

def nextUse (σ : List Page) (i : ℕ) (p : Page) : Option ℕ :=
  (σ.drop i).findIdx? (fun q => q = p)

nextUse σ i p = some j exactly when the request at relative position j of the suffix σ.drop i is p and no earlier request of the suffix is p.


lemma nextUse_eq_some_iff {σ : List Page} {i p j : ℕ} :
    nextUse σ i p = some j ↔
      ∃ h : j < (σ.drop i).length, (σ.drop i)[j] = p ∧
        ∀ k (hk : k < j), (σ.drop i)[k] ≠ p := by
  unfold nextUse
  rw [List.findIdx?_eq_some_iff_getElem (p := fun q => q = p) (xs := σ.drop i)]
  simp

nextUse σ i p = none exactly when no request at or after position i is p.


lemma nextUse_eq_none_iff {σ : List Page} {i p : ℕ} :
    nextUse σ i p = none ↔ ∀ q, q ∈ σ.drop i → q ≠ p := by
  unfold nextUse
  rw [List.findIdx?_eq_none_iff]
  simp

The element of a drop at a relative position is the element of the original list at the shifted absolute position.


lemma getD_drop (l : List Page) (d : Page) (i j : ℕ) :
    (l.drop i).getD j d = l.getD (i + j) d := by
  rw [List.getD_eq_getElem?_getD, List.getD_eq_getElem?_getD]
  simp

If nextUse σ i p = some j, then the request at absolute position i + j is p, and no request strictly between i and i + j is p.


lemma getD_nextUse {σ : List Page} {i p j : ℕ} (h : nextUse σ i p = some j) :
    σ.getD (i + j) 0 = p ∧ ∀ k, i ≤ k → k < i + j → σ.getD k 0 ≠ p := by
  rcases (nextUse_eq_some_iff.mp h) with ⟨hlt, hget, hmin⟩
  constructor
  · rw [← getD_drop σ 0 i j]
    rw [List.getD_eq_getElem _ 0 hlt]
    exact hget
  · intro k hik hkj
    have hki : k - i < j := by omega
    have hne := hmin (k - i) hki
    have hget' : (σ.drop i).getD (k - i) 0 = σ.getD k 0 := by
      have hsub : (σ.drop i).getD (k - i) 0 = σ.getD (i + (k - i)) 0 := by
        rw [getD_drop σ 0 i (k - i)]
      rw [hsub]
      rw [Nat.add_sub_of_le hik]
    rw [← hget']
    rw [List.getD_eq_getElem _ 0 (Nat.lt_trans hki hlt)]
    exact hne

If nextUse σ i p = some j, then the request at absolute position i + j is p.

lemma getD_eq_nextUse {σ : List Page} {i p j : ℕ} (h : nextUse σ i p = some j) :
    σ.getD (i + j) 0 = p :=
  (getD_nextUse h).1

If nextUse σ i p = some j, then no request strictly between i and i + j is p.

lemma getD_ne_nextUse {σ : List Page} {i p j : ℕ} (h : nextUse σ i p = some j) {k : ℕ}
    (hik : i ≤ k) (hkj : k < i + j) :
    σ.getD k 0 ≠ p :=
  (getD_nextUse h).2 k hik hkj

end Cachingend CLRS

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.S2_Farthest_In_Future

S2. The farthest-in-future eviction

The greedy choice of the offline caching problem (CLRS §15.4): when a fault occurs, evict the resident page whose next use is farthest in the future. Pages never requested again count as farthest (none). Ties are broken arbitrarily (towards the left in the enumeration order of the cache).

Main results:

Farther: the "at least as far in the future" order on next-use options (none = never again is the farthest)
farthestInFuture cache σ i: the resident page whose next use at or after position i is farthest
mem_farthestInFuture: the chosen page is resident
farthestInFuture_max: no resident page has a farther next use
fifoPolicy σ: the farthest-in-future eviction policy for σ
fifo_step_of_mem / fifo_step_fault: the cache transition of the policy

Notation conventions used in this section:

C : cache
σ : request sequence
i : position of the fault

              namespace CLRSopen Finsetnamespace Caching

Farther a b says that the next use a is at least as far in the future as b: none (never requested again) is the farthest, and among some i / some j the one with the larger position is farther (CLRS §15.4).

def Farther (a b : Option ℕ) : Prop :=
  match a, b with
  | none, _ => True
  | some _, none => False
  | some i, some j => j ≤ i

Farther-in-the-future is reflexive.

lemma farther_refl (a : Option ℕ) : Farther a a := by
  cases a <;> simp [Farther]

Farther-in-the-future is transitive.

lemma farther_trans {a b c : Option ℕ} (hab : Farther a b) (hbc : Farther b c) :
    Farther a c := by
  cases a with
  | none => simp [Farther]
  | some i =>
      cases b with
      | none =>
          simp [Farther] at hab
      | some j =>
          cases c with
          | none =>
              simp [Farther] at hbc
          | some k =>
              simp [Farther] at hab hbc ⊢
              omega

Farther-in-the-future is total.

lemma farther_total {a b : Option ℕ} (h : ¬ Farther a b) : Farther b a := by
  cases a with
  | none =>
      simp [Farther] at h
  | some i =>
      cases b with
      | none => simp [Farther]
      | some j =>
          simp [Farther] at h ⊢
          omega

If a is at least as far as b, then either a is none, or both are some with b's position no later than a's.

lemma farther_cases {a b : Option ℕ} (h : Farther a b) :
    a = none ∨ ∃ i j, a = some i ∧ b = some j ∧ j ≤ i := by
  cases a with
  | none => exact Or.inl rfl
  | some i =>
      cases b with
      | none =>
          simp [Farther] at h
      | some j => exact Or.inr ⟨i, j, rfl, rfl, by simpa [Farther] using h⟩

none is at least as far as any next use.

lemma farther_none (a : Option ℕ) : Farther none a := by
  cases a <;> simp [Farther]

The farther-in-the-future relation is decidable.

instance instDecidableFarther (a b : Option ℕ) : Decidable (Farther a b) := by
  unfold Farther
  cases a <;> cases b <;> infer_instance

A concrete next use is never as far as none.

lemma not_farther_of_some_none {i : ℕ} : ¬ Farther (some i) none := by
  simp [Farther]

The page in l whose next use under f is farthest in the future, ties broken towards the left; junk value 0 on the empty list.

def farthestInList (f : Page → Option ℕ) : List Page → Page
  | [] => 0
  | p :: rest =>
      if rest = [] then p
      else
        let q := farthestInList f rest
        if Farther (f p) (f q) then p else q

The page chosen by farthestInList is at least as far in the future as every page of the list.


lemma farthestInList_spec (f : Page → Option ℕ) (l : List Page) :
    ∀ r ∈ l, Farther (f (farthestInList f l)) (f r) := by
  induction l with
  | nil => simp [farthestInList]
  | cons p rest ih =>
      by_cases hrest : rest = []
      · rw [hrest]
        intro r hr
        simp [farthestInList] at hr ⊢
        rw [← hr]
        exact farther_refl (f r)
      · by_cases hpq : Farther (f p) (f (farthestInList f rest))
        · intro r hr
          simp [farthestInList, hrest, hpq] at hr ⊢
          rcases hr with hr | hr
          · subst hr
            exact farther_refl (f r)
          · exact farther_trans hpq (ih r hr)
        · intro r hr
          simp [farthestInList, hrest, hpq] at hr ⊢
          rcases hr with rfl | hr
          · exact farther_total hpq
          · exact ih r hr

On a nonempty list, farthestInList returns a page of the list.

lemma mem_farthestInList {f : Page → Option ℕ} {l : List Page} (hl : l ≠ []) :
    farthestInList f l ∈ l := by
  induction l with
  | nil => simp at hl
  | cons p rest ih =>
      by_cases hrest : rest = []
      · subst rest
        simp [farthestInList]
      · by_cases hpq : Farther (f p) (f (farthestInList f rest))
        · simp [farthestInList, hrest, hpq]
        · simpa [farthestInList, hrest, hpq, List.mem_cons] using (Or.inr (ih hrest))

The resident page of cache whose next use at or after position i is farthest in the future (pages never requested again count as farthest; ties are broken arbitrarily). Junk value 0 on the empty cache (CLRS §15.4).

noncomputable def farthestInFuture (cache : Finset Page) (σ : List Page) (i : ℕ) : Page :=
  farthestInList (fun p => nextUse σ (i + 1) p) cache.toList

On a nonempty cache, farthestInFuture returns a resident page.


lemma mem_farthestInFuture {cache : Finset Page} {σ : List Page} {i : ℕ}
    (h : cache.Nonempty) :
    farthestInFuture cache σ i ∈ cache := by
  unfold farthestInFuture
  have hmem : farthestInList (fun p => nextUse σ (i + 1) p) cache.toList ∈ cache.toList := by
    apply mem_farthestInList
    rcases h with ⟨p, hp⟩
    have hp' : p ∈ cache.toList := by simpa [Finset.mem_toList] using hp
    exact List.ne_nil_of_mem hp'
  simpa [Finset.mem_toList] using hmem

No resident page has a next use at or after position i that is farther than that of farthestInFuture cache σ i.

lemma farthestInFuture_max {cache : Finset Page} {σ : List Page} {i : ℕ} {p : Page}
    (hp : p ∈ cache) :
    Farther (nextUse σ (i + 1) (farthestInFuture cache σ i)) (nextUse σ (i + 1) p) := by
  unfold farthestInFuture
  apply farthestInList_spec
  simpa [Finset.mem_toList] using hp

The farthest-in-future eviction policy for the request list σ (the Belady algorithm, CLRS §15.4): at a fault, evict the resident page whose next use is farthest in the future.

noncomputable def fifoPolicy (σ : List Page) : Policy where
  evict := fun i C p => farthestInFuture C σ i
  evict_mem := by
    intro i C p hp hC
    exact mem_farthestInFuture hC

The farthest-in-future policy keeps the cache unchanged on a hit.

lemma fifo_step_of_mem (σ : List Page) (i : ℕ) (C : Finset Page) (p : Page) (hp : p ∈ C) :
    (fifoPolicy σ).step i C p = C := by
  simp [Policy.step, hp]

On a fault, the farthest-in-future policy evicts the farthest-in-future page and loads the requested page.

lemma fifo_step_fault (σ : List Page) (i : ℕ) (C : Finset Page) (p : Page) (hp : p ∉ C) :
    (fifoPolicy σ).step i C p = insert p (C.erase (farthestInFuture C σ i)) := by
  simp [Policy.step, fifoPolicy, hp]

end Cachingend CLRS

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.S3_Optimality

S3. Optimality of the farthest-in-future policy

The exchange-schedule machinery for the optimality proof of the farthest-in-future (Belady) eviction policy of CLRS §15.4, plus basic sanity lemmas for the policy itself: it always evicts a resident page and preserves the cache size. The unconditional theorem is closed through a separate policy-independent legal-trace argument: one-page cache differences are coupled across the suffix, the first disagreement is exchanged without adding misses, and finite iteration yields a trace that agrees with FIF everywhere.

Main results:

fifo_optimal: no offline eviction policy incurs fewer misses than FIF
LegalTrace / policyTrace: policy-independent legal cache executions and the trace induced by any policy
exchange_trace: one local exchange extends agreement with FIF by one cache boundary without increasing total misses
exists_fully_agreeing_trace / fifo_optimal_trace: finite iteration of the exchange and its trace-level optimality consequence
fifo_evicts_resident: the FIF policy evicts a resident page
fifo_step_size: a FIF step preserves the cache size
schedCache / schedMisses: the run and miss count of an arbitrary eviction schedule; a policy's schedule incurs exactly the policy's misses
exchangeSchedule_invariant: from the first disagreement t onwards, the exchange schedule's cache contains every page of d's cache except possibly q and q', so a fault where d hits can only be a request of q or q'
exchangeDecision_of_hit / exchangeDecision_of_fault: the exchange eviction at a hit is q, q', or a page d's cache lacks; at a fault it is additionally d s
exchangeSchedule_misses_le: one exchange step never increases the miss count — the good event at the first request of q compensates the unique bad event at the first request of q' (or q' is never requested again). The chain of supporting lemmas is proved under a weakened reducedness hypothesis hweak : ∀ s, t ≤ s → fault of dats→d s resident, so the counting lemma applies to schedules that are reduced only from the exchange position on (the iteration's exchange schedules are reduced at every fault after the first q' request, by exchangeSchedule_reduced_after)
exchangeSchedule_q_mem / exchangeSchedule_q'_mem: from the first q (resp. q') request on, a page resident in d's cache is also resident in the exchange cache, so bad events are confined to the first q' request
fifoSchedule: the eviction schedule of the farthest-in-future policy
first_disagree: at a first disagreement of a reduced schedule, both schedules fault, the evictions differ, and the policy's eviction is resident
exchange_step: exchanging the first disagreement of a reduced schedule never increases misses and extends agreement with fifoSchedule by one position
exchangeSchedule_reduced_after: the exchange schedule is reduced at every fault after the first q' request, so the reducedness state needed by the iteration is preserved from one exchange to the next
exchangeSchedule_misses_le_plus_one: when the bad event did not occur (q' never requested again and q is, or d evicts q' before its first request), the exchange saves a spare miss — the compensating slack for the repair step
repairSchedule / repair_step: replacing a no-op eviction at the first disagreement by the policy's choice (q', evicted again at its first request so the caches coincide afterwards) costs at most one extra miss and extends agreement by one position, with the window up to J' relation repairSchedule_window and the post-J' containment repairSchedule_superset

Current gaps:

None for optimality in the mathematical cache model. Low-level RAM/cache implementation refinement is outside this section's current model.

              namespace CLRSnamespace Cachingopen Finset

The farthest-in-future policy always evicts a resident page.

lemma fifo_evicts_resident (σ : List Page) (i : ℕ) (C : Finset Page) (p : Page)
    (hp : p ∉ C) (hC : C.Nonempty) :
    (fifoPolicy σ).evict i C p ∈ C :=
  (fifoPolicy σ).evict_mem i C p hp hC

A step of the farthest-in-future policy preserves the cache size.

lemma fifo_step_size (σ : List Page) (i : ℕ) (C : Finset Page) (p : Page)
    (hC : C.Nonempty) :
    ((fifoPolicy σ).step i C p).card = C.card :=
  step_card (fifoPolicy σ) i C p hC

A schedule for the request list σ is a decision function d : ℕ → Page giving, for every position s, the page to evict at that position. The schedule's run schedCache d C₀ σ starts from C₀: a hit keeps the cache, a fault evicts d s (an eviction of an absent page is a no-op, so schedules need not be reduced) and loads the requested page.

def schedCache (d : ℕ → Page) (C₀ : Finset Page) (σ : List Page) : ℕ → Finset Page
  | 0 => C₀
  | s + 1 => if σ.getD s 0 ∈ schedCache d C₀ σ s then schedCache d C₀ σ s
             else insert (σ.getD s 0) ((schedCache d C₀ σ s).erase (d s))

Whether position s is a miss for the schedule d from C₀ on σ (0 or 1).

def schedFaultAt (d : ℕ → Page) (C₀ : Finset Page) (σ : List Page) (s : ℕ) : ℕ :=
  if σ.getD s 0 ∈ schedCache d C₀ σ s then 0 else 1

The number of misses of the schedule d from C₀ on σ.

def schedMisses (d : ℕ → Page) (C₀ : Finset Page) (σ : List Page) : ℕ :=
  ∑ s ∈ Finset.range σ.length, schedFaultAt d C₀ σ s

The schedule induced by a policy: at position s it evicts exactly the page the policy evicts in its own run.

def policySchedule (π : Policy) (C₀ : Finset Page) (σ : List Page) : ℕ → Page :=
  fun s => π.evict s (cacheSeq π C₀ σ s) (σ.getD s 0)

The run of a policy's schedule is the policy's own run.


lemma schedCache_policySchedule (π : Policy) (C₀ : Finset Page) (σ : List Page) (s : ℕ) :
    schedCache (policySchedule π C₀ σ) C₀ σ s = cacheSeq π C₀ σ s := by
  induction s with
  | zero => rfl
  | succ s ih =>
      unfold schedCache
      rw [ih]
      cases s with
      | zero => rfl
      | succ s' =>
          unfold cacheSeq
          rfl

A policy and its schedule incur the same number of misses.


lemma schedMisses_policySchedule (π : Policy) (C₀ : Finset Page) (σ : List Page) :
    schedMisses (policySchedule π C₀ σ) C₀ σ = misses π C₀ σ := by
  unfold schedMisses misses faultAt
  apply Finset.sum_congr rfl
  intro s hs
  unfold schedFaultAt
  rw [schedCache_policySchedule]

The exchange schedule for the first fault where d and the farthest-in-future policy disagree (position t, request p, d evicting q, the policy evicting q'): it agrees with d before t, evicts q' at t, and afterwards follows d except that it never evicts a page that d keeps while the exchange schedule lacks it (when d evicts q' the exchange schedule evicts q' too — a no-op when it already lacks q' — and a multi-set element — a page d does not have — when d hits a request of q or q' that the exchange schedule misses), so that no bad event (a fault where d hits) is created.

The eviction decision at position s, based on the exchange schedule's cache C' (the cache just before the request at s) and d's cache.

noncomputable def exchangeDecision (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ C' : Finset Page) (s : ℕ) : Page :=
  if s < t then d s
  else if s = t then q'
  else if d s = q' then q'
  else if (σ.getD s 0 = q' ∨ σ.getD s 0 = q) ∧ σ.getD s 0 ∈ schedCache d C₀ σ s then
    let M : Finset Page := C' \ schedCache d C₀ σ s
    if h : (M.filter (fun x => x ≠ q')).Nonempty then Classical.choose h
    else if h : M.Nonempty then Classical.choose h
    else 0
  else if d s ∈ C' then d s
  else
    let M : Finset Page := C' \ schedCache d C₀ σ s
    if h : M.Nonempty then Classical.choose h
    else 0

noncomputable def exchangeScheduleCore (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page) : ℕ → Finset Page × Page
  | 0 => (C₀, exchangeDecision d t q q' σ C₀ C₀ 0)
  | s + 1 =>
      let prev := exchangeScheduleCore d t q q' σ C₀ s
      let r : Page := σ.getD s 0
      let Csucc : Finset Page :=
        if r ∈ prev.1 then prev.1 else insert r (prev.1.erase prev.2)
      (Csucc, exchangeDecision d t q q' σ C₀ Csucc (s + 1))

The decision function of the exchange schedule.

noncomputable def exchangeSchedule (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page) : ℕ → Page :=
  fun s => (exchangeScheduleCore d t q q' σ C₀ s).2

The exchange schedule's run is the cache component of the core.


lemma schedCache_exchangeScheduleCore (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page) (s : ℕ) :
    schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s =
      (exchangeScheduleCore d t q q' σ C₀ s).1 := by
  induction s with
  | zero => rfl
  | succ s ih =>
      unfold schedCache
      rw [ih]
      cases s with
      | zero => rfl
      | succ s' =>
          unfold exchangeScheduleCore
          rfl

Strictly before t, the exchange schedule's cache and decision agree with d's.


lemma exchangeScheduleCore_eq_d (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page) {s : ℕ} (hs : s < t) :
    exchangeScheduleCore d t q q' σ C₀ s = (schedCache d C₀ σ s, d s) := by
  induction s with
  | zero =>
      unfold exchangeScheduleCore
      simp [exchangeDecision, hs]
      rfl
  | succ s ih =>
      rw [exchangeScheduleCore]
      rw [ih (lt_trans (Nat.lt_succ_self s) hs)]
      simp [exchangeDecision, hs]
      cases s with
      | zero => rfl
      | succ s' =>
          unfold schedCache
          rfl

The exchange schedule agrees with d strictly before t.


lemma exchangeSchedule_eq_d_of_lt (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page) {s : ℕ} (hs : s < t) :
    exchangeSchedule d t q q' σ C₀ s = d s := by
  unfold exchangeSchedule
  rw [exchangeScheduleCore_eq_d d t q q' σ C₀ hs]

Up to and including position t, the exchange schedule's cache agrees with d's.


lemma schedCache_exchangeSchedule_eq_d (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page) {s : ℕ} (hs : s ≤ t) :
    schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s = schedCache d C₀ σ s := by
  induction s with
  | zero => rfl
  | succ s ih =>
      unfold schedCache
      rw [exchangeSchedule_eq_d_of_lt d t q q' σ C₀ (Nat.lt_of_succ_le hs)]
      rw [ih (by omega)]

The exchange schedule evicts q' at position t.

lemma exchangeSchedule_at_t (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page) :
    exchangeSchedule d t q q' σ C₀ t = q' := by
  unfold exchangeSchedule exchangeScheduleCore
  induction t with
  | zero => simp [exchangeDecision]
  | succ t ih =>
      unfold exchangeScheduleCore
      simp [exchangeDecision]

A reduced schedule's cache size is constant (evictions hit resident pages and faults load a page that was absent).


lemma schedCache_card_const (d : ℕ → Page) (C₀ : Finset Page) (σ : List Page)
    (t : ℕ)
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    {s : ℕ} (hts : t ≤ s) : (schedCache d C₀ σ (s + 1)).card = (schedCache d C₀ σ s).card := by
  rw [schedCache]
  by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
  · rw [if_pos hr]
  · rw [if_neg hr]
    rw [Finset.card_insert_of_notMem]
    · rw [Finset.card_erase_of_mem (hweak s hts hr)]
      have hc : 0 < (schedCache d C₀ σ s).card :=
        Finset.card_pos.mpr ⟨d s, hweak s hts hr⟩
      omega
    · intro hm
      exact hr (Finset.mem_erase.mp hm).2

One step never shrinks the exchange schedule's cache.


lemma exchangeScheduleCore_card_step (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page) (s : ℕ) :
    (exchangeScheduleCore d t q q' σ C₀ (s + 1)).1.card ≥
      (exchangeScheduleCore d t q q' σ C₀ s).1.card := by
  rw [exchangeScheduleCore]
  by_cases hr : σ.getD s 0 ∈ (exchangeScheduleCore d t q q' σ C₀ s).1
  · rw [if_pos hr]
  · rw [if_neg hr]
    rw [Finset.card_insert_of_notMem]
    · have hle : ((exchangeScheduleCore d t q q' σ C₀ s).1.erase
          (exchangeScheduleCore d t q q' σ C₀ s).2).card + 1 ≥
          (exchangeScheduleCore d t q q' σ C₀ s).1.card := by
        by_cases hx : (exchangeScheduleCore d t q q' σ C₀ s).2 ∈
          (exchangeScheduleCore d t q q' σ C₀ s).1
        · rw [Finset.card_erase_of_mem hx]
          omega
        · simp [hx]
      omega
    · intro hm
      exact hr (Finset.mem_erase.mp hm).2

The exchange schedule's cache never shrinks below d's: from t onwards it has at least as many pages as d's cache.


lemma exchangeScheduleCore_card (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    {s : ℕ} (hs : t ≤ s) :
    (exchangeScheduleCore d t q q' σ C₀ s).1.card ≥ (schedCache d C₀ σ s).card := by
  have hmono : (exchangeScheduleCore d t q q' σ C₀ s).1.card ≥
      (exchangeScheduleCore d t q q' σ C₀ t).1.card := by
    induction s with
    | zero =>
        have ht : t = 0 := by omega
        subst t
        rfl
    | succ s ih =>
        by_cases hst : t ≤ s
        · exact le_trans (ih hst) (exchangeScheduleCore_card_step d t q q' σ C₀ s)
        · have hs' : s + 1 = t := by omega
          rw [← schedCache_exchangeScheduleCore]
          rw [← schedCache_exchangeScheduleCore]
          rw [schedCache_exchangeSchedule_eq_d d t q q' σ C₀ (le_of_eq hs')]
          rw [schedCache_exchangeSchedule_eq_d d t q q' σ C₀ le_rfl]
          rw [hs']
  have hbase : (exchangeScheduleCore d t q q' σ C₀ t).1.card = (schedCache d C₀ σ t).card := by
    rw [← schedCache_exchangeScheduleCore]
    rw [schedCache_exchangeSchedule_eq_d d t q q' σ C₀ le_rfl]
  have hconst : (schedCache d C₀ σ s).card = (schedCache d C₀ σ t).card := by
    have h : ∀ n, (schedCache d C₀ σ (t + n)).card = (schedCache d C₀ σ t).card := by
      intro n
      induction n with
      | zero => rfl
      | succ n ih =>
          rw [Nat.add_succ]
          rw [schedCache_card_const d C₀ σ t hweak (s := t + n) (by omega)]
          exact ih
    have hs' : s = t + (s - t) := by omega
    rw [hs']
    exact h (s - t)
  rw [hconst]
  rw [← hbase]
  exact hmono

The decision component of the core is the exchange decision at the same position.


lemma exchangeScheduleCore_second (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page) (s : ℕ) :
    (exchangeScheduleCore d t q q' σ C₀ s).2 =
      exchangeDecision d t q q' σ C₀ (exchangeScheduleCore d t q q' σ C₀ s).1 s := by
  induction s with
  | zero => rfl
  | succ s ih =>
      rw [exchangeScheduleCore]

When d hits at s and the exchange schedule faults, the exchange eviction at s is q, q', or a page d's cache lacks.


lemma exchangeDecision_of_hit (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ C' : Finset Page) {s : ℕ} (hst : t < s)
    (hr : σ.getD s 0 ∈ schedCache d C₀ σ s) (hr' : σ.getD s 0 ∉ C')
    (hrqq : σ.getD s 0 = q' ∨ σ.getD s 0 = q)
    (hcard : (schedCache d C₀ σ s).card ≤ C'.card) :
    exchangeDecision d t q q' σ C₀ C' s = q ∨
      exchangeDecision d t q q' σ C₀ C' s = q' ∨
      exchangeDecision d t q q' σ C₀ C' s ∉ schedCache d C₀ σ s := by
  unfold exchangeDecision
  have hlt : ¬ s < t := by omega
  have hne : ¬ s = t := by omega
  rw [if_neg hlt, if_neg hne]
  by_cases h1 : d s = q'
  · rw [if_pos h1]
    exact Or.inr (Or.inl rfl)
  · rw [if_neg h1]
    by_cases h2 : (σ.getD s 0 = q' ∨ σ.getD s 0 = q) ∧
        σ.getD s 0 ∈ schedCache d C₀ σ s
    · rw [if_pos h2]
      by_cases hf : ((C' \ schedCache d C₀ σ s).filter (fun x => x ≠ q')).Nonempty
      · rw [dif_pos hf]
        right; right
        have hspec := Classical.choose_spec hf
        intro hdec
        exact (Finset.mem_sdiff.mp (Finset.mem_filter.mp hspec).1).2 hdec
      · rw [dif_neg hf]
        by_cases hm : (C' \ schedCache d C₀ σ s).Nonempty
        · rw [dif_pos hm]
          right; right
          have hspec := Classical.choose_spec hm
          intro hdec
          exact (Finset.mem_sdiff.mp hspec).2 hdec
        · rw [dif_neg hm]
          exfalso
          have hsub : C' ⊆ schedCache d C₀ σ s := by
            intro y hy
            by_contra hyn
            exact hm ⟨y, Finset.mem_sdiff.mpr ⟨hy, hyn⟩⟩
          have hEq : C' = schedCache d C₀ σ s :=
            Finset.eq_of_subset_of_card_le hsub hcard
          have hrC' : σ.getD s 0 ∈ C' := by
            rw [hEq]
            exact hr
          exact hr' hrC'
    · rw [if_neg h2]
      exfalso
      exact h2 ⟨hrqq, hr⟩

When d faults at s, the exchange eviction at s is q, q', d s, or a page d's cache lacks.


lemma exchangeDecision_of_fault (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ C' : Finset Page)
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    {s : ℕ} (hst : t < s) (hr : σ.getD s 0 ∉ schedCache d C₀ σ s)
    (hcard : (schedCache d C₀ σ s).card ≤ C'.card) :
    exchangeDecision d t q q' σ C₀ C' s = q ∨
      exchangeDecision d t q q' σ C₀ C' s = q' ∨
      exchangeDecision d t q q' σ C₀ C' s = d s ∨
      exchangeDecision d t q q' σ C₀ C' s ∉ schedCache d C₀ σ s := by
  unfold exchangeDecision
  have hlt : ¬ s < t := by omega
  have hne : ¬ s = t := by omega
  rw [if_neg hlt, if_neg hne]
  by_cases h1 : d s = q'
  · rw [if_pos h1]
    exact Or.inr (Or.inl rfl)
  · rw [if_neg h1]
    by_cases h2 : (σ.getD s 0 = q' ∨ σ.getD s 0 = q) ∧
        σ.getD s 0 ∈ schedCache d C₀ σ s
    · exfalso
      exact hr h2.2
    · rw [if_neg h2]
      by_cases h3 : d s ∈ C'
      · rw [if_pos h3]
        exact Or.inr (Or.inr (Or.inl rfl))
      · rw [if_neg h3]
        by_cases hm : (C' \ schedCache d C₀ σ s).Nonempty
        · rw [dif_pos hm]
          right; right; right
          have hspec := Classical.choose_spec hm
          intro hdec
          exact (Finset.mem_sdiff.mp hspec).2 hdec
        · rw [dif_neg hm]
          exfalso
          have hsub : C' ⊆ schedCache d C₀ σ s := by
            intro y hy
            by_contra hyn
            exact hm ⟨y, Finset.mem_sdiff.mpr ⟨hy, hyn⟩⟩
          have hEq : C' = schedCache d C₀ σ s :=
            Finset.eq_of_subset_of_card_le hsub hcard
          have hds : d s ∈ C' := by
            rw [hEq]
            exact hweak s (by omega) hr
          exact h3 hds

The invariant of the exchange schedule: for every position s ≥ t+1, the exchange schedule's cache contains every page of d's cache except possibly q and q'. Consequently a fault of d on a request outside {q, q'} is never a hit of the exchange schedule — bad events (faults where d hits) can only happen on requests of q or q'.


lemma exchangeSchedule_invariant (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q)
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s) :
    ∀ s ≥ t + 1, ∀ x, x ∉ ({q, q'} : Finset Page) →
      x ∈ schedCache d C₀ σ s →
      x ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
  intro s hs
  induction s with
  | zero => omega
  | succ s ih =>
      intro x hx hmem
      by_cases hst : s = t
      · -- base: after the request at t, the caches differ only in q vs q'
        subst s
        rw [schedCache_exchangeScheduleCore]
        rw [exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ t).1 = schedCache d C₀ σ t by
          rw [← schedCache_exchangeScheduleCore]
          exact schedCache_exchangeSchedule_eq_d d t q q' σ C₀ le_rfl]
        rw [show (exchangeScheduleCore d t q q' σ C₀ t).2 = q' by
          exact exchangeSchedule_at_t d t q q' σ C₀]
        unfold schedCache at hmem
        rw [hq] at hmem
        by_cases hp : σ.getD t 0 ∈ schedCache d C₀ σ t
        · rw [if_pos hp] at hmem ⊢
          exact hmem
        · rw [if_neg hp] at hmem ⊢
          rcases Finset.mem_insert.mp hmem with hxeq | hxin
          · rw [hxeq]
            exact Finset.mem_insert_self (σ.getD t 0) ((schedCache d C₀ σ t).erase q')
          · have hxq' : x ≠ q' := by
              intro h
              exact hx (by simp [h])
            exact Finset.mem_insert_of_mem
              (Finset.mem_erase.mpr ⟨hxq', (Finset.mem_erase.mp hxin).2⟩)
      · -- step: s > t
        have hs' : t + 1 ≤ s := by omega
        have hst : t < s := by omega
        have ih' := ih hs'
        rw [schedCache_exchangeScheduleCore]
        rw [exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).1 =
            schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s by
          rw [← schedCache_exchangeScheduleCore]]
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).2 = exchangeDecision d t q q' σ C₀
            (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s by
          rw [exchangeScheduleCore_second]
          congr 1
          rw [← schedCache_exchangeScheduleCore]]
        by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
        · -- d hits at s
          unfold schedCache at hmem
          rw [if_pos hr] at hmem
          by_cases hr' : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
          · -- the exchange schedule hits too: no eviction
            rw [if_pos hr']
            exact ih' x hx hmem
          · -- d hits, the exchange schedule faults: the decision evicts q, q',
            -- or a page d's cache lacks, so x survives
            rw [if_neg hr']
            have hrqq : σ.getD s 0 = q' ∨ σ.getD s 0 = q := by
              by_contra hnot
              exact hr' (ih' (σ.getD s 0) (by
                intro hmem
                apply hnot
                rcases Finset.mem_insert.mp hmem with hqeq | hq'
                · exact Or.inr hqeq
                · exact Or.inl (Finset.mem_singleton.mp hq')) hr)
            have hcard : (schedCache d C₀ σ s).card ≤
                (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s).card := by
              rw [schedCache_exchangeScheduleCore]
              exact exchangeScheduleCore_card d t q q' σ C₀ hweak (by omega)
            have hdec := exchangeDecision_of_hit d t q q' σ C₀
              (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) hst hr hr' hrqq hcard
            have hxq : x ≠ q := by
              intro h
              exact hx (by simp [h])
            have hxq' : x ≠ q' := by
              intro h
              exact hx (by simp [h])
            have hxne : x ≠ exchangeDecision d t q q' σ C₀
                (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s := by
              intro hxdec
              rcases hdec with hdecq | hdecq' | hdecnot
              · exact hxq (hxdec.trans hdecq)
              · exact hxq' (hxdec.trans hdecq')
              · exact hdecnot (hxdec ▸ hmem)
            have hxC' : x ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s :=
              ih' x hx hmem
            exact Finset.mem_insert_of_mem (Finset.mem_erase.mpr ⟨hxne, hxC'⟩)
        · -- d faults at s
          unfold schedCache at hmem
          rw [if_neg hr] at hmem
          by_cases hr' : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
          · -- the exchange schedule hits: its cache is unchanged
            rw [if_pos hr']
            rcases Finset.mem_insert.mp hmem with hxr | hxin
            · rw [hxr]
              exact hr'
            · exact ih' x hx (Finset.mem_erase.mp hxin).2
          · -- both fault: r is inserted, and the decision evicts q, q', d s, or
            -- a page d's cache lacks, so x survives
            rw [if_neg hr']
            rcases Finset.mem_insert.mp hmem with hxr | hxin
            · rw [hxr]
              exact Finset.mem_insert_self (σ.getD s 0) _
            · have hxC_d : x ∈ schedCache d C₀ σ s := (Finset.mem_erase.mp hxin).2
              have hxne_ds : x ≠ d s := (Finset.mem_erase.mp hxin).1
              have hcard : (schedCache d C₀ σ s).card ≤
                  (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s).card := by
                rw [schedCache_exchangeScheduleCore]
                exact exchangeScheduleCore_card d t q q' σ C₀ hweak (by omega)
              have hdec := exchangeDecision_of_fault d t q q' σ C₀
                (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) hweak hst hr hcard
              have hxq : x ≠ q := by
                intro h
                exact hx (by simp [h])
              have hxq' : x ≠ q' := by
                intro h
                exact hx (by simp [h])
              have hxne : x ≠ exchangeDecision d t q q' σ C₀
                  (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s := by
                intro hxdec
                rcases hdec with hdecq | hdecq' | hdecds | hdecnot
                · exact hxq (hxdec.trans hdecq)
                · exact hxq' (hxdec.trans hdecq')
                · exact hxne_ds (hxdec.trans hdecds)
                · exact hdecnot (hxdec ▸ hxC_d)
              have hxC' : x ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s :=
                ih' x hx hxC_d
              exact Finset.mem_insert_of_mem (Finset.mem_erase.mpr ⟨hxne, hxC'⟩)

If q' is the farthest-in-future page of a cache at position i and q is a different resident page, then either q' is never requested again, or q's next request comes strictly before q''s next request.


lemma fifo_nextUse_order (σ : List Page) (cache : Finset Page) (i : ℕ) (q' q : Page)
    (hq' : q' = farthestInFuture cache σ i) (hq : q ∈ cache) (hqq' : q ≠ q') :
    nextUse σ (i + 1) q' = none ∨
      ∃ j j', nextUse σ (i + 1) q = some j ∧ nextUse σ (i + 1) q' = some j' ∧ j < j' := by
  have hmax := farthestInFuture_max (σ := σ) (i := i) (p := q) hq
  rw [← hq'] at hmax
  have hc := farther_cases hmax
  rcases hc with hnone' | ⟨jq', jq, hq'eq, hqeq, hle⟩
  · exact Or.inl hnone'
  · right
    refine ⟨jq, jq', hqeq, hq'eq, ?_⟩
    have hne : jq ≠ jq' := by
      intro hjj
      have hget := getD_eq_nextUse hqeq
      have hget' := getD_eq_nextUse hq'eq
      rw [hjj] at hget
      exact hqq' (hget.symm.trans hget')
    omega

Before the first request of q (inclusive), d's cache does not contain q (d evicts q at t, and q is not requested within (t, J)).


lemma d_cache_ne_q (d : ℕ → Page) (t : ℕ) (q Variable name `q'` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q)
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    {s : ℕ} (hs1 : t < s) (hs2 : s ≤ t + 1 + j) :
    q ∉ schedCache d C₀ σ s := by
  induction s with
  | zero => omega
  | succ s ih =>
      by_cases hs_eq : s = t
      · subst s
        rw [schedCache, hq, if_neg hft]
        rw [Finset.mem_insert]
        intro h
        rcases h with hqr | hqin
        · have hqinD : q ∈ schedCache d C₀ σ t := by
            have hd : d t ∈ schedCache d C₀ σ t := hweak t le_rfl hft
            rw [hq] at hd
            exact hd
          exact hft (hqr ▸ hqinD)
        · exact (by simpa [hq] using (Finset.mem_erase.mp hqin).1)
      · have hts : t < s := by omega
        have hsJ : s < t + 1 + j := by omega
        rw [schedCache]
        by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
        · rw [if_pos hr]
          exact ih hts (by omega)
        · rw [if_neg hr]
          intro hmem
          rcases Finset.mem_insert.mp hmem with hqr | hqin
          · have hneq := getD_ne_nextUse hj (by omega) hsJ
            exact hneq hqr.symm
          · exact ih hts (by omega) (Finset.mem_erase.mp hqin).2

Before the first request of q, the exchange cache differs from d's cache only by the swap of q' and q.


lemma exchangeSchedule_window (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q)
    (hqq' : q ≠ q')
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    (hq'res : q' ∈ schedCache d C₀ σ t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    (hq'ne : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q')
    {s : ℕ} (hs1 : t < s) (hs2 : s ≤ t + 1 + j) :
    schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s =
      insert q ((schedCache d C₀ σ s).erase q') := by
  induction s with
  | zero => omega
  | succ s ih =>
      by_cases hs_eq : s = t
      · subst s
        rw [schedCache_exchangeScheduleCore, exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ t).1 = schedCache d C₀ σ t by
          rw [← schedCache_exchangeScheduleCore]
          exact schedCache_exchangeSchedule_eq_d d t q q' σ C₀ le_rfl]
        rw [show (exchangeScheduleCore d t q q' σ C₀ t).2 = q' by
          exact exchangeSchedule_at_t d t q q' σ C₀]
        rw [if_neg hft]
        rw [schedCache]
        rw [hq]
        rw [if_neg hft]
        -- goal: insert r (D(t) − q') = insert q ((insert r (D(t) − q)) − q')
        have hqin : q ∈ schedCache d C₀ σ t := by
          have hd : d t ∈ schedCache d C₀ σ t := hweak t le_rfl hft
          rw [hq] at hd
          exact hd
        have hr_ne_q : σ.getD t 0 ≠ q := by
          intro h
          exact hft (h ▸ hqin)
        have hr_ne_q' : σ.getD t 0 ≠ q' := by
          intro h
          exact hft (h ▸ hq'res)
        apply Finset.ext
        intro x
        constructor
        · intro hx
          rw [Finset.mem_insert]
          rcases Finset.mem_insert.mp hx with hxr | hxin
          · subst x
            right
            rw [Finset.mem_erase]
            constructor
            · exact hr_ne_q'
            · rw [Finset.mem_insert]
              left
              rfl
          · by_cases hxq : x = q
            · left
              exact hxq
            · right
              rw [Finset.mem_erase]
              constructor
              · exact (Finset.mem_erase.mp hxin).1
              · rw [Finset.mem_insert]
                right
                exact Finset.mem_erase.mpr ⟨hxq, (Finset.mem_erase.mp hxin).2⟩
        · intro hx
          rw [Finset.mem_insert] at hx
          rcases hx with hxq | hxin
          · subst x
            rw [Finset.mem_insert]
            right
            rw [Finset.mem_erase]
            constructor
            · exact hqq'
            · exact hqin
          · have hxne_q' : x ≠ q' := (Finset.mem_erase.mp hxin).1
            rw [Finset.mem_insert]
            rcases Finset.mem_insert.mp (Finset.mem_erase.mp hxin).2 with hxr | hxin2
            · left
              exact hxr
            · right
              rw [Finset.mem_erase]
              constructor
              · exact hxne_q'
              · exact (Finset.mem_erase.mp hxin2).2
      · -- step: t < s, process position s
        have hts : t < s := by omega
        have hsJ : s < t + 1 + j := by omega
        have hqne : q ∉ schedCache d C₀ σ s :=
          d_cache_ne_q d t q q' σ C₀ hq hweak hft hj hts (by omega)
        have hsig_ne_q : σ.getD s 0 ≠ q := getD_ne_nextUse hj (by omega) hsJ
        have hsig_ne_q' : σ.getD s 0 ≠ q' := hq'ne s (by omega) hsJ
        rw [schedCache_exchangeScheduleCore, exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).1 =
            schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s by
          rw [← schedCache_exchangeScheduleCore]]
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).2 = exchangeDecision d t q q' σ C₀
            (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s by
          rw [exchangeScheduleCore_second]
          congr 1
          rw [← schedCache_exchangeScheduleCore]]
        rw [schedCache]
        by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
        · -- both hit
          rw [if_pos hr]
          have hrE : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
            rw [ih hts (by omega)]
            rw [Finset.mem_insert]
            right
            rw [Finset.mem_erase]
            constructor
            · exact hsig_ne_q'
            · exact hr
          rw [if_pos hrE]
          rw [ih hts (by omega)]
        · -- both fault
          rw [if_neg hr]
          have hrE : σ.getD s 0 ∉ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
            rw [ih hts (by omega)]
            intro hm
            rcases Finset.mem_insert.mp hm with hqeq | hmem
            · exact hsig_ne_q hqeq
            · exact hr (Finset.mem_erase.mp hmem).2
          rw [if_neg hrE]
          have hw := ih hts (by omega)
          rw [hw]
          unfold exchangeDecision
          have hlt : ¬ s < t := by omega
          have hne : ¬ s = t := by omega
          rw [if_neg hlt, if_neg hne]
          by_cases hdsq' : d s = q'
          · rw [if_pos hdsq']
            rw [hdsq']
            -- the erase q' on both sides has no effect
            have hq'notE : q' ∉ insert q ((schedCache d C₀ σ s).erase q') := by
              rw [Finset.mem_insert]
              intro hmem
              rcases hmem with hq'q | hq'mem
              · exact hqq' hq'q.symm
              · exact (Finset.mem_erase.mp hq'mem).1 rfl
            have hq'notE2 : q' ∉ insert (σ.getD s 0) ((schedCache d C₀ σ s).erase q') := by
              rw [Finset.mem_insert]
              intro hmem
              rcases hmem with hq'q | hq'mem
              · exact hsig_ne_q' hq'q.symm
              · exact (Finset.mem_erase.mp hq'mem).1 rfl
            rw [Finset.erase_eq_of_notMem hq'notE]
            rw [Finset.erase_eq_of_notMem hq'notE2]
            -- both sides equal insert q (insert r (D(s) − q'))
            rw [Finset.insert_comm]
          · rw [if_neg hdsq']
            -- d s ≠ q': branch 4 does not trigger (σ[s] ∉ {q, q'})
            by_cases hb4 : (σ.getD s 0 = q' ∨ σ.getD s 0 = q) ∧
                σ.getD s 0 ∈ schedCache d C₀ σ s
            · exfalso
              exact hb4.1.elim (fun h => hsig_ne_q' h) (fun h => hsig_ne_q h)
            · rw [if_neg hb4]
              -- d s ∈ E(s): by the invariant (d s ∈ D(s) and d s ∉ {q, q'})
              have hdne : d s ≠ q := by
                intro hdsq
                exact hqne (hdsq ▸ hweak s (by omega) hr)
              have hdE : d s ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
                have hinv := exchangeSchedule_invariant d t q q' σ C₀ hq hweak s (by omega)
                exact hinv (d s) (by
                  rw [Finset.mem_insert]
                  intro hmem
                  rcases hmem with hdsq | hdsqmem
                  · exact hdne hdsq
                  · exact hdsq' (Finset.mem_singleton.mp hdsqmem)) (hweak s (by omega) hr)
              have hdE' : d s ∈ insert q ((schedCache d C₀ σ s).erase q') := by
                rw [← hw]
                exact hdE
              rw [if_pos hdE']
              -- dec = d s: both sides are insert q (insert r (D(s) − {q', d s}))
              rw [Finset.erase_insert_of_ne hdne.symm]
              rw [Finset.erase_insert_of_ne hsig_ne_q']
              have herase_comm : ((schedCache d C₀ σ s).erase q').erase (d s) =
                  ((schedCache d C₀ σ s).erase (d s)).erase q' := by
                ext x
                simp [Finset.mem_erase, and_left_comm, This simp argument is unused:
  and_assoc

Hint: Omit it from the simp argument list.
  simp [Finset.mem_erase, and_left_comm,̵ ̵a̵n̵d̵_̵a̵s̵s̵o̵c̵]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`and_assoc]
              rw [herase_comm]
              rw [Finset.insert_comm]

When p is in both d's cache and the exchange cache, the exchange's eviction at s is not p (unless p is q' and d happens to evict q', which is excluded by hpq'; the 0-fallback branch is excluded by h0hit/h0fault together with a cardinality argument).


lemma exchangeDecision_ne (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    {s : ℕ} (hst : t < s) (C' : Finset Page) (p : Page)
    (Variable name `hpE` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hpE : p ∈ C') (hpD : p ∈ schedCache d C₀ σ s) (hdsq' : d s = q' → p ≠ q')
    (hdsC' : d s ∈ C' → p ≠ d s)
    (hcard : (schedCache d C₀ σ s).card ≤ C'.card)
    (h0hit : σ.getD s 0 ∈ schedCache d C₀ σ s → σ.getD s 0 ∉ C') :
    exchangeDecision d t q q' σ C₀ C' s ≠ p := by
  unfold exchangeDecision
  have hlt : ¬ s < t := by omega
  have hne : ¬ s = t := by omega
  rw [if_neg hlt, if_neg hne]
  by_cases h1 : d s = q'
  · rw [if_pos h1]
    intro hpeq
    exact hdsq' h1 hpeq.symm
  · rw [if_neg h1]
    by_cases h2 : (σ.getD s 0 = q' ∨ σ.getD s 0 = q) ∧
        σ.getD s 0 ∈ schedCache d C₀ σ s
    · rw [if_pos h2]
      by_cases hf : ((C' \ schedCache d C₀ σ s).filter (fun x => x ≠ q')).Nonempty
      · rw [dif_pos hf]
        intro hpeq
        have hspec := Classical.choose_spec hf
        have hpnotM : p ∉ C' \ schedCache d C₀ σ s := by
          intro hmem
          exact (Finset.mem_sdiff.mp hmem).2 hpD
        exact hpnotM (hpeq ▸ (Finset.mem_filter.mp hspec).1)
      · rw [dif_neg hf]
        by_cases hm : (C' \ schedCache d C₀ σ s).Nonempty
        · rw [dif_pos hm]
          intro hpeq
          have hspec := Classical.choose_spec hm
          have hpnotM : p ∉ C' \ schedCache d C₀ σ s := by
            rw [Finset.mem_sdiff]
            intro hmem
            exact hmem.2 hpD
          exact hpnotM (hpeq ▸ hspec)
        · rw [dif_neg hm]
          have hsub : C' ⊆ schedCache d C₀ σ s := by
            intro y hy
            by_contra hyn
            exact hm ⟨y, Finset.mem_sdiff.mpr ⟨hy, hyn⟩⟩
          have hEq : C' = schedCache d C₀ σ s :=
            Finset.eq_of_subset_of_card_le hsub hcard
          intro hpeq
          exact (h0hit h2.2) (hEq ▸ h2.2)
    · rw [if_neg h2]
      by_cases h3 : d s ∈ C'
      · rw [if_pos h3]
        intro hpeq
        exact hdsC' h3 hpeq.symm
      · rw [if_neg h3]
        by_cases hm : (C' \ schedCache d C₀ σ s).Nonempty
        · rw [dif_pos hm]
          intro hpeq
          have hspec := Classical.choose_spec hm
          have hpnotM : p ∉ C' \ schedCache d C₀ σ s := by
            rw [Finset.mem_sdiff]
            intro hmem
            exact hmem.2 hpD
          exact hpnotM (hpeq ▸ hspec)
        · rw [dif_neg hm]
          have hsub : C' ⊆ schedCache d C₀ σ s := by
            intro y hy
            by_contra hyn
            exact hm ⟨y, Finset.mem_sdiff.mpr ⟨hy, hyn⟩⟩
          have hEq : C' = schedCache d C₀ σ s :=
            Finset.eq_of_subset_of_card_le hsub hcard
          intro hpeq
          by_cases hr0 : σ.getD s 0 ∈ schedCache d C₀ σ s
          · exact (h0hit hr0) (hEq ▸ hr0)
          · have hdsin : d s ∈ C' := by
              rw [hEq]
              exact hweak s (by omega) hr0
            exact h3 hdsin

When σ[s] ∈ {q,q'} and d hits, while p is in both caches (branch 4 triggers), the exchange's eviction at s is not p.


lemma exchangeDecision_ne_of_branch4 (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (Variable name `hqq'` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hqq' : q ≠ q')
    (Variable name `hweak` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    {s : ℕ} (hst : t < s) (C' : Finset Page) (p : Page)
    (Variable name `hpE` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hpE : p ∈ C') (hpD : p ∈ schedCache d C₀ σ s) (hpq' : p ≠ q')
    (hb4 : (σ.getD s 0 = q' ∨ σ.getD s 0 = q) ∧
      σ.getD s 0 ∈ schedCache d C₀ σ s)
    (hcard : (schedCache d C₀ σ s).card ≤ C'.card)
    (h0hit : σ.getD s 0 ∈ schedCache d C₀ σ s → σ.getD s 0 ∉ C') :
    exchangeDecision d t q q' σ C₀ C' s ≠ p := by
  unfold exchangeDecision
  have hlt : ¬ s < t := by omega
  have hne : ¬ s = t := by omega
  rw [if_neg hlt, if_neg hne]
  by_cases h1 : d s = q'
  · rw [if_pos h1]
    intro hpeq
    exact hpq' hpeq.symm
  · rw [if_neg h1]
    rw [if_pos hb4]
    by_cases hf : ((C' \ schedCache d C₀ σ s).filter (fun x => x ≠ q')).Nonempty
    · rw [dif_pos hf]
      intro hpeq
      have hspec := Classical.choose_spec hf
      have hpnotM : p ∉ C' \ schedCache d C₀ σ s := by
        intro hmem
        exact (Finset.mem_sdiff.mp hmem).2 hpD
      exact hpnotM (hpeq ▸ (Finset.mem_filter.mp hspec).1)
    · rw [dif_neg hf]
      by_cases hm : (C' \ schedCache d C₀ σ s).Nonempty
      · rw [dif_pos hm]
        intro hpeq
        have hspec := Classical.choose_spec hm
        have hpnotM : p ∉ C' \ schedCache d C₀ σ s := by
          intro hmem
          exact (Finset.mem_sdiff.mp hmem).2 hpD
        exact hpnotM (hpeq ▸ hspec)
      · rw [dif_neg hm]
        have hsub : C' ⊆ schedCache d C₀ σ s := by
          intro y hy
          by_contra hyn
          exact hm ⟨y, Finset.mem_sdiff.mpr ⟨hy, hyn⟩⟩
        have hEq : C' = schedCache d C₀ σ s :=
          Finset.eq_of_subset_of_card_le hsub hcard
        intro hpeq
        exact (h0hit hb4.2) (hEq ▸ hb4.2)

If q is in d's cache then q is also in the exchange cache (at any position after t): q leaves the exchange cache only when d evicts it, and at that point d evicts it too.


lemma exchangeSchedule_q_mem (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q) (hqq' : q ≠ q')
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    (Variable name `hq'res` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hq'res : q' ∈ schedCache d C₀ σ t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    (Variable name `hq'ne` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hq'ne : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q') :
    ∀ s, t < s → q ∈ schedCache d C₀ σ s →
      q ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
  intro s
  induction s with
  | zero => omega
  | succ s ih =>
      intro hs hqin
      by_cases hs_eq : s = t
      · -- q ∉ D(t+1): d evicts q at t, and there is no q request before t
        subst s
        exfalso
        have hqne : q ∉ schedCache d C₀ σ (t + 1) :=
          d_cache_ne_q d t q q' σ C₀ hq hweak hft hj (by omega) (by omega)
        exact hqne hqin
      · have hts : t < s := by omega
        -- unfold E(s+1)
        rw [schedCache_exchangeScheduleCore, exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).1 =
            schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s by
          rw [← schedCache_exchangeScheduleCore]]
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).2 = exchangeDecision d t q q' σ C₀
            (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s by
          rw [exchangeScheduleCore_second]
          congr 1
          rw [← schedCache_exchangeScheduleCore]]
        -- unfold D(s+1) in hqin
        rw [schedCache] at hqin
        by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
        · -- d hits: D(s+1) = D(s)
          rw [if_pos hr] at hqin
          have hqE : q ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s :=
            ih hts hqin
          by_cases hrE : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
          · rw [if_pos hrE]
            exact hqE
          · -- bad event: σ[s] ∈ D(s) − E(s) ⊆ {q, q'}
            rw [if_neg hrE]
            have hqqq' : σ.getD s 0 = q' ∨ σ.getD s 0 = q := by
              by_contra hnot
              have hinv := exchangeSchedule_invariant d t q q' σ C₀ hq hweak s (by omega)
              exact hrE (hinv (σ.getD s 0) (by
                intro hmem
                apply hnot
                rcases Finset.mem_insert.mp hmem with hqeq | hq'eq
                · exact Or.inr hqeq
                · exact Or.inl (Finset.mem_singleton.mp hq'eq)) hr)
            rcases hqqq' with hq'eq | hqeq
            · -- σ[s] = q': branch 4 triggers, dec ≠ q
              have hb4 : (σ.getD s 0 = q' ∨ σ.getD s 0 = q) ∧
                  σ.getD s 0 ∈ schedCache d C₀ σ s := ⟨Or.inl hq'eq, hr⟩
              have hcard : (schedCache d C₀ σ s).card ≤
                  (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s).card := by
                rw [schedCache_exchangeScheduleCore]
                exact exchangeScheduleCore_card d t q q' σ C₀ hweak (by omega)
              have hdec : exchangeDecision d t q q' σ C₀
                  (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s ≠ q := by
                apply exchangeDecision_ne_of_branch4 d t q q' σ C₀ hqq' hweak hts
                · exact hqE
                · exact hqin
                · exact hqq'
                · exact hb4
                · exact hcard
                · exact fun _ => hrE
              exact Finset.mem_insert_of_mem (b := σ.getD s 0) (Finset.mem_erase.mpr ⟨hdec.symm, hqE⟩)
            · -- σ[s] = q: contradicts q ∈ E(s)
              exfalso
              exact hrE (hqeq ▸ hqE)
        · -- d faults
          rw [if_neg hr] at hqin
          rcases Finset.mem_insert.mp hqin with hqeq | hqin'
          · -- q = σ[s]: the exchange loads q
            by_cases hrE : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
            · rw [if_pos hrE]
              exact hqeq.symm ▸ hrE
            · rw [if_neg hrE]
              exact hqeq.symm ▸ Finset.mem_insert_self (σ.getD s 0) _
          · -- q ∈ D(s) and q ≠ d s
            have hqD : q ∈ schedCache d C₀ σ s := (Finset.mem_erase.mp hqin').2
            have hqds : q ≠ d s := (Finset.mem_erase.mp hqin').1
            have hqE : q ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s :=
              ih hts hqD
            have hcard : (schedCache d C₀ σ s).card ≤
                (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s).card := by
              rw [schedCache_exchangeScheduleCore]
              exact exchangeScheduleCore_card d t q q' σ C₀ hweak (by omega)
            have hdec : exchangeDecision d t q q' σ C₀
                (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s ≠ q := by
              apply exchangeDecision_ne d t q q' σ C₀ hweak hts
              · exact hqE
              · exact hqD
              · intro hds
                exact hqq'
              · intro hdsin
                exact hqds
              · exact hcard
              · intro hmem
                exact False.elim (hr hmem)
            by_cases hrE : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
            · rw [if_pos hrE]
              exact hqE
            · rw [if_neg hrE]
              exact Finset.mem_insert_of_mem (b := σ.getD s 0) (Finset.mem_erase.mpr ⟨hdec.symm, hqE⟩)

Up to and including the first q' request, the exchange cache does not contain q' (q' is evicted at t, and there is no q' request within (t, J')).


lemma exchangeSchedule_q'_absent (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (Variable name `hweak` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    (hq'res : q' ∈ schedCache d C₀ σ t)
    {j' : ℕ} (hj' : nextUse σ (t + 1) q' = some j')
    {s : ℕ} (hs1 : t < s) (hs2 : s ≤ t + 1 + j') :
    q' ∉ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
  induction s with
  | zero => omega
  | succ s ih =>
      by_cases hs_eq : s = t
      · subst s
        rw [schedCache_exchangeScheduleCore, exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ t).1 = schedCache d C₀ σ t by
          rw [← schedCache_exchangeScheduleCore]
          exact schedCache_exchangeSchedule_eq_d d t q q' σ C₀ le_rfl]
        rw [show (exchangeScheduleCore d t q q' σ C₀ t).2 = q' by
          exact exchangeSchedule_at_t d t q q' σ C₀]
        rw [if_neg hft]
        rw [Finset.mem_insert]
        intro hmem
        rcases hmem with hq'eq | hq'mem
        · exact hft (hq'eq ▸ hq'res)
        · exact (Finset.mem_erase.mp hq'mem).1 rfl
      · have hts : t < s := by omega
        have hsJ' : s < t + 1 + j' := by omega
        have hsig_ne_q' : σ.getD s 0 ≠ q' := getD_ne_nextUse hj' (by omega) hsJ'
        rw [schedCache_exchangeScheduleCore, exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).1 =
            schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s by
          rw [← schedCache_exchangeScheduleCore]]
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).2 = exchangeDecision d t q q' σ C₀
            (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s by
          rw [exchangeScheduleCore_second]
          congr 1
          rw [← schedCache_exchangeScheduleCore]]
        by_cases hrE : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
        · rw [if_pos hrE]
          exact ih hts (by omega)
        · rw [if_neg hrE]
          intro hmem
          rcases Finset.mem_insert.mp hmem with hq'eq | hq'in
          · exact hsig_ne_q' hq'eq.symm
          · exact ih hts (by omega) (Finset.mem_erase.mp hq'in).2

After the first q' request, if q' is in d's cache then q' is also in the exchange cache (q' is reloaded by both schedules at J', and afterwards only evicted together with d).


lemma exchangeSchedule_q'_mem (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q) (hqq' : q ≠ q')
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    (hq'res : q' ∈ schedCache d C₀ σ t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    (hq'ne : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q')
    {j' : ℕ} (hj' : nextUse σ (t + 1) q' = some j') :
    ∀ s, t + 1 + j' < s → q' ∈ schedCache d C₀ σ s →
      q' ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
  intro s
  induction s with
  | zero => omega
  | succ s ih =>
      intro hs hqin
      by_cases hs_eq : s = t + 1 + j'
      · -- base: at position J' the exchange loads q'
        subst s
        rw [schedCache_exchangeScheduleCore, exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ (t + 1 + j')).1 =
            schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ (t + 1 + j') by
          rw [← schedCache_exchangeScheduleCore]]
        have hsig : σ.getD (t + 1 + j') 0 = q' := getD_eq_nextUse hj'
        have hJ'ne : σ.getD (t + 1 + j') 0 ∉
            schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ (t + 1 + j') := by
          rw [hsig]
          apply exchangeSchedule_q'_absent d t q q' σ C₀ hweak hft hq'res hj'
          · omega
          · rfl
        rw [hsig]
        rw [hsig] at hJ'ne
        rw [if_neg hJ'ne]
        exact Finset.mem_insert_self q' _
      · have hsJ' : t + 1 + j' < s := by omega
        rw [schedCache_exchangeScheduleCore, exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).1 =
            schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s by
          rw [← schedCache_exchangeScheduleCore]]
        rw [show (exchangeScheduleCore d t q q' σ C₀ s).2 = exchangeDecision d t q q' σ C₀
            (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s by
          rw [exchangeScheduleCore_second]
          congr 1
          rw [← schedCache_exchangeScheduleCore]]
        rw [schedCache] at hqin
        by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
        · -- d hits
          rw [if_pos hr] at hqin
          have hq'E : q' ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s :=
            ih hsJ' hqin
          by_cases hrE : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
          · rw [if_pos hrE]
            exact hq'E
          · -- bad event: σ[s] ∈ D(s) − E(s) ⊆ {q, q'}, both subcases excluded by the membership lemmas
            rw [if_neg hrE]
            have hqqq' : σ.getD s 0 = q' ∨ σ.getD s 0 = q := by
              by_contra hnot
              have hinv := exchangeSchedule_invariant d t q q' σ C₀ hq hweak s (by omega)
              exact hrE (hinv (σ.getD s 0) (by
                intro hmem
                apply hnot
                rcases Finset.mem_insert.mp hmem with hqeq | hq'eq
                · exact Or.inr hqeq
                · exact Or.inl (Finset.mem_singleton.mp hq'eq)) hr)
            rcases hqqq' with hq'eq | hqeq
            · exfalso
              exact hrE (hq'eq ▸ hq'E)
            · exfalso
              have hqE : q ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s :=
                exchangeSchedule_q_mem d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'ne s (by omega) (hqeq ▸ hr)
              exact hrE (hqeq ▸ hqE)
        · -- d faults
          rw [if_neg hr] at hqin
          rcases Finset.mem_insert.mp hqin with hq'eq | hq'in
          · -- q' = σ[s]: the exchange loads q'
            by_cases hrE : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
            · rw [if_pos hrE]
              exact hq'eq.symm ▸ hrE
            · rw [if_neg hrE]
              exact hq'eq.symm ▸ Finset.mem_insert_self (σ.getD s 0) _
          · -- q' ∈ D(s) and q' ≠ d s
            have hts : t < s := by omega
            have hq'D : q' ∈ schedCache d C₀ σ s := (Finset.mem_erase.mp hq'in).2
            have hq'ds : q' ≠ d s := (Finset.mem_erase.mp hq'in).1
            have hq'E : q' ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s :=
              ih hsJ' hq'D
            have hcard : (schedCache d C₀ σ s).card ≤
                (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s).card := by
              rw [schedCache_exchangeScheduleCore]
              exact exchangeScheduleCore_card d t q q' σ C₀ hweak (by omega)
            have hdec : exchangeDecision d t q q' σ C₀
                (schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) s ≠ q' := by
              apply exchangeDecision_ne d t q q' σ C₀ hweak hts
              · exact hq'E
              · exact hq'D
              · intro hds
                exact False.elim (hq'ds hds.symm)
              · intro hdsin
                exact hq'ds
              · exact hcard
              · intro hmem
                exact False.elim (hr hmem)
            by_cases hrE : σ.getD s 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
            · rw [if_pos hrE]
              exact hq'E
            · rw [if_neg hrE]
              exact Finset.mem_insert_of_mem (b := σ.getD s 0) (Finset.mem_erase.mpr ⟨hdec.symm, hq'E⟩)

Good event: at the first request of q, the exchange hits while d faults.


lemma exchangeSchedule_good (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q) (hqq' : q ≠ q')
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    (hq'res : q' ∈ schedCache d C₀ σ t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    (hq'ne : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q') :
    σ.getD (t + 1 + j) 0 ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ (t + 1 + j) ∧
    σ.getD (t + 1 + j) 0 ∉ schedCache d C₀ σ (t + 1 + j) := by
  have hsig : σ.getD (t + 1 + j) 0 = q := getD_eq_nextUse hj
  constructor
  · rw [hsig]
    rw [exchangeSchedule_window d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'ne
      (s := t + 1 + j) (by omega) (by rfl)]
    rw [Finset.mem_insert]
    left
    rfl
  · rw [hsig]
    exact d_cache_ne_q d t q q' σ C₀ hq hweak hft hj (by omega) (by omega)

The bad event (the exchange faults while d hits) can only occur at the first q' request.


lemma exchangeSchedule_bad (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q) (hqq' : q ≠ q')
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    (hq'res : q' ∈ schedCache d C₀ σ t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    (hq'ne : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q')
    {j' : ℕ} (hj' : nextUse σ (t + 1) q' = some j')
    {s : ℕ} (hst : t < s) :
    σ.getD s 0 ∈ schedCache d C₀ σ s →
    σ.getD s 0 ∉ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s →
    s = t + 1 + j' := by
  intro hmem hnot
  have hqqq' : σ.getD s 0 = q' ∨ σ.getD s 0 = q := by
    by_contra hnot'
    have hinv := exchangeSchedule_invariant d t q q' σ C₀ hq hweak s (by omega)
    exact hnot (hinv (σ.getD s 0) (by
      intro hmem2
      apply hnot'
      rcases Finset.mem_insert.mp hmem2 with hqeq | hq'eq
      · exact Or.inr hqeq
      · exact Or.inl (Finset.mem_singleton.mp hq'eq)) hmem)
  rcases hqqq' with hq'eq | hqeq
  · -- σ[s] = q': exclude s < J' and s > J'
    by_cases hlt : s < t + 1 + j'
    · exfalso
      exact (getD_ne_nextUse hj' (by omega) hlt) hq'eq
    · by_cases hgt : t + 1 + j' < s
      · exfalso
        have hq'E : q' ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
          have hq'in' : q' ∈ schedCache d C₀ σ s := hq'eq ▸ hmem
          exact exchangeSchedule_q'_mem d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'ne hj'
            s hgt hq'in'
        exact hnot (hq'eq ▸ hq'E)
      · omega
  · -- σ[s] = q: contradicts L-q
    exfalso
    have hqE : q ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
      have hqin' : q ∈ schedCache d C₀ σ s := hqeq ▸ hmem
      exact exchangeSchedule_q_mem d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'ne s hst hqin'
    exact hnot (hqeq ▸ hqE)

The exchange schedule has no more misses than d: the good event (first q request) compensates for the unique bad event (first q' request).


lemma exchangeSchedule_misses_le (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q) (hqq' : q ≠ q')
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    (hq'res : q' ∈ schedCache d C₀ σ t)
    (hfifo : nextUse σ (t + 1) q' = none ∨
      ∃ j j', nextUse σ (t + 1) q = some j ∧ nextUse σ (t + 1) q' = some j' ∧ j < j') :
    schedMisses (exchangeSchedule d t q q' σ C₀) C₀ σ ≤ schedMisses d C₀ σ := by
  let e : ℕ → Page := exchangeSchedule d t q q' σ C₀
  let eF : ℕ → ℕ := schedFaultAt e C₀ σ
  let dF : ℕ → ℕ := schedFaultAt d C₀ σ
  rcases hfifo with hnone | ⟨j, j', hj, hj', hjlt⟩
  · -- CASE A: `q'` is never requested again
    have hq'ne_s : ∀ s, t + 1 ≤ s → s < σ.length → σ.getD s 0 ≠ q' := by
      intro s hs hlen
      have hnone' := nextUse_eq_none_iff.mp hnone
      apply hnone' (σ.getD s 0)
      have hget : (σ.drop (t + 1)).getD (s - (t + 1)) 0 = σ.getD s 0 := by
        rw [getD_drop]
        rw [Nat.add_sub_of_le hs]
      rw [← hget]
      have hlt' : s - (t + 1) < (σ.drop (t + 1)).length := by
        rw [List.length_drop]
        omega
      rw [List.getD_eq_getElem _ 0 hlt']
      exact List.getElem_mem hlt'
    by_cases hqreq : ∃ j, nextUse σ (t + 1) q = some j
    · -- q will be requested: the good event at J compensates for everything
      rcases hqreq with ⟨j, hj⟩
      have hJlen : t + 1 + j < σ.length := by
        have hjlt' : j < (σ.drop (t + 1)).length := (nextUse_eq_some_iff.mp hj).1
        rw [List.length_drop] at hjlt'
        omega
      have hJle : t + 1 + j + 1 ≤ σ.length := by omega
      have hq'neA : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q' := by
        intro k hk1 hk2
        exact hq'ne_s k hk1 (by omega)
      -- pointwise: fault equal for s ≤ t
      have hP0 : ∀ s, s ≤ t → eF s = dF s := by
        intro s hs
        unfold eF dF e schedFaultAt
        rw [schedCache_exchangeSchedule_eq_d d t q q' σ C₀ hs]
      -- pointwise: fault equal for t < s < J (window)
      have hP1 : ∀ s, t < s → s < t + 1 + j → eF s = dF s := by
        intro s hst hsJ
        unfold eF dF e schedFaultAt
        rw [exchangeSchedule_window d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neA
          (s := s) hst (by omega)]
        have hne1 : σ.getD s 0 ≠ q := getD_ne_nextUse hj (by omega) hsJ
        have hne2 : σ.getD s 0 ≠ q' := hq'neA s (by omega) hsJ
        by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
        · rw [if_pos hr]
          have hrE' : σ.getD s 0 ∈ insert q ((schedCache d C₀ σ s).erase q') := by
            rw [Finset.mem_insert]
            right
            rw [Finset.mem_erase]
            constructor
            · exact hne2
            · exact hr
          rw [if_pos hrE']
        · rw [if_neg hr]
          have hrE' : σ.getD s 0 ∉ insert q ((schedCache d C₀ σ s).erase q') := by
            intro hm
            rcases Finset.mem_insert.mp hm with hqeq | hmem
            · exact hne1 hqeq
            · exact hr (Finset.mem_erase.mp hmem).2
          rw [if_neg hrE']
      -- pointwise: eF ≤ dF for J < s (no bad event)
      have hP3A : ∀ s, t < s → s < σ.length → eF s ≤ dF s := by
        intro s hst hlen
        unfold eF dF e schedFaultAt
        by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
        · by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
          · rw [if_pos hrE, if_pos hr]
          · rw [if_neg hrE, if_pos hr]
            exfalso
            have hqqq' : σ.getD s 0 = q' ∨ σ.getD s 0 = q := by
              by_contra hnot
              have hinv := exchangeSchedule_invariant d t q q' σ C₀ hq hweak s (by omega)
              exact hrE (hinv (σ.getD s 0) (by
                intro hmem2
                apply hnot
                rcases Finset.mem_insert.mp hmem2 with hqeq | hq'eq
                · exact Or.inr hqeq
                · exact Or.inl (Finset.mem_singleton.mp hq'eq)) hr)
            rcases hqqq' with hq'eq | hqeq
            · exact hq'ne_s s (by omega) hlen hq'eq
            · have hqE : q ∈ schedCache e C₀ σ s := by
                exact exchangeSchedule_q_mem d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neA
                  s hst (hqeq ▸ hr)
              exact hrE (hqeq ▸ hqE)
        · rw [if_neg hr]
          by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
          · rw [if_pos hrE]
            omega
          · rw [if_neg hrE]
      -- good event at J
      have hgood := exchangeSchedule_good d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neA
      -- split the sum
      have hdisj : Disjoint (Finset.range (t + 1 + j + 1))
          (Finset.Ico (t + 1 + j + 1) σ.length) := by
        rw [Finset.disjoint_left]
        intro s hs1 hs2
        have h1 : s < t + 1 + j + 1 := Finset.mem_range.mp hs1
        have h2 : t + 1 + j + 1 ≤ s := (Finset.mem_Ico.mp hs2).1
        omega
      have hunion : Finset.range (t + 1 + j + 1) ∪ Finset.Ico (t + 1 + j + 1) σ.length =
          Finset.range σ.length := by
        ext s
        simp [Finset.mem_Ico]
        constructor
        · intro h
          rcases h with hs | ⟨h1, h2⟩
          · omega
          · exact h2
        · intro hs
          by_cases hs' : s < t + 1 + j + 1
          · exact Or.inl (Nat.lt_succ_iff.mp hs')
          · right
            constructor
            · omega
            · exact hs
      have hsum_e : (∑ s ∈ Finset.range σ.length, eF s) =
          (∑ s ∈ Finset.range (t + 1 + j + 1), eF s) +
            ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s := by
        rw [← hunion, Finset.sum_union hdisj]
      have hsum_d : (∑ s ∈ Finset.range σ.length, dF s) =
          (∑ s ∈ Finset.range (t + 1 + j + 1), dF s) +
            ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, dF s := by
        rw [← hunion, Finset.sum_union hdisj]
      -- first part: Σ_{<J+1} eF + 1 ≤ Σ_{<J+1} dF
      have hpart1 : (∑ s ∈ Finset.range (t + 1 + j + 1), eF s) + 1 ≤
          ∑ s ∈ Finset.range (t + 1 + j + 1), dF s := by
        rw [Finset.sum_range_succ]
        rw [Finset.sum_range_succ]
        have heJ : eF (t + 1 + j) = 0 := by
          unfold eF schedFaultAt
          rw [if_pos hgood.1]
        have hdJ : dF (t + 1 + j) = 1 := by
          unfold dF schedFaultAt
          rw [if_neg hgood.2]
        rw [heJ, hdJ]
        have hle : (∑ s ∈ Finset.range (t + 1 + j), eF s) ≤
            ∑ s ∈ Finset.range (t + 1 + j), dF s := by
          exact Finset.sum_le_sum (fun s hs => by
            by_cases hst' : s ≤ t
            · exact le_of_eq (hP0 s hst')
            · have hts' : t < s := by omega
              exact le_of_eq (hP1 s hts' (Finset.mem_range.mp hs)))
        have hle' : (∑ s ∈ Finset.range (t + 1 + j), eF s) + 1 ≤
            (∑ s ∈ Finset.range (t + 1 + j), dF s) + 1 := Nat.add_le_add_right hle 1
        simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hle'
      -- second part: Σ_{[J+1,len)} eF ≤ Σ dF
      have hpart2 : (∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s) ≤
          ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, dF s := by
        apply Finset.sum_le_sum
        intro s hs
        have hst' : t < s := by
          have h1 : t + 1 + j + 1 ≤ s := (Finset.mem_Ico.mp hs).1
          omega
        exact hP3A s hst' (Finset.mem_Ico.mp hs).2
      -- assemble
      unfold schedMisses
      change (∑ s ∈ Finset.range σ.length, eF s) ≤ ∑ s ∈ Finset.range σ.length, dF s
      rw [hsum_e, hsum_d]
      omega
    · -- q is never requested either: no q request, no q' request, pointwise comparison suffices
      have hqne_s : ∀ s, t + 1 ≤ s → s < σ.length → σ.getD s 0 ≠ q := by
        intro s hs hlen
        have hnoneq : nextUse σ (t + 1) q = none := by
          cases hopt : nextUse σ (t + 1) q with
          | none => rfl
          | some j => exact False.elim (hqreq ⟨j, hopt⟩)
        have hnoneq' := nextUse_eq_none_iff.mp hnoneq
        apply hnoneq' (σ.getD s 0)
        have hget : (σ.drop (t + 1)).getD (s - (t + 1)) 0 = σ.getD s 0 := by
          rw [getD_drop]
          rw [Nat.add_sub_of_le hs]
        rw [← hget]
        have hlt' : s - (t + 1) < (σ.drop (t + 1)).length := by
          rw [List.length_drop]
          omega
        rw [List.getD_eq_getElem _ 0 hlt']
        exact List.getElem_mem hlt'
      -- pointwise eF ≤ dF
      have hP : ∀ s, s < σ.length → eF s ≤ dF s := by
        intro s hlen
        by_cases hst : s ≤ t
        · -- caches equal
          unfold eF dF e schedFaultAt
          rw [schedCache_exchangeSchedule_eq_d d t q q' σ C₀ hst]
        · have hts' : t < s := by omega
          unfold eF dF e schedFaultAt
          by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
          · by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
            · rw [if_pos hrE, if_pos hr]
            · rw [if_neg hrE, if_pos hr]
              exfalso
              have hqqq' : σ.getD s 0 = q' ∨ σ.getD s 0 = q := by
                by_contra hnot
                have hinv := exchangeSchedule_invariant d t q q' σ C₀ hq hweak s (by omega)
                exact hrE (hinv (σ.getD s 0) (by
                  intro hmem2
                  apply hnot
                  rcases Finset.mem_insert.mp hmem2 with hqeq | hq'eq
                  · exact Or.inr hqeq
                  · exact Or.inl (Finset.mem_singleton.mp hq'eq)) hr)
              rcases hqqq' with hq'eq | hqeq
              · exact hq'ne_s s (by omega) hlen hq'eq
              · exact hqne_s s (by omega) hlen hqeq
          · rw [if_neg hr]
            by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
            · rw [if_pos hrE]
              omega
            · rw [if_neg hrE]
      unfold schedMisses
      change (∑ s ∈ Finset.range σ.length, eF s) ≤ ∑ s ∈ Finset.range σ.length, dF s
      exact Finset.sum_le_sum (fun s hs => hP s (Finset.mem_range.mp hs))
  · -- CASE B: the first request of `q` comes before the first request of `q'`
    have hJlen : t + 1 + j < σ.length := by
      have hjlt' : j < (σ.drop (t + 1)).length := (nextUse_eq_some_iff.mp hj).1
      rw [List.length_drop] at hjlt'
      omega
    have hJ'len : t + 1 + j' < σ.length := by
      have hj'lt' : j' < (σ.drop (t + 1)).length := (nextUse_eq_some_iff.mp hj').1
      rw [List.length_drop] at hj'lt'
      omega
    have hJle : t + 1 + j + 1 ≤ σ.length := by omega
    have hJ'le : t + 1 + j' + 1 ≤ σ.length := by omega
    have hJJ' : t + 1 + j + 1 ≤ t + 1 + j' := by omega
    have hq'neB : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q' := by
      intro k hk1 hk2
      exact getD_ne_nextUse hj' hk1 (by omega)
    -- pointwise: fault equal for s ≤ t
    have hP0 : ∀ s, s ≤ t → eF s = dF s := by
      intro s hs
      unfold eF dF e schedFaultAt
      rw [schedCache_exchangeSchedule_eq_d d t q q' σ C₀ hs]
    -- pointwise: fault equal for t < s < J (window)
    have hP1 : ∀ s, t < s → s < t + 1 + j → eF s = dF s := by
      intro s hst hsJ
      unfold eF dF e schedFaultAt
      rw [exchangeSchedule_window d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neB
        (s := s) hst (by omega)]
      have hne1 : σ.getD s 0 ≠ q := getD_ne_nextUse hj (by omega) hsJ
      have hne2 : σ.getD s 0 ≠ q' := hq'neB s (by omega) hsJ
      by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
      · rw [if_pos hr]
        have hrE' : σ.getD s 0 ∈ insert q ((schedCache d C₀ σ s).erase q') := by
          rw [Finset.mem_insert]
          right
          rw [Finset.mem_erase]
          constructor
          · exact hne2
          · exact hr
        rw [if_pos hrE']
      · rw [if_neg hr]
        have hrE' : σ.getD s 0 ∉ insert q ((schedCache d C₀ σ s).erase q') := by
          intro hm
          rcases Finset.mem_insert.mp hm with hqeq | hmem
          · exact hne1 hqeq
          · exact hr (Finset.mem_erase.mp hmem).2
        rw [if_neg hrE']
    -- pointwise: eF ≤ dF for s ≠ J' (the bad event only at J')
    have hP3 : ∀ s, t < s → s < σ.length → s ≠ t + 1 + j' → eF s ≤ dF s := by
      intro s hst hlen hsne
      unfold eF dF e schedFaultAt
      by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
      · by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
        · rw [if_pos hrE, if_pos hr]
        · rw [if_neg hrE, if_pos hr]
          exfalso
          exact hsne (exchangeSchedule_bad d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neB hj'
            hst hr hrE)
      · rw [if_neg hr]
        by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
        · rw [if_pos hrE]
          omega
        · rw [if_neg hrE]
    -- good event at J
    have hgood := exchangeSchedule_good d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neB
    -- split the sum
    have hdisj : Disjoint (Finset.range (t + 1 + j + 1))
        (Finset.Ico (t + 1 + j + 1) σ.length) := by
      rw [Finset.disjoint_left]
      intro s hs1 hs2
      have h1 : s < t + 1 + j + 1 := Finset.mem_range.mp hs1
      have h2 : t + 1 + j + 1 ≤ s := (Finset.mem_Ico.mp hs2).1
      omega
    have hunion : Finset.range (t + 1 + j + 1) ∪ Finset.Ico (t + 1 + j + 1) σ.length =
        Finset.range σ.length := by
      ext s
      simp [Finset.mem_Ico]
      constructor
      · intro h
        rcases h with hs | ⟨h1, h2⟩
        · omega
        · exact h2
      · intro hs
        by_cases hs' : s < t + 1 + j + 1
        · exact Or.inl (Nat.lt_succ_iff.mp hs')
        · right
          constructor
          · omega
          · exact hs
    have hsum_e : (∑ s ∈ Finset.range σ.length, eF s) =
        (∑ s ∈ Finset.range (t + 1 + j + 1), eF s) +
          ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s := by
      rw [← hunion, Finset.sum_union hdisj]
    have hsum_d : (∑ s ∈ Finset.range σ.length, dF s) =
        (∑ s ∈ Finset.range (t + 1 + j + 1), dF s) +
          ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, dF s := by
      rw [← hunion, Finset.sum_union hdisj]
    -- first part: Σ_{<J+1} eF + 1 ≤ Σ_{<J+1} dF
    have hpart1 : (∑ s ∈ Finset.range (t + 1 + j + 1), eF s) + 1 ≤
        ∑ s ∈ Finset.range (t + 1 + j + 1), dF s := by
      rw [Finset.sum_range_succ]
      rw [Finset.sum_range_succ]
      have heJ : eF (t + 1 + j) = 0 := by
        unfold eF schedFaultAt
        rw [if_pos hgood.1]
      have hdJ : dF (t + 1 + j) = 1 := by
        unfold dF schedFaultAt
        rw [if_neg hgood.2]
      rw [heJ, hdJ]
      have hle : (∑ s ∈ Finset.range (t + 1 + j), eF s) ≤
          ∑ s ∈ Finset.range (t + 1 + j), dF s := by
        exact Finset.sum_le_sum (fun s hs => by
          by_cases hst' : s ≤ t
          · exact le_of_eq (hP0 s hst')
          · have hts' : t < s := by omega
            exact le_of_eq (hP1 s hts' (Finset.mem_range.mp hs)))
      have hle' : (∑ s ∈ Finset.range (t + 1 + j), eF s) + 1 ≤
          (∑ s ∈ Finset.range (t + 1 + j), dF s) + 1 := Nat.add_le_add_right hle 1
      simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hle'
    -- second part: Σ_{[J+1,len)} eF ≤ Σ dF + 1
    have hpart2 : (∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s) ≤
        (∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, dF s) + 1 := by
      have hper : ∀ s ∈ Finset.Ico (t + 1 + j + 1) σ.length,
          eF s ≤ dF s + (if s = t + 1 + j' then 1 else 0) := by
        intro s hs
        have hst' : t < s := by
          have h1 : t + 1 + j + 1 ≤ s := (Finset.mem_Ico.mp hs).1
          exact lt_of_lt_of_le (by omega : t < t + 1 + j + 1) h1
        by_cases hsne : s = t + 1 + j'
        · subst s
          unfold eF dF schedFaultAt
          dsimp [e]
          by_cases hr : σ.getD (t + 1 + j') 0 ∈ schedCache d C₀ σ (t + 1 + j')
          · by_cases hrE : σ.getD (t + 1 + j') 0 ∈ schedCache e C₀ σ (t + 1 + j')
            · rw [if_pos hrE, if_pos hr]
              norm_num
            · rw [if_neg hrE, if_pos hr]
              norm_num
          · by_cases hrE : σ.getD (t + 1 + j') 0 ∈ schedCache e C₀ σ (t + 1 + j')
            · rw [if_pos hrE, if_neg hr]
              norm_num
            · rw [if_neg hrE, if_neg hr]
              norm_num
        · have hle := hP3 s hst' (Finset.mem_Ico.mp hs).2 hsne
          have hif : (if s = t + 1 + j' then 1 else 0) = 0 := if_neg hsne
          rw [hif]
          exact hle
      have hsum1 : (∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s) ≤
          ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length,
            (dF s + (if s = t + 1 + j' then 1 else 0)) := by
        exact Finset.sum_le_sum hper
      have hsum2 : (∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length,
            (dF s + (if s = t + 1 + j' then 1 else 0))) =
          (∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, dF s) +
            ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, (if s = t + 1 + j' then 1 else 0) := by
        rw [Finset.sum_add_distrib]
      have hsum3 : (∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, (if s = t + 1 + j' then 1 else 0)) ≤ 1 := by
        rw [Finset.sum_ite_eq']
        by_cases hJ'in : t + 1 + j' ∈ Finset.Ico (t + 1 + j + 1) σ.length
        · simp [hJ'in]
        · simp [hJ'in]
      rw [hsum2] at hsum1
      exact le_trans hsum1 (Nat.add_le_add_left hsum3 _)
    -- assemble
    unfold schedMisses
    change (∑ s ∈ Finset.range σ.length, eF s) ≤ ∑ s ∈ Finset.range σ.length, dF s
    rw [hsum_e, hsum_d]
    have hboth : (∑ s ∈ Finset.range σ.length, eF s) + 1 ≤
        (∑ s ∈ Finset.range σ.length, dF s) + 1 := by
      rw [hsum_e, hsum_d]
      have h := add_le_add hpart1 hpart2
      simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using h
    omega

The farthest-in-future (Belady) eviction schedule for σ from C₀.

noncomputable def fifoSchedule (σ : List Page) (C₀ : Finset Page) : ℕ → Page :=
  policySchedule (fifoPolicy σ) C₀ σ

d agrees with the farthest-in-future schedule on caches through n.

def agreeWithFIF (d : ℕ → Page) (C₀ : Finset Page) (σ : List Page) (n : ℕ) : Prop :=
  ∀ s ≤ n, schedCache d C₀ σ s = schedCache (fifoSchedule σ C₀) C₀ σ s

The run of the FIF schedule is the run of the FIF policy.

lemma schedCache_fifoSchedule (σ : List Page) (C₀ : Finset Page) (s : ℕ) :
    schedCache (fifoSchedule σ C₀) C₀ σ s = cacheSeq (fifoPolicy σ) C₀ σ s := by
  unfold fifoSchedule
  exact schedCache_policySchedule (fifoPolicy σ) C₀ σ s

When d agrees with the FIF schedule through t, the FIF eviction at t is the farthest-in-future page of d's cache.


lemma fifo_evict_eq_farthest (d : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    {t : ℕ} (hagree : agreeWithFIF d C₀ σ t) :
    (fifoSchedule σ C₀) t = farthestInFuture (schedCache d C₀ σ t) σ t := by
  change farthestInFuture (cacheSeq (fifoPolicy σ) C₀ σ t) σ t =
    farthestInFuture (schedCache d C₀ σ t) σ t
  rw [← schedCache_fifoSchedule σ C₀ t]
  rw [← hagree t le_rfl]

The caches in a run of a reduced schedule from a nonempty cache are nonempty.


lemma schedCache_nonempty_of_reduced (d : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (hC₀ : C₀.Nonempty) (s : ℕ) : (schedCache d C₀ σ s).Nonempty := by
  cases s with
  | zero => exact hC₀
  | succ s =>
      rw [schedCache]
      by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
      · rw [if_pos hr]
        exact ⟨σ.getD s 0, hr⟩
      · rw [if_neg hr]
        exact ⟨σ.getD s 0, Finset.mem_insert_self _ _⟩

At a first disagreement t of a reduced schedule d with the FIF schedule, both fault at t, the evictions differ, and the FIF eviction is resident in d's cache.


lemma first_disagree (d : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (hC₀ : C₀.Nonempty)
    {t : ℕ} (Variable name `ht` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`ht : t < σ.length)
    (hagree : agreeWithFIF d C₀ σ t)
    (hdis : schedCache d C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1)) :
    σ.getD t 0 ∉ schedCache d C₀ σ t ∧
    d t ≠ (fifoSchedule σ C₀) t ∧
    (fifoSchedule σ C₀) t ∈ schedCache d C₀ σ t := by
  have hft : σ.getD t 0 ∉ schedCache d C₀ σ t := by
    intro hft
    have hFt : σ.getD t 0 ∈ schedCache (fifoSchedule σ C₀) C₀ σ t := by
      rw [← hagree t le_rfl]
      exact hft
    have hD : schedCache d C₀ σ (t + 1) = schedCache d C₀ σ t := by
      rw [schedCache]
      rw [if_pos hft]
    have hF : schedCache (fifoSchedule σ C₀) C₀ σ (t + 1) =
        schedCache (fifoSchedule σ C₀) C₀ σ t := by
      rw [schedCache]
      rw [if_pos hFt]
    exact hdis ((hD.trans (hagree t le_rfl)).trans hF.symm)
  constructor
  · exact hft
  · constructor
    · intro hq
      have hFt : σ.getD t 0 ∉ schedCache (fifoSchedule σ C₀) C₀ σ t := by
        rw [← hagree t le_rfl]
        exact hft
      have hD : schedCache d C₀ σ (t + 1) =
          insert (σ.getD t 0) ((schedCache d C₀ σ t).erase (d t)) := by
        rw [schedCache]
        rw [if_neg hft]
      have hF : schedCache (fifoSchedule σ C₀) C₀ σ (t + 1) =
          insert (σ.getD t 0) ((schedCache (fifoSchedule σ C₀) C₀ σ t).erase
            ((fifoSchedule σ C₀) t)) := by
        rw [schedCache]
        rw [if_neg hFt]
      have hEq : schedCache d C₀ σ t = schedCache (fifoSchedule σ C₀) C₀ σ t :=
        hagree t le_rfl
      rw [hD, hF] at hdis
      rw [hEq] at hdis
      rw [hq] at hdis
      exact hdis rfl
    · rw [fifo_evict_eq_farthest d σ C₀ hagree]
      apply mem_farthestInFuture
      exact schedCache_nonempty_of_reduced d σ C₀ hC₀ t

Exchanging the first disagreement of a reduced schedule never increases misses and extends agreement with the FIF schedule by one position.


lemma exchange_step (d : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (hdreduced : ∀ s, σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hC₀ : C₀.Nonempty)
    {t : ℕ} (ht : t < σ.length)
    (hagree : agreeWithFIF d C₀ σ t)
    (hdis : schedCache d C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1)) :
    schedMisses (exchangeSchedule d t (d t) (fifoSchedule σ C₀ t) σ C₀) C₀ σ ≤
      schedMisses d C₀ σ ∧
    agreeWithFIF (exchangeSchedule d t (d t) (fifoSchedule σ C₀ t) σ C₀) C₀ σ (t + 1) := by
  let q : Page := d t
  let q' : Page := fifoSchedule σ C₀ t
  have hfd := first_disagree d σ C₀ hC₀ ht hagree hdis
  have hqq' : q ≠ q' := hfd.2.1
  have hft : σ.getD t 0 ∉ schedCache d C₀ σ t := hfd.1
  have hq'res : q' ∈ schedCache d C₀ σ t := hfd.2.2
  have hfifo : nextUse σ (t + 1) q' = none ∨
      ∃ j j', nextUse σ (t + 1) q = some j ∧ nextUse σ (t + 1) q' = some j' ∧ j < j' := by
    apply fifo_nextUse_order σ (schedCache d C₀ σ t) t q' q
    · exact fifo_evict_eq_farthest d σ C₀ hagree
    · exact hdreduced t hft
    · exact hqq'
  constructor
  · exact exchangeSchedule_misses_le d t q q' σ C₀ rfl hqq'
      (fun s hs hr => hdreduced s hr) hft hq'res hfifo
  · intro s hs
    by_cases hs' : s ≤ t
    · rw [schedCache_exchangeSchedule_eq_d d t q q' σ C₀ hs']
      exact hagree s hs'
    · have hst : s = t + 1 := by omega
      subst s
      have hFt : σ.getD t 0 ∉ schedCache (fifoSchedule σ C₀) C₀ σ t := by
        rw [← hagree t le_rfl]
        exact hft
      have hE : schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ (t + 1) =
          insert (σ.getD t 0) ((schedCache d C₀ σ t).erase q') := by
        rw [schedCache_exchangeScheduleCore, exchangeScheduleCore]
        dsimp
        rw [show (exchangeScheduleCore d t q q' σ C₀ t).1 = schedCache d C₀ σ t by
          rw [← schedCache_exchangeScheduleCore]
          exact schedCache_exchangeSchedule_eq_d d t q q' σ C₀ le_rfl]
        rw [show (exchangeScheduleCore d t q q' σ C₀ t).2 = q' by
          exact exchangeSchedule_at_t d t q q' σ C₀]
        rw [if_neg hft]
      have hF : schedCache (fifoSchedule σ C₀) C₀ σ (t + 1) =
          insert (σ.getD t 0) ((schedCache d C₀ σ t).erase q') := by
        rw [schedCache_fifoSchedule σ C₀ (t + 1)]
        unfold cacheSeq Policy.step
        rw [← schedCache_fifoSchedule σ C₀ t]
        rw [if_neg hFt]
        congr 2
        · rw [← hagree t le_rfl]
        · change farthestInFuture (schedCache (fifoSchedule σ C₀) C₀ σ t) σ t = q'
          rw [← hagree t le_rfl]
          rw [← fifo_evict_eq_farthest d σ C₀ hagree]
      rw [hE, hF]

The exchange schedule is reduced at every fault after the first q' request: from J' on, q' is resident whenever d evicts it, and the multi-set branches always evict resident pages.


lemma exchangeSchedule_reduced_after (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q) (hqq' : q ≠ q')
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    (hq'res : q' ∈ schedCache d C₀ σ t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    (hq'ne : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q')
    {j' : ℕ} (hj' : nextUse σ (t + 1) q' = some j')
    {s : ℕ} (hsJ' : t + 1 + j' < s)
    (hFault : σ.getD s 0 ∉ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s) :
    exchangeSchedule d t q q' σ C₀ s ∈ schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s := by
  let e : ℕ → Page := exchangeSchedule d t q q' σ C₀
  let C' : Finset Page := schedCache e C₀ σ s
  have hC' : C' = (exchangeScheduleCore d t q q' σ C₀ s).1 := by
    unfold C'
    rw [schedCache_exchangeScheduleCore]
  have hFault' : σ.getD s 0 ∉ C' := by
    simpa [C'] using hFault
  have hcard : (schedCache d C₀ σ s).card ≤ C'.card := by
    rw [hC']
    exact exchangeScheduleCore_card d t q q' σ C₀ hweak (by omega)
  -- a request that `d` serves from the cache is `q` or `q'`
  have hsig_in : σ.getD s 0 ∈ schedCache d C₀ σ s → σ.getD s 0 = q' ∨ σ.getD s 0 = q := by
    intro hsigD
    by_contra hnot
    have hinv := exchangeSchedule_invariant d t q q' σ C₀ hq hweak s (by omega)
    have hmem : σ.getD s 0 ∈ C' := by
      simpa [e, C'] using hinv (σ.getD s 0) (by
        intro hmem
        apply hnot
        rcases Finset.mem_insert.mp hmem with hqeq | hq'eq
        · exact Or.inr hqeq
        · exact Or.inl (Finset.mem_singleton.mp hq'eq)) hsigD
    exact hFault' hmem
  -- resident pages of `d` are resident in the exchange cache
  have hq_memD : q ∈ schedCache d C₀ σ s → q ∈ C' := by
    intro hqD
    have hmem := exchangeSchedule_q_mem d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'ne
      s (by omega) hqD
    simpa [e, C'] using hmem
  have hq'_memD : q' ∈ schedCache d C₀ σ s → q' ∈ C' := by
    intro hq'D
    have hmem := exchangeSchedule_q'_mem d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'ne hj'
      s hsJ' hq'D
    simpa [e, C'] using hmem
  -- `d` cannot hit at `s` (the exchange schedule faults there)
  have hdFault : σ.getD s 0 ∉ schedCache d C₀ σ s := by
    intro hdHit
    rcases hsig_in hdHit with hq'eq | hqeq
    · exact hFault' (hq'eq ▸ hq'_memD (hq'eq ▸ hdHit))
    · exact hFault' (hqeq ▸ hq_memD (hqeq ▸ hdHit))
  -- branch analysis of the exchange decision
  change (exchangeScheduleCore d t q q' σ C₀ s).2 ∈
    schedCache (exchangeSchedule d t q q' σ C₀) C₀ σ s
  rw [exchangeScheduleCore_second]
  rw [← hC']
  change exchangeDecision d t q q' σ C₀ C' s ∈ C'
  unfold exchangeDecision
  have hlt : ¬ s < t := by omega
  have hne : ¬ s = t := by omega
  rw [if_neg hlt, if_neg hne]
  by_cases h1 : d s = q'
  · rw [if_pos h1]
    -- d faults at s, so q' ∈ D(s), hence q' ∈ E(s)
    have hq'inD : q' ∈ schedCache d C₀ σ s := by
      have hd : d s ∈ schedCache d C₀ σ s := hweak s (by omega) hdFault
      rwa [h1] at hd
    exact hq'_memD hq'inD
  · rw [if_neg h1]
    by_cases hb4 : (σ.getD s 0 = q' ∨ σ.getD s 0 = q) ∧
        σ.getD s 0 ∈ schedCache d C₀ σ s
    · rw [if_pos hb4]
      by_cases hf : ((C' \ schedCache d C₀ σ s).filter (fun x => x ≠ q')).Nonempty
      · rw [dif_pos hf]
        have hspec := Classical.choose_spec hf
        exact (Finset.mem_sdiff.mp (Finset.mem_filter.mp hspec).1).1
      · rw [dif_neg hf]
        by_cases hm : (C' \ schedCache d C₀ σ s).Nonempty
        · rw [dif_pos hm]
          exact (Finset.mem_sdiff.mp (Classical.choose_spec hm)).1
        · rw [dif_neg hm]
          exfalso
          have hsub : C' ⊆ schedCache d C₀ σ s := by
            intro y hy
            by_contra hyn
            exact hm ⟨y, Finset.mem_sdiff.mpr ⟨hy, hyn⟩⟩
          have hEq : C' = schedCache d C₀ σ s :=
            Finset.eq_of_subset_of_card_le hsub hcard
          exact hFault' (hEq ▸ hb4.2)
    · rw [if_neg hb4]
      by_cases h5 : d s ∈ C'
      · rw [if_pos h5]
        exact h5
      · rw [if_neg h5]
        by_cases hm : (C' \ schedCache d C₀ σ s).Nonempty
        · rw [dif_pos hm]
          exact (Finset.mem_sdiff.mp (Classical.choose_spec hm)).1
        · rw [dif_neg hm]
          exfalso
          have hsub : C' ⊆ schedCache d C₀ σ s := by
            intro y hy
            by_contra hyn
            exact hm ⟨y, Finset.mem_sdiff.mpr ⟨hy, hyn⟩⟩
          have hEq : C' = schedCache d C₀ σ s :=
            Finset.eq_of_subset_of_card_le hsub hcard
          exact h5 (hEq ▸ hweak s (by omega) hdFault)

The exchange has a spare miss when the bad event did not occur: either q' is never requested again and q is, or d evicts q' before its first request (so d misses there too).


lemma exchangeSchedule_misses_le_plus_one (d : ℕ → Page) (t : ℕ) (q q' : Page)
    (σ : List Page) (C₀ : Finset Page)
    (hq : d t = q) (hqq' : q ≠ q')
    (hweak : ∀ s, t ≤ s → σ.getD s 0 ∉ schedCache d C₀ σ s → d s ∈ schedCache d C₀ σ s)
    (hft : σ.getD t 0 ∉ schedCache d C₀ σ t)
    (hq'res : q' ∈ schedCache d C₀ σ t)
    (hslack : (nextUse σ (t + 1) q' = none ∧ ∃ j, nextUse σ (t + 1) q = some j) ∨
      ∃ j j', nextUse σ (t + 1) q = some j ∧ nextUse σ (t + 1) q' = some j' ∧ j < j' ∧
        σ.getD (t + 1 + j') 0 ∉ schedCache d C₀ σ (t + 1 + j')) :
    schedMisses (exchangeSchedule d t q q' σ C₀) C₀ σ + 1 ≤ schedMisses d C₀ σ := by
  let e : ℕ → Page := exchangeSchedule d t q q' σ C₀
  let eF : ℕ → ℕ := schedFaultAt e C₀ σ
  let dF : ℕ → ℕ := schedFaultAt d C₀ σ
  rcases hslack with ⟨hnone, hqreq⟩ | ⟨j, j', hj, hj', hjlt, hnoBad⟩
  · -- CASE A: `q'` is never requested again
    have hq'ne_s : ∀ s, t + 1 ≤ s → s < σ.length → σ.getD s 0 ≠ q' := by
      intro s hs hlen
      have hnone' := nextUse_eq_none_iff.mp hnone
      apply hnone' (σ.getD s 0)
      have hget : (σ.drop (t + 1)).getD (s - (t + 1)) 0 = σ.getD s 0 := by
        rw [getD_drop]
        rw [Nat.add_sub_of_le hs]
      rw [← hget]
      have hlt' : s - (t + 1) < (σ.drop (t + 1)).length := by
        rw [List.length_drop]
        omega
      rw [List.getD_eq_getElem _ 0 hlt']
      exact List.getElem_mem hlt'
    rcases hqreq with ⟨j, hj⟩
    have hJlen : t + 1 + j < σ.length := by
      have hjlt' : j < (σ.drop (t + 1)).length := (nextUse_eq_some_iff.mp hj).1
      rw [List.length_drop] at hjlt'
      omega
    have hJle : t + 1 + j + 1 ≤ σ.length := by omega
    have hq'neA : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q' := by
      intro k hk1 hk2
      exact hq'ne_s k hk1 (by omega)
    -- pointwise: fault equal for s ≤ t
    have hP0 : ∀ s, s ≤ t → eF s = dF s := by
      intro s hs
      unfold eF dF e schedFaultAt
      rw [schedCache_exchangeSchedule_eq_d d t q q' σ C₀ hs]
    -- pointwise: fault equal for t < s < J (window)
    have hP1 : ∀ s, t < s → s < t + 1 + j → eF s = dF s := by
      intro s hst hsJ
      unfold eF dF e schedFaultAt
      rw [exchangeSchedule_window d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neA
        (s := s) hst (by omega)]
      have hne1 : σ.getD s 0 ≠ q := getD_ne_nextUse hj (by omega) hsJ
      have hne2 : σ.getD s 0 ≠ q' := hq'neA s (by omega) hsJ
      by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
      · rw [if_pos hr]
        have hrE' : σ.getD s 0 ∈ insert q ((schedCache d C₀ σ s).erase q') := by
          rw [Finset.mem_insert]
          right
          rw [Finset.mem_erase]
          constructor
          · exact hne2
          · exact hr
        rw [if_pos hrE']
      · rw [if_neg hr]
        have hrE' : σ.getD s 0 ∉ insert q ((schedCache d C₀ σ s).erase q') := by
          intro hm
          rcases Finset.mem_insert.mp hm with hqeq | hmem
          · exact hne1 hqeq
          · exact hr (Finset.mem_erase.mp hmem).2
        rw [if_neg hrE']
    -- pointwise: eF ≤ dF for J < s (no bad event)
    have hP3A : ∀ s, t < s → s < σ.length → eF s ≤ dF s := by
      intro s hst hlen
      unfold eF dF e schedFaultAt
      by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
      · by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
        · rw [if_pos hrE, if_pos hr]
        · rw [if_neg hrE, if_pos hr]
          exfalso
          have hqqq' : σ.getD s 0 = q' ∨ σ.getD s 0 = q := by
            by_contra hnot
            have hinv := exchangeSchedule_invariant d t q q' σ C₀ hq hweak s (by omega)
            exact hrE (hinv (σ.getD s 0) (by
              intro hmem2
              apply hnot
              rcases Finset.mem_insert.mp hmem2 with hqeq | hq'eq
              · exact Or.inr hqeq
              · exact Or.inl (Finset.mem_singleton.mp hq'eq)) hr)
          rcases hqqq' with hq'eq | hqeq
          · exact hq'ne_s s (by omega) hlen hq'eq
          · have hqE : q ∈ schedCache e C₀ σ s := by
              exact exchangeSchedule_q_mem d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neA
                s hst (hqeq ▸ hr)
            exact hrE (hqeq ▸ hqE)
      · rw [if_neg hr]
        by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
        · rw [if_pos hrE]
          omega
        · rw [if_neg hrE]
    -- good event at J
    have hgood := exchangeSchedule_good d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neA
    -- split the sum
    have hdisj : Disjoint (Finset.range (t + 1 + j + 1))
        (Finset.Ico (t + 1 + j + 1) σ.length) := by
      rw [Finset.disjoint_left]
      intro s hs1 hs2
      have h1 : s < t + 1 + j + 1 := Finset.mem_range.mp hs1
      have h2 : t + 1 + j + 1 ≤ s := (Finset.mem_Ico.mp hs2).1
      omega
    have hunion : Finset.range (t + 1 + j + 1) ∪ Finset.Ico (t + 1 + j + 1) σ.length =
        Finset.range σ.length := by
      ext s
      simp [Finset.mem_Ico]
      constructor
      · intro h
        rcases h with hs | ⟨h1, h2⟩
        · omega
        · exact h2
      · intro hs
        by_cases hs' : s < t + 1 + j + 1
        · exact Or.inl (Nat.lt_succ_iff.mp hs')
        · right
          constructor
          · omega
          · exact hs
    have hsum_e : (∑ s ∈ Finset.range σ.length, eF s) =
        (∑ s ∈ Finset.range (t + 1 + j + 1), eF s) +
          ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s := by
      rw [← hunion, Finset.sum_union hdisj]
    have hsum_d : (∑ s ∈ Finset.range σ.length, dF s) =
        (∑ s ∈ Finset.range (t + 1 + j + 1), dF s) +
          ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, dF s := by
      rw [← hunion, Finset.sum_union hdisj]
    -- first part: Σ_{<J+1} eF + 1 ≤ Σ_{<J+1} dF
    have hpart1 : (∑ s ∈ Finset.range (t + 1 + j + 1), eF s) + 1 ≤
        ∑ s ∈ Finset.range (t + 1 + j + 1), dF s := by
      rw [Finset.sum_range_succ]
      rw [Finset.sum_range_succ]
      have heJ : eF (t + 1 + j) = 0 := by
        unfold eF schedFaultAt
        rw [if_pos hgood.1]
      have hdJ : dF (t + 1 + j) = 1 := by
        unfold dF schedFaultAt
        rw [if_neg hgood.2]
      rw [heJ, hdJ]
      have hle : (∑ s ∈ Finset.range (t + 1 + j), eF s) ≤
          ∑ s ∈ Finset.range (t + 1 + j), dF s := by
        exact Finset.sum_le_sum (fun s hs => by
          by_cases hst' : s ≤ t
          · exact le_of_eq (hP0 s hst')
          · have hts' : t < s := by omega
            exact le_of_eq (hP1 s hts' (Finset.mem_range.mp hs)))
      have hle' : (∑ s ∈ Finset.range (t + 1 + j), eF s) + 1 ≤
          (∑ s ∈ Finset.range (t + 1 + j), dF s) + 1 := Nat.add_le_add_right hle 1
      simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hle'
    -- second part: Σ_{[J+1,len)} eF ≤ Σ dF
    have hpart2 : (∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s) ≤
        ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, dF s := by
      apply Finset.sum_le_sum
      intro s hs
      have hst' : t < s := by
        have h1 : t + 1 + j + 1 ≤ s := (Finset.mem_Ico.mp hs).1
        omega
      exact hP3A s hst' (Finset.mem_Ico.mp hs).2
    -- assemble
    unfold schedMisses
    change (∑ s ∈ Finset.range σ.length, eF s) + 1 ≤ ∑ s ∈ Finset.range σ.length, dF s
    rw [hsum_e, hsum_d]
    have h := add_le_add hpart1 hpart2
    simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using h

  · -- CASE B: the first request of `q` comes before the first request of `q'`
    have hJlen : t + 1 + j < σ.length := by
      have hjlt' : j < (σ.drop (t + 1)).length := (nextUse_eq_some_iff.mp hj).1
      rw [List.length_drop] at hjlt'
      omega
    have hJ'len : t + 1 + j' < σ.length := by
      have hj'lt' : j' < (σ.drop (t + 1)).length := (nextUse_eq_some_iff.mp hj').1
      rw [List.length_drop] at hj'lt'
      omega
    have hJle : t + 1 + j + 1 ≤ σ.length := by omega
    have hJ'le : t + 1 + j' + 1 ≤ σ.length := by omega
    have hJJ' : t + 1 + j + 1 ≤ t + 1 + j' := by omega
    have hq'neB : ∀ k, t + 1 ≤ k → k < t + 1 + j → σ.getD k 0 ≠ q' := by
      intro k hk1 hk2
      exact getD_ne_nextUse hj' hk1 (by omega)
    -- pointwise: fault equal for s ≤ t
    have hP0 : ∀ s, s ≤ t → eF s = dF s := by
      intro s hs
      unfold eF dF e schedFaultAt
      rw [schedCache_exchangeSchedule_eq_d d t q q' σ C₀ hs]
    -- pointwise: fault equal for t < s < J (window)
    have hP1 : ∀ s, t < s → s < t + 1 + j → eF s = dF s := by
      intro s hst hsJ
      unfold eF dF e schedFaultAt
      rw [exchangeSchedule_window d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neB
        (s := s) hst (by omega)]
      have hne1 : σ.getD s 0 ≠ q := getD_ne_nextUse hj (by omega) hsJ
      have hne2 : σ.getD s 0 ≠ q' := hq'neB s (by omega) hsJ
      by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
      · rw [if_pos hr]
        have hrE' : σ.getD s 0 ∈ insert q ((schedCache d C₀ σ s).erase q') := by
          rw [Finset.mem_insert]
          right
          rw [Finset.mem_erase]
          constructor
          · exact hne2
          · exact hr
        rw [if_pos hrE']
      · rw [if_neg hr]
        have hrE' : σ.getD s 0 ∉ insert q ((schedCache d C₀ σ s).erase q') := by
          intro hm
          rcases Finset.mem_insert.mp hm with hqeq | hmem
          · exact hne1 hqeq
          · exact hr (Finset.mem_erase.mp hmem).2
        rw [if_neg hrE']
    -- pointwise: eF ≤ dF for s ≠ J' (the bad event only at J')
    have hP3 : ∀ s, t < s → s < σ.length → s ≠ t + 1 + j' → eF s ≤ dF s := by
      intro s hst hlen hsne
      unfold eF dF e schedFaultAt
      by_cases hr : σ.getD s 0 ∈ schedCache d C₀ σ s
      · by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
        · rw [if_pos hrE, if_pos hr]
        · rw [if_neg hrE, if_pos hr]
          exfalso
          exact hsne (exchangeSchedule_bad d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neB hj'
            hst hr hrE)
      · rw [if_neg hr]
        by_cases hrE : σ.getD s 0 ∈ schedCache e C₀ σ s
        · rw [if_pos hrE]
          omega
        · rw [if_neg hrE]
    -- good event at J
    have hgood := exchangeSchedule_good d t q q' σ C₀ hq hqq' hweak hft hq'res hj hq'neB
    -- split the sum
    have hdisj : Disjoint (Finset.range (t + 1 + j + 1))
        (Finset.Ico (t + 1 + j + 1) σ.length) := by
      rw [Finset.disjoint_left]
      intro s hs1 hs2
      have h1 : s < t + 1 + j + 1 := Finset.mem_range.mp hs1
      have h2 : t + 1 + j + 1 ≤ s := (Finset.mem_Ico.mp hs2).1
      omega
    have hunion : Finset.range (t + 1 + j + 1) ∪ Finset.Ico (t + 1 + j + 1) σ.length =
        Finset.range σ.length := by
      ext s
      simp [Finset.mem_Ico]
      constructor
      · intro h
        rcases h with hs | ⟨h1, h2⟩
        · omega
        · exact h2
      · intro hs
        by_cases hs' : s < t + 1 + j + 1
        · exact Or.inl (Nat.lt_succ_iff.mp hs')
        · right
          constructor
          · omega
          · exact hs
    have hsum_e : (∑ s ∈ Finset.range σ.length, eF s) =
        (∑ s ∈ Finset.range (t + 1 + j + 1), eF s) +
          ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s := by
      rw [← hunion, Finset.sum_union hdisj]
    have hsum_d : (∑ s ∈ Finset.range σ.length, dF s) =
        (∑ s ∈ Finset.range (t + 1 + j + 1), dF s) +
          ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, dF s := by
      rw [← hunion, Finset.sum_union hdisj]
    -- first part: Σ_{<J+1} eF + 1 ≤ Σ_{<J+1} dF
    have hpart1 : (∑ s ∈ Finset.range (t + 1 + j + 1), eF s) + 1 ≤
        ∑ s ∈ Finset.range (t + 1 + j + 1), dF s := by
      rw [Finset.sum_range_succ]
      rw [Finset.sum_range_succ]
      have heJ : eF (t + 1 + j) = 0 := by
        unfold eF schedFaultAt
        rw [if_pos hgood.1]
      have hdJ : dF (t + 1 + j) = 1 := by
        unfold dF schedFaultAt
        rw [if_neg hgood.2]
      rw [heJ, hdJ]
      have hle : (∑ s ∈ Finset.range (t + 1 + j), eF s) ≤
          ∑ s ∈ Finset.range (t + 1 + j), dF s := by
        exact Finset.sum_le_sum (fun s hs => by
          by_cases hst' : s ≤ t
          · exact le_of_eq (hP0 s hst')
          · have hts' : t < s := by omega
            exact le_of_eq (hP1 s hts' (Finset.mem_range.mp hs)))
      have hle' : (∑ s ∈ Finset.range (t + 1 + j), eF s) + 1 ≤
          (∑ s ∈ Finset.range (t + 1 + j), dF s) + 1 := Nat.add_le_add_right hle 1
      simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hle'
    -- second part: Σ_{[J+1,len)} eF ≤ Σ dF + 1
    have hpart2 : (∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s) ≤
        ∑ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, dF s := by
      have hper : ∀ s ∈ Finset.Ico (t + 1 + j + 1) σ.length, eF s ≤ dF s := by
        intro s hs
        have hst' : t < s := by
          have h1 : t + 1 + j + 1 ≤ s := (Finset.mem_Ico.mp hs).1
          exact lt_of_lt_of_le (by omega : t < t + 1 + j + 1) h1
        by_cases hsne : s = t + 1 + j'
        · subst s
          unfold eF dF schedFaultAt
          dsimp [e]
          have hsig : σ.getD (t + 1 + j') 0 = q' := getD_eq_nextUse hj'
          have hnotE : σ.getD (t + 1 + j') 0 ∉ schedCache e C₀ σ (t + 1 + j') := by
            rw [hsig]
            apply exchangeSchedule_q'_absent d t q q' σ C₀ hweak hft hq'res hj'
            · omega
            · rfl
          rw [if_neg hnotE]
          rw [if_neg hnoBad]
        · exact hP3 s hst' (Finset.mem_Ico.mp hs).2 hsne
      exact Finset.sum_le_sum hper
    -- assemble
    unfold schedMisses
    change (∑ s ∈ Finset.range σ.length, eF s) + 1 ≤ ∑ s ∈ Finset.range σ.length, dF s
    rw [hsum_e, hsum_d]
    have h := add_le_add hpart1 hpart2
    simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using h

The repair schedule: agrees with e everywhere except it evicts q' at t and at nop (the first q' request; the second eviction is a no-op that makes the cache coincide with e's afterwards).

noncomputable def repairSchedule (e : ℕ → Page) (t : ℕ) (q' : Page) (nop : ℕ) : ℕ → Page :=
  fun s => if s = t ∨ s = nop then q' else e s

The repair schedule evicts q' at t.

lemma repairSchedule_at_t (e : ℕ → Page) (t : ℕ) (q' : Page) (nop : ℕ) :
    repairSchedule e t q' nop t = q' := by
  unfold repairSchedule
  simp

The repair schedule's cache agrees with e's up to t.


lemma schedCache_repairSchedule_eq_e (e : ℕ → Page) (t : ℕ) (q' : Page) (nop : ℕ)
    (htn : t < nop) (σ : List Page) (C₀ : Finset Page) {s : ℕ} (hs : s ≤ t) :
    schedCache (repairSchedule e t q' nop) C₀ σ s = schedCache e C₀ σ s := by
  induction s with
  | zero => rfl
  | succ s ih =>
      rw [schedCache, schedCache]
      rw [ih (by omega)]
      unfold repairSchedule
      simp [show s ≠ t by omega, show s ≠ nop by omega]

The repair's cache just after t is e's cache with q' removed.


lemma repairSchedule_base (e : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (hC₀ : C₀.Nonempty)
    {t : ℕ} (ht : t < σ.length)
    (hagree : agreeWithFIF e C₀ σ t)
    (hdis : schedCache e C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1))
    (hnoop : e t ∉ schedCache e C₀ σ t)
    (hq' : q' = fifoSchedule σ C₀ t)
    {j' : ℕ} (Variable name `hj'` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hj' : nextUse σ (t + 1) q' = some j') :
    schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (t + 1) =
      (schedCache e C₀ σ (t + 1)).erase q' := by
  have hft : σ.getD t 0 ∉ schedCache e C₀ σ t := by
    intro hft
    have hFt : σ.getD t 0 ∈ schedCache (fifoSchedule σ C₀) C₀ σ t := by
      rw [← hagree t le_rfl]
      exact hft
    have hD : schedCache e C₀ σ (t + 1) = schedCache e C₀ σ t := by
      rw [schedCache]
      rw [if_pos hft]
    have hF : schedCache (fifoSchedule σ C₀) C₀ σ (t + 1) =
        schedCache (fifoSchedule σ C₀) C₀ σ t := by
      rw [schedCache]
      rw [if_pos hFt]
    exact hdis ((hD.trans (hagree t le_rfl)).trans hF.symm)
  have hq'res : q' ∈ schedCache e C₀ σ t := by
    have hfd := first_disagree e σ C₀ hC₀ ht hagree hdis
    rw [hq']
    exact hfd.2.2
  have hsig_ne : σ.getD t 0 ≠ q' := by
    intro hsig
    exact hft (hsig ▸ hq'res)
  rw [schedCache]
  rw [schedCache_repairSchedule_eq_e e t q' (t + 1 + j') (by omega) σ C₀ le_rfl]
  rw [repairSchedule_at_t]
  rw [if_neg hft]
  rw [schedCache]
  rw [if_neg hft]
  rw [Finset.erase_eq_of_notMem hnoop]
  rw [Finset.erase_insert_of_ne hsig_ne]

The repair's cache step inside the window.


lemma repairSchedule_step (e : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (Variable name `hC₀` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hC₀ : C₀.Nonempty)
    {t : ℕ} (Variable name `ht` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`ht : t < σ.length)
    (Variable name `hagree` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hagree : agreeWithFIF e C₀ σ t)
    (Variable name `hdis` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hdis : schedCache e C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1))
    (Variable name `hnoop` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hnoop : e t ∉ schedCache e C₀ σ t)
    (Variable name `hq'` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hq' : q' = fifoSchedule σ C₀ t)
    {j' : ℕ} (hj' : nextUse σ (t + 1) q' = some j')
    (s : ℕ) (ih : t < s → s ≤ t + 1 + j' →
      schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s =
        (schedCache e C₀ σ s).erase q')
    (hts : t < s) (hsJ' : s < t + 1 + j') :
    schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (s + 1) =
      (schedCache e C₀ σ (s + 1)).erase q' := by
  have hsig_ne_q' : σ.getD s 0 ≠ q' := getD_ne_nextUse (k := s) hj' (by omega) hsJ'
  have hds : repairSchedule e t q' (t + 1 + j') s = e s := by
    unfold repairSchedule
    simp [show s ≠ t by omega, show s ≠ t + 1 + j' by omega]
  change (if σ.getD s 0 ∈ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s then
      schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s
    else insert (σ.getD s 0) ((schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s).erase
      (repairSchedule e t q' (t + 1 + j') s))) =
    (if σ.getD s 0 ∈ schedCache e C₀ σ s then schedCache e C₀ σ s
      else insert (σ.getD s 0) ((schedCache e C₀ σ s).erase (e s))).erase q'
  rw [hds]
  rw [ih hts (by omega)]
  by_cases hr : σ.getD s 0 ∈ schedCache e C₀ σ s
  · have hr' : σ.getD s 0 ∈ (schedCache e C₀ σ s).erase q' := by
      rw [Finset.mem_erase]
      constructor
      · exact hsig_ne_q'
      · exact hr
    rw [if_pos hr, if_pos hr']
  · rw [if_neg hr]
    have hr' : σ.getD s 0 ∉ (schedCache e C₀ σ s).erase q' := by
      intro hm
      exact hr (Finset.mem_erase.mp hm).2
    rw [if_neg hr']
    rw [Finset.erase_insert_of_ne hsig_ne_q']
    have herase_comm : ((schedCache e C₀ σ s).erase q').erase (e s) =
        ((schedCache e C₀ σ s).erase (e s)).erase q' := by
      ext x
      simp [Finset.mem_erase, and_left_comm, This simp argument is unused:
  and_assoc

Hint: Omit it from the simp argument list.
  simp [Finset.mem_erase, and_left_comm,̵ ̵a̵n̵d̵_̵a̵s̵s̵o̵c̵]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`and_assoc]
    rw [herase_comm]

In the window (t, J'], the repair schedule's cache is e's cache with q' removed.

lemma repairSchedule_window (e : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (hC₀ : C₀.Nonempty)
    {t : ℕ} (ht : t < σ.length)
    (hagree : agreeWithFIF e C₀ σ t)
    (hdis : schedCache e C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1))
    (hnoop : e t ∉ schedCache e C₀ σ t)
    (hq' : q' = fifoSchedule σ C₀ t)
    {j' : ℕ} (hj' : nextUse σ (t + 1) q' = some j')
    {s : ℕ} (hs1 : t < s) (hs2 : s ≤ t + 1 + j') :
    schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s =
      (schedCache e C₀ σ s).erase q' := by
  induction s with
  | zero => omega
  | succ s ih =>
      by_cases hs_eq : s = t
      · subst s
        exact repairSchedule_base e σ C₀ hC₀ ht hagree hdis hnoop hq' hj'
      · exact repairSchedule_step e σ C₀ hC₀ ht hagree hdis hnoop hq' hj' s ih
          (by omega) (by omega)

After the first q' request, the repair's cache contains e's.


lemma repairSchedule_superset (e : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (hC₀ : C₀.Nonempty)
    {t : ℕ} (ht : t < σ.length)
    (hagree : agreeWithFIF e C₀ σ t)
    (hdis : schedCache e C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1))
    (hnoop : e t ∉ schedCache e C₀ σ t)
    (hq' : q' = fifoSchedule σ C₀ t)
    {j' : ℕ} (hj' : nextUse σ (t + 1) q' = some j')
    {s : ℕ} (hs : t + 1 + j' < s) :
    schedCache e C₀ σ s ⊆ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s := by
  induction s with
  | zero => omega
  | succ s ih =>
      by_cases hs_eq : s = t + 1 + j'
      · subst s
        -- base: the repair evicts q' at J' (a no-op) and reloads it
        have hwin : schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (t + 1 + j') =
            (schedCache e C₀ σ (t + 1 + j')).erase q' := by
          exact repairSchedule_window e σ C₀ hC₀ ht hagree hdis hnoop hq' hj'
            (by omega) (by rfl)
        have hsig : (σ[t + 1 + j']?).getD 0 = q' := by
          simpa using getD_eq_nextUse hj'
        have hq'notE : q' ∉ (schedCache e C₀ σ (t + 1 + j')).erase q' := by
          intro hm
          exact (Finset.mem_erase.mp hm).1 rfl
        change (if σ.getD (t + 1 + j') 0 ∈ schedCache e C₀ σ (t + 1 + j') then
            schedCache e C₀ σ (t + 1 + j')
          else insert (σ.getD (t + 1 + j') 0)
            ((schedCache e C₀ σ (t + 1 + j')).erase (e (t + 1 + j')))) ⊆
          (if σ.getD (t + 1 + j') 0 ∈ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (t + 1 + j')
            then schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (t + 1 + j')
          else insert (σ.getD (t + 1 + j') 0)
            ((schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (t + 1 + j')).erase
              (repairSchedule e t q' (t + 1 + j') (t + 1 + j'))))
        rw [hwin]
        unfold repairSchedule
        simp [show t + 1 + j' ≠ t by omega]
        simp [hsig]
        intro x hx
        by_cases hr : q' ∈ schedCache e C₀ σ (t + 1 + j')
        · rw [if_pos hr] at hx
          rw [Finset.mem_insert]
          by_cases hxq' : x = q'
          · left
            exact hxq'
          · right
            rw [Finset.mem_erase]
            constructor
            · exact hxq'
            · exact hx
        · rw [if_neg hr] at hx
          rcases Finset.mem_insert.mp hx with hxq' | hxin
          · rw [hxq']
            rw [Finset.mem_insert]
            left
            rfl
          · have hxin' : x ∈ (schedCache e C₀ σ (t + 1 + j')).erase (e (t + 1 + j')) :=
              hxin
            have hxE : x ∈ schedCache e C₀ σ (t + 1 + j') := (Finset.mem_erase.mp hxin').2
            have hxne_q' : x ≠ q' := by
              intro hxq'
              exact hr (hxq' ▸ hxE)
            rw [Finset.mem_insert]
            right
            rw [Finset.mem_erase]
            constructor
            · exact hxne_q'
            · exact hxE
      · -- step: s > J'
        have hsJ' : t + 1 + j' < s := by omega
        have ih' := ih hsJ'
        have hds : repairSchedule e t q' (t + 1 + j') s = e s := by
          unfold repairSchedule
          simp [show s ≠ t by omega, show s ≠ t + 1 + j' by omega]
        change (if σ.getD s 0 ∈ schedCache e C₀ σ s then schedCache e C₀ σ s
            else insert (σ.getD s 0) ((schedCache e C₀ σ s).erase (e s))) ⊆
          (if σ.getD s 0 ∈ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s then
              schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s
            else insert (σ.getD s 0) ((schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s).erase
              (repairSchedule e t q' (t + 1 + j') s)))
        rw [hds]
        intro x hx
        by_cases hr : σ.getD s 0 ∈ schedCache e C₀ σ s
        · rw [if_pos hr] at hx
          rw [if_pos (ih' hr)]
          exact ih' hx
        · rw [if_neg hr] at hx
          rcases Finset.mem_insert.mp hx with hxr | hxin
          · subst x
            by_cases hrE : σ.getD s 0 ∈
                schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s
            · rw [if_pos hrE]
              exact hrE
            · rw [if_neg hrE]
              rw [Finset.mem_insert]
              left
              rfl
          · have hxE : x ∈ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s :=
              ih' (Finset.mem_erase.mp hxin).2
            have hxne : x ≠ e s := (Finset.mem_erase.mp hxin).1
            by_cases hrE : σ.getD s 0 ∈
                schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s
            · rw [if_pos hrE]
              exact hxE
            · rw [if_neg hrE]
              rw [Finset.mem_insert]
              right
              rw [Finset.mem_erase]
              constructor
              · exact hxne
              · exact hxE




lemma repair_step (e : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (hC₀ : C₀.Nonempty)
    {t : ℕ} (ht : t < σ.length)
    (hagree : agreeWithFIF e C₀ σ t)
    (hdis : schedCache e C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1))
    (hnoop : e t ∉ schedCache e C₀ σ t)
    {j' : ℕ} (hj' : nextUse σ (t + 1) (fifoSchedule σ C₀ t) = some j') :
    schedMisses (repairSchedule e t (fifoSchedule σ C₀ t) (t + 1 + j')) C₀ σ ≤
      schedMisses e C₀ σ + 1 ∧
    agreeWithFIF (repairSchedule e t (fifoSchedule σ C₀ t) (t + 1 + j')) C₀ σ (t + 1) := by
  let q' : Page := fifoSchedule σ C₀ t
  let r : ℕ → Page := repairSchedule e t q' (t + 1 + j')
  let eF : ℕ → ℕ := schedFaultAt e C₀ σ
  let rF : ℕ → ℕ := schedFaultAt r C₀ σ
  have hft : σ.getD t 0 ∉ schedCache e C₀ σ t := by
    intro hft
    have hFt : σ.getD t 0 ∈ schedCache (fifoSchedule σ C₀) C₀ σ t := by
      rw [← hagree t le_rfl]
      exact hft
    have hD : schedCache e C₀ σ (t + 1) = schedCache e C₀ σ t := by
      rw [schedCache]
      rw [if_pos hft]
    have hF : schedCache (fifoSchedule σ C₀) C₀ σ (t + 1) =
        schedCache (fifoSchedule σ C₀) C₀ σ t := by
      rw [schedCache]
      rw [if_pos hFt]
    exact hdis ((hD.trans (hagree t le_rfl)).trans hF.symm)
  have hq'res : q' ∈ schedCache e C₀ σ t := by
    have hfd := first_disagree e σ C₀ hC₀ ht hagree hdis
    exact hfd.2.2
  have hsig_ne : σ.getD t 0 ≠ q' := by
    intro hsig
    exact hft (hsig ▸ hq'res)
  have hJ'len : t + 1 + j' < σ.length := by
    have hj'lt' : j' < (σ.drop (t + 1)).length := (nextUse_eq_some_iff.mp hj').1
    rw [List.length_drop] at hj'lt'
    omega
  constructor
  · -- misses: rF ≤ eF + 1 pointwise
    have hper : ∀ s, s < σ.length → rF s ≤ eF s + (if s = t + 1 + j' then 1 else 0) := by
      intro s hlen
      by_cases hst : s ≤ t
      · unfold rF eF r schedFaultAt
        rw [schedCache_repairSchedule_eq_e e t q' (t + 1 + j') (by omega) σ C₀ hst]
        rw [show (if s = t + 1 + j' then 1 else 0) = 0 by
          simp [show s ≠ t + 1 + j' by omega]]
        omega
      · have hts' : t < s := by omega
        by_cases hsJ' : s < t + 1 + j'
        · -- in the window: faults coincide
          have hwin : schedCache r C₀ σ s = (schedCache e C₀ σ s).erase q' := by
            exact repairSchedule_window e σ C₀ hC₀ ht hagree hdis hnoop rfl hj' hts' (by omega)
          unfold rF eF r schedFaultAt
          rw [hwin]
          have hneq : σ.getD s 0 ≠ q' := getD_ne_nextUse (k := s) hj' (by omega) hsJ'
          by_cases hr : σ.getD s 0 ∈ schedCache e C₀ σ s
          · rw [if_pos hr]
            have hr' : σ.getD s 0 ∈ (schedCache e C₀ σ s).erase q' := by
              rw [Finset.mem_erase]
              constructor
              · exact hneq
              · exact hr
            rw [if_pos hr']
            rw [show (if s = t + 1 + j' then 1 else 0) = 0 by
              simp [show s ≠ t + 1 + j' by omega]]
          · rw [if_neg hr]
            have hr' : σ.getD s 0 ∉ (schedCache e C₀ σ s).erase q' := by
              intro hm
              exact hr (Finset.mem_erase.mp hm).2
            rw [if_neg hr']
            rw [show (if s = t + 1 + j' then 1 else 0) = 0 by
              simp [show s ≠ t + 1 + j' by omega]]
        · -- s ≥ J'
          by_cases hseq : s = t + 1 + j'
          · subst s
            -- at J': r faults
            unfold rF eF r schedFaultAt
            have hwin : schedCache r C₀ σ (t + 1 + j') =
                (schedCache e C₀ σ (t + 1 + j')).erase q' := by
              exact repairSchedule_window e σ C₀ hC₀ ht hagree hdis hnoop rfl hj'
                (by omega) (by rfl)
            rw [hwin]
            have hsig : σ.getD (t + 1 + j') 0 = q' := getD_eq_nextUse hj'
            have hq'notE : q' ∉ (schedCache e C₀ σ (t + 1 + j')).erase q' := by
              intro hm
              exact (Finset.mem_erase.mp hm).1 rfl
            rw [hsig]
            rw [if_neg hq'notE]
            have hind : (if t + 1 + j' = t + 1 + j' then 1 else 0) = 1 := by simp
            rw [hind]
            by_cases hr : q' ∈ schedCache e C₀ σ (t + 1 + j')
            · rw [if_pos hr]
            · rw [if_neg hr]
              omega
          · -- s > J': E ⊆ Ê
            have hsJ''' : t + 1 + j' < s := by omega
            have hsup : schedCache e C₀ σ s ⊆ schedCache r C₀ σ s := by
              exact repairSchedule_superset e σ C₀ hC₀ ht hagree hdis hnoop rfl hj' hsJ'''
            unfold rF eF r schedFaultAt
            by_cases hr : σ.getD s 0 ∈ schedCache e C₀ σ s
            · rw [if_pos hr]
              rw [if_pos (hsup hr)]
              rw [show (if s = t + 1 + j' then 1 else 0) = 0 by
                simp [show s ≠ t + 1 + j' by omega]]
            · rw [if_neg hr]
              by_cases hr' : σ.getD s 0 ∈ schedCache r C₀ σ s
              · rw [if_pos hr']
                rw [show (if s = t + 1 + j' then 1 else 0) = 0 by
                  simp [show s ≠ t + 1 + j' by omega]]
                omega
              · rw [if_neg hr']
                rw [show (if s = t + 1 + j' then 1 else 0) = 0 by
                  simp [show s ≠ t + 1 + j' by omega]]
    unfold schedMisses
    change (∑ s ∈ Finset.range σ.length, rF s) ≤ (∑ s ∈ Finset.range σ.length, eF s) + 1
    have hsum1 : (∑ s ∈ Finset.range σ.length, rF s) ≤
        ∑ s ∈ Finset.range σ.length, (eF s + (if s = t + 1 + j' then 1 else 0)) := by
      exact Finset.sum_le_sum (fun s hs => hper s (Finset.mem_range.mp hs))
    have hsum2 : (∑ s ∈ Finset.range σ.length, (eF s + (if s = t + 1 + j' then 1 else 0))) =
        (∑ s ∈ Finset.range σ.length, eF s) +
          ∑ s ∈ Finset.range σ.length, (if s = t + 1 + j' then 1 else 0) := by
      rw [Finset.sum_add_distrib]
    have hsum3 : (∑ s ∈ Finset.range σ.length, (if s = t + 1 + j' then 1 else 0)) ≤ 1 := by
      rw [Finset.sum_ite_eq']
      by_cases hJ'in : t + 1 + j' ∈ Finset.range σ.length
      · simp [hJ'in]
      · simp [hJ'in]
    rw [hsum2] at hsum1
    exact le_trans hsum1 (Nat.add_le_add_left hsum3 _)
  · -- agree through t + 1
    intro s hs
    by_cases hs' : s ≤ t
    · rw [schedCache_repairSchedule_eq_e e t q' (t + 1 + j') (by omega) σ C₀ hs']
      exact hagree s hs'
    · have hst : s = t + 1 := by omega
      subst s
      have hbase : schedCache r C₀ σ (t + 1) = (schedCache e C₀ σ (t + 1)).erase q' := by
        exact repairSchedule_base e σ C₀ hC₀ ht hagree hdis hnoop rfl hj'
      have hF : schedCache (fifoSchedule σ C₀) C₀ σ (t + 1) =
          insert (σ.getD t 0) ((schedCache e C₀ σ t).erase q') := by
        rw [schedCache_fifoSchedule σ C₀ (t + 1)]
        unfold cacheSeq Policy.step
        rw [← schedCache_fifoSchedule σ C₀ t]
        rw [if_neg (by rw [← hagree t le_rfl]; exact hft)]
        congr 2
        · rw [hagree t le_rfl]
        · change farthestInFuture (schedCache (fifoSchedule σ C₀) C₀ σ t) σ t = q'
          rw [← hagree t le_rfl]
          rw [← fifo_evict_eq_farthest e σ C₀ hagree]
      have hE : schedCache r C₀ σ (t + 1) =
          insert (σ.getD t 0) ((schedCache e C₀ σ t).erase q') := by
        rw [hbase]
        rw [schedCache]
        rw [if_neg hft]
        rw [Finset.erase_eq_of_notMem hnoop]
        rw [Finset.erase_insert_of_ne hsig_ne]
      rw [hE, hF]

The B2 window base: when q = e t is resident, repair's cache at t+1 is insert q ((E(t+1)).erase q').


lemma repairSchedule_base_swap (e : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (hC₀ : C₀.Nonempty)
    {t : ℕ} (ht : t < σ.length)
    (hagree : agreeWithFIF e C₀ σ t)
    (hdis : schedCache e C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1))
    (hqin : e t ∈ schedCache e C₀ σ t)
    (hq' : q' = fifoSchedule σ C₀ t)
    (hq : q = e t)
    {j' : ℕ} (Variable name `hj'` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hj' : nextUse σ (t + 1) q' = some j') :
    schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (t + 1) =
      insert q ((schedCache e C₀ σ (t + 1)).erase q') := by
  have hft : σ.getD t 0 ∉ schedCache e C₀ σ t := by
    intro hft
    have hFt : σ.getD t 0 ∈ schedCache (fifoSchedule σ C₀) C₀ σ t := by
      rw [← hagree t le_rfl]
      exact hft
    have hD : schedCache e C₀ σ (t + 1) = schedCache e C₀ σ t := by
      rw [schedCache]
      rw [if_pos hft]
    have hF : schedCache (fifoSchedule σ C₀) C₀ σ (t + 1) =
        schedCache (fifoSchedule σ C₀) C₀ σ t := by
      rw [schedCache]
      rw [if_pos hFt]
    exact hdis ((hD.trans (hagree t le_rfl)).trans hF.symm)
  have hq'res : q' ∈ schedCache e C₀ σ t := by
    have hfd := first_disagree e σ C₀ hC₀ ht hagree hdis
    rw [hq']
    exact hfd.2.2
  have hqne : q ≠ q' := by
    have hfd := first_disagree e σ C₀ hC₀ ht hagree hdis
    intro hqq'
    exact hfd.2.1 (by rw [← hq, ← hq']; exact hqq')
  have hsig_ne_q' : σ.getD t 0 ≠ q' := by
    intro hsig
    exact hft (hsig ▸ hq'res)
  have hsig_ne_q : σ.getD t 0 ≠ q := by
    intro hsig
    exact hft (hsig ▸ hq ▸ hqin)
  rw [schedCache]
  rw [schedCache_repairSchedule_eq_e e t q' (t + 1 + j') (by omega) σ C₀ le_rfl]
  rw [repairSchedule_at_t]
  rw [if_neg hft]
  rw [schedCache]
  rw [if_neg hft]
  rw [← hq]
  rw [Finset.erase_insert_of_ne hsig_ne_q']
  have hqin' : q ∈ schedCache e C₀ σ t := by
    rw [hq]
    exact hqin
  have hE : (schedCache e C₀ σ t).erase q' =
      insert q (((schedCache e C₀ σ t).erase q).erase q') := by
    ext x
    constructor
    · intro hx
      have hxq' : x ≠ q' := (Finset.mem_erase.mp hx).1
      have hxin : x ∈ schedCache e C₀ σ t := (Finset.mem_erase.mp hx).2
      rw [Finset.mem_insert]
      by_cases hxq : x = q
      · exact Or.inl hxq
      · exact Or.inr (Finset.mem_erase.mpr ⟨hxq', Finset.mem_erase.mpr ⟨hxq, hxin⟩⟩)
    · intro hx
      rw [Finset.mem_insert] at hx
      rcases hx with hxq | hxin
      · rw [hxq]
        exact Finset.mem_erase.mpr ⟨hqne, hqin'⟩
      · have hx' := Finset.mem_erase.mp (Finset.mem_erase.mp hxin).2
        exact Finset.mem_erase.mpr ⟨(Finset.mem_erase.mp hxin).1, hx'.2⟩
  rw [hE]
  rw [Finset.insert_comm]

Within the (t, J] window, q is not in e's cache (e evicts q at t, and q is not requested before J).


lemma swap_q_not_mem (e : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    {t : ℕ} {q : Page} (hq : e t = q) (hqin : q ∈ schedCache e C₀ σ t)
    (hft : σ.getD t 0 ∉ schedCache e C₀ σ t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    {s : ℕ} (hs1 : t < s) (hs2 : s ≤ t + 1 + j) :
    q ∉ schedCache e C₀ σ s := by
  induction s with
  | zero => omega
  | succ s ih =>
      by_cases hs_eq : s = t
      · subst s
        rw [schedCache]
        rw [if_neg hft]
        intro hm
        rw [Finset.mem_insert] at hm
        rcases hm with hqr | hqin2
        · have h : σ.getD t 0 ∈ schedCache e C₀ σ t := by
            rwa [← hqr]
          exact hft h
        · exact (Finset.mem_erase.mp hqin2).1 hq.symm
      · have hts : t < s := by omega
        have hsJ' : s < t + 1 + j := by omega
        have hsig_ne : σ.getD s 0 ≠ q := getD_ne_nextUse (k := s) hj (by omega) hsJ'
        rw [schedCache]
        by_cases hr : σ.getD s 0 ∈ schedCache e C₀ σ s
        · rw [if_pos hr]
          exact ih hts (by omega)
        · rw [if_neg hr]
          intro hm
          rcases Finset.mem_insert.mp hm with hqr | hqin2
          · exact hsig_ne hqr.symm
          · exact ih hts (by omega) (Finset.mem_erase.mp hqin2).2

The B2 window step (disjunctive version): the swap relation Ê = insert q (E − q') or the B1-style relation Ê = E − q' is preserved within (t, J) (the former switches to the latter when e evicts q).


lemma repairSchedule_step_swap' (e : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (Variable name `hC₀` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hC₀ : C₀.Nonempty)
    {t : ℕ} (Variable name `ht` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`ht : t < σ.length)
    (hagree : agreeWithFIF e C₀ σ t)
    (hdis : schedCache e C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1))
    (hqin : e t ∈ schedCache e C₀ σ t)
    (Variable name `hq'` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hq' : q' = fifoSchedule σ C₀ t)
    (hq : q = e t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    {j' : ℕ} (hj' : nextUse σ (t + 1) q' = some j')
    (hjj' : j < j')
    (s : ℕ) (ih : t < s → s ≤ t + 1 + j →
      schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s =
          insert q ((schedCache e C₀ σ s).erase q')
        ∨ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s =
          (schedCache e C₀ σ s).erase q')
    (hts : t < s) (hsJ : s + 1 ≤ t + 1 + j) :
    schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (s + 1) =
        insert q ((schedCache e C₀ σ (s + 1)).erase q')
      ∨ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (s + 1) =
        (schedCache e C₀ σ (s + 1)).erase q' := by
  have hsJ' : s < t + 1 + j := by omega
  have hsig_ne_q : σ.getD s 0 ≠ q := getD_ne_nextUse (k := s) hj (by omega) hsJ'
  have hsig_ne_q' : σ.getD s 0 ≠ q' := getD_ne_nextUse (k := s) hj' (by omega) (by omega)
  have hds : repairSchedule e t q' (t + 1 + j') s = e s := by
    unfold repairSchedule
    simp [show s ≠ t by omega, show s ≠ t + 1 + j' by omega]
  change (if σ.getD s 0 ∈ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s then
      schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s
    else insert (σ.getD s 0) ((schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s).erase
      (repairSchedule e t q' (t + 1 + j') s))) =
        insert q ((if σ.getD s 0 ∈ schedCache e C₀ σ s then schedCache e C₀ σ s
          else insert (σ.getD s 0) ((schedCache e C₀ σ s).erase (e s))).erase q')
      ∨ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ (s + 1) =
        (schedCache e C₀ σ (s + 1)).erase q'
  rw [hds]
  rcases ih hts (by omega) with hrel1 | hrel2
  · -- relation 1: Ê(s) = insert q (E(s) − q')
    by_cases hes : e s = q
    · -- e s = q: on a hit relation 1 is preserved, on a fault it switches to relation 2
      by_cases hr : σ.getD s 0 ∈ schedCache e C₀ σ s
      · -- σ[s] ∈ E: both hit, relation 1 preserved
        have hrE : σ.getD s 0 ∈ insert q ((schedCache e C₀ σ s).erase q') := by
          rw [Finset.mem_insert]
          right
          rw [Finset.mem_erase]
          constructor
          · exact hsig_ne_q'
          · exact hr
        left
        rw [hrel1]
        rw [hes]
        rw [if_pos hrE]
        rw [if_pos hr]
      · -- fault: relation 2
        have hrE : σ.getD s 0 ∉ insert q ((schedCache e C₀ σ s).erase q') := by
          intro hm
          rcases Finset.mem_insert.mp hm with hqeq | hmem
          · exact hsig_ne_q hqeq
          · exact hr (Finset.mem_erase.mp hmem).2
        have hqnotE : q ∉ schedCache e C₀ σ s :=
          swap_q_not_mem e σ C₀ hq.symm (by rw [hq]; exact hqin) (by
            intro hft
            have hFt : σ.getD t 0 ∈ schedCache (fifoSchedule σ C₀) C₀ σ t := by
              rw [← hagree t le_rfl]
              exact hft
            have hD : schedCache e C₀ σ (t + 1) = schedCache e C₀ σ t := by
              rw [schedCache]
              rw [if_pos hft]
            have hF : schedCache (fifoSchedule σ C₀) C₀ σ (t + 1) =
                schedCache (fifoSchedule σ C₀) C₀ σ t := by
              rw [schedCache]
              rw [if_pos hFt]
            exact hdis ((hD.trans (hagree t le_rfl)).trans hF.symm)) hj
            (by omega) (by omega)
        have hqnotE' : q ∉ (schedCache e C₀ σ s).erase q' := by
          intro hm
          exact hqnotE (Finset.mem_erase.mp hm).2
        right
        rw [schedCache]
        rw [hrel1]
        rw [hds]
        rw [hes]
        rw [if_neg hrE]
        rw [Finset.erase_insert hqnotE']
        rw [show schedCache e C₀ σ (s + 1) =
            if σ.getD s 0 ∈ schedCache e C₀ σ s then schedCache e C₀ σ s
            else insert (σ.getD s 0) ((schedCache e C₀ σ s).erase (e s)) by
          rw [schedCache]]
        rw [hes]
        rw [if_neg hr]
        rw [Finset.erase_eq_of_notMem hqnotE]
        rw [Finset.erase_insert_of_ne hsig_ne_q']
    · -- e s ≠ q: relation 1 preserved
      left
      rw [hrel1]
      by_cases hr : σ.getD s 0 ∈ schedCache e C₀ σ s
      · -- both hit
        have hr' : σ.getD s 0 ∈ insert q ((schedCache e C₀ σ s).erase q') := by
          rw [Finset.mem_insert]
          right
          rw [Finset.mem_erase]
          constructor
          · exact hsig_ne_q'
          · exact hr
        rw [if_pos hr, if_pos hr']
      · -- both fault
        rw [if_neg hr]
        have hr' : σ.getD s 0 ∉ insert q ((schedCache e C₀ σ s).erase q') := by
          intro hm
          rcases Finset.mem_insert.mp hm with hqeq | hmem
          · exact hsig_ne_q hqeq
          · exact hr (Finset.mem_erase.mp hmem).2
        rw [if_neg hr']
        rw [Finset.erase_insert_of_ne hsig_ne_q']
        have hqne_es : q ≠ e s := Ne.symm hes
        rw [show (insert q ((schedCache e C₀ σ s).erase q')).erase (e s) =
            insert q (((schedCache e C₀ σ s).erase q').erase (e s)) from
          Finset.erase_insert_of_ne hqne_es]
        rw [Finset.insert_comm]
        have herase_comm : ((schedCache e C₀ σ s).erase q').erase (e s) =
            ((schedCache e C₀ σ s).erase (e s)).erase q' := by
          ext x
          simp [Finset.mem_erase, and_left_comm, This simp argument is unused:
  and_assoc

Hint: Omit it from the simp argument list.
  simp [Finset.mem_erase, and_left_comm,̵ ̵a̵n̵d̵_̵a̵s̵s̵o̵c̵]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`and_assoc]
        rw [herase_comm]
  · -- relation 2: Ê(s) = E(s) − q' (B1-style), preserved
    right
    rw [schedCache]
    rw [hrel2]
    rw [hds]
    rw [show schedCache e C₀ σ (s + 1) =
        if σ.getD s 0 ∈ schedCache e C₀ σ s then schedCache e C₀ σ s
        else insert (σ.getD s 0) ((schedCache e C₀ σ s).erase (e s)) by
      rw [schedCache]]
    by_cases hr : σ.getD s 0 ∈ schedCache e C₀ σ s
    · -- both hit
      have hr' : σ.getD s 0 ∈ (schedCache e C₀ σ s).erase q' := by
        rw [Finset.mem_erase]
        constructor
        · exact hsig_ne_q'
        · exact hr
      rw [if_pos hr, if_pos hr']
    · -- both fault
      rw [if_neg hr]
      have hr' : σ.getD s 0 ∉ (schedCache e C₀ σ s).erase q' := by
        intro hm
        exact hr (Finset.mem_erase.mp hm).2
      rw [if_neg hr']
      rw [Finset.erase_insert_of_ne hsig_ne_q']
      have herase_comm : ((schedCache e C₀ σ s).erase q').erase (e s) =
          ((schedCache e C₀ σ s).erase (e s)).erase q' := by
        ext x
        simp [Finset.mem_erase, and_left_comm, This simp argument is unused:
  and_assoc

Hint: Omit it from the simp argument list.
  simp [Finset.mem_erase, and_left_comm,̵ ̵a̵n̵d̵_̵a̵s̵s̵o̵c̵]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`and_assoc]
      rw [herase_comm]

The B2 window (disjunctive): when q = e t is resident, repair's cache within (t, J] is either insert q (E − q') (swap relation) or E − q' (B1-style relation, after e evicts q).

lemma repairSchedule_window_swap' (e : ℕ → Page) (σ : List Page) (C₀ : Finset Page)
    (hC₀ : C₀.Nonempty)
    {t : ℕ} (ht : t < σ.length)
    (hagree : agreeWithFIF e C₀ σ t)
    (hdis : schedCache e C₀ σ (t + 1) ≠ schedCache (fifoSchedule σ C₀) C₀ σ (t + 1))
    (hqin : e t ∈ schedCache e C₀ σ t)
    (hq' : q' = fifoSchedule σ C₀ t)
    (hq : q = e t)
    {j : ℕ} (hj : nextUse σ (t + 1) q = some j)
    {j' : ℕ} (hj' : nextUse σ (t + 1) q' = some j')
    (hjj' : j < j')
    {s : ℕ} (hs1 : t < s) (hs2 : s ≤ t + 1 + j) :
    schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s =
        insert q ((schedCache e C₀ σ s).erase q')
      ∨ schedCache (repairSchedule e t q' (t + 1 + j')) C₀ σ s =
        (schedCache e C₀ σ s).erase q' := by
  induction s with
  | zero => omega
  | succ s ih =>
      by_cases hs_eq : s = t
      · subst s
        left
        exact repairSchedule_base_swap e σ C₀ hC₀ ht hagree hdis hqin hq' hq hj'
      · exact repairSchedule_step_swap' e σ C₀ hC₀ ht hagree hdis hqin hq' hq hj hj' hjj' s ih
          (by omega) (by omega)

The farthest-in-future policy is optimal among all offline eviction policies for a nonempty initial cache (CLRS Theorem 15.5).

theorem fifo_optimal
    (π : Policy) (C₀ : Finset Page) (σ : List Page)
    (hC₀ : C₀.Nonempty) :
    misses (fifoPolicy σ) C₀ σ ≤ misses π C₀ σ := by
  exact fifo_optimal_trace π C₀ σ hC₀

end Cachingend CLRS

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.EmptyStart

Empty-start boundary for offline caching

The core eviction trace starts from a nonempty cache because every fault must name a resident page to evict. This module isolates the compulsory first miss: under the core transition semantics an empty cache becomes the singleton containing the first request, independently of the policy. Thereafter the existing exchange theorem applies unchanged. This literal-empty execution is capacity one after its first request: it cannot represent filling a capacity-k cache for k > 1.

For a capacity greater than one, the deterministic compulsory-fill phase is represented separately by compulsoryFillCost; once a nonempty resident set is handed to the eviction phase, adding the same fill cost preserves optimality. The fill cost, resident set, and remaining suffix are supplied parameters. This module does not compute them from a capacity and empty initial state, or prove that such a capacity-parametric fill execution realizes this decomposition.

namespace CLRS.Cachingopen Finset

Shift from an empty cache and from the first-page singleton agrees after request 0.


theorem cacheSeq_empty_eq_singleton_after_first
    (π : Policy) (p : Page) (rest : List Page) (t : Nat) :
    cacheSeq π ∅ (p :: rest) (t + 1) =
      cacheSeq π {p} (p :: rest) (t + 1) := by
  induction t with
  | zero => simp [cacheSeq, Policy.step]
  | succ t ih =>
      change π.step (t + 1) (cacheSeq π ∅ (p :: rest) (t + 1))
          ((p :: rest).getD (t + 1) 0) =
        π.step (t + 1) (cacheSeq π {p} (p :: rest) (t + 1))
          ((p :: rest).getD (t + 1) 0)
      rw [ih]

The core literal-empty run has capacity one after the first request.


theorem cacheSeq_empty_card_one_after_first
    (π : Policy) (p : Page) (rest : List Page) (t : Nat) :
    (cacheSeq π ∅ (p :: rest) (t + 1)).card = 1 := by
  rw [cacheSeq_empty_eq_singleton_after_first]
  rw [cacheSeq_card π {p} (p :: rest) (t + 1) (by simp)]
  simp

              theorem faultAt_empty_zero (π : Policy) (p : Page) (rest : List Page) :
    faultAt π ∅ (p :: rest) 0 = 1 := by
  simp [faultAt, cacheSeq]theorem faultAt_singleton_zero (π : Policy) (p : Page) (rest : List Page) :
    faultAt π {p} (p :: rest) 0 = 0 := by
  simp [faultAt, cacheSeq]

theorem faultAt_empty_eq_singleton_succ
    (π : Policy) (p : Page) (rest : List Page) (t : Nat) :
    faultAt π ∅ (p :: rest) (t + 1) =
      faultAt π {p} (p :: rest) (t + 1) := by
  unfold faultAt
  rw [cacheSeq_empty_eq_singleton_after_first]

Every policy pays exactly one additional compulsory miss when starting empty.


theorem misses_empty_eq_singleton_add_one
    (π : Policy) (p : Page) (rest : List Page) :
    misses π ∅ (p :: rest) = misses π {p} (p :: rest) + 1 := by
  have hempty :
      misses π ∅ (p :: rest) =
        1 + ∑ t ∈ Finset.range rest.length,
          faultAt π ∅ (p :: rest) (t + 1) := by
    unfold misses
    rw [show (p :: rest).length = rest.length + 1 by simp,
      sum_range_shift]
    rw [faultAt_empty_zero]
  have hsingleton :
      misses π {p} (p :: rest) =
        ∑ t ∈ Finset.range rest.length,
          faultAt π {p} (p :: rest) (t + 1) := by
    unfold misses
    rw [show (p :: rest).length = rest.length + 1 by simp,
      sum_range_shift]
    rw [faultAt_singleton_zero, zero_add]
  rw [hempty, hsingleton]
  have hsum :
      (∑ t ∈ Finset.range rest.length,
          faultAt π ∅ (p :: rest) (t + 1)) =
        ∑ t ∈ Finset.range rest.length,
          faultAt π {p} (p :: rest) (t + 1) := by
    apply Finset.sum_congr rfl
    intro t _
    exact faultAt_empty_eq_singleton_succ π p rest t
  rw [hsum, Nat.add_comm]

Farthest-in-future is optimal from the literal empty cache in the core transition semantics of capacity one after the first load; the empty request list and the compulsory first miss are both covered. This is not an arbitrary capacity empty-start execution theorem.


theorem fifo_optimal_from_empty (π : Policy) (σ : List Page) :
    misses (fifoPolicy σ) ∅ σ ≤ misses π ∅ σ := by
  cases σ with
  | nil => simp [misses]
  | cons p rest =>
      rw [misses_empty_eq_singleton_add_one (fifoPolicy (p :: rest)) p rest,
        misses_empty_eq_singleton_add_one π p rest]
      exact Nat.add_le_add_right
        (fifo_optimal π {p} (p :: rest) (by simp)) 1

Cost decomposition after a policy-independent compulsory-fill phase.

def compulsoryFillCost
    (fillMisses : Nat) (π : Policy) (resident : Finset Page)
    (remaining : List Page) : Nat :=
  fillMisses + misses π resident remaining

Adding a common compulsory-fill cost does not change the optimal eviction policy for the remaining requests. This is the capacity-independent bridge for supplied fill data. It does not establish that a capacity-parametric empty-start algorithm produces those data.

theorem fifo_optimal_after_compulsory_fill
    (fillMisses : Nat) (π : Policy) (resident : Finset Page)
    (remaining : List Page) (hresident : resident.Nonempty) :
    compulsoryFillCost fillMisses (fifoPolicy remaining) resident remaining ≤
      compulsoryFillCost fillMisses π resident remaining := by
  unfold compulsoryFillCost
  exact Nat.add_le_add_left (fifo_optimal π resident remaining hresident) fillMisses

end CLRS.Caching

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.Optimality.Trace.A1_LegalTrace

Section 15.4 optimality: legal cache traces

This file separates the semantic notion of a legal cache execution from the Policy representation. It is the first layer of the trace-coupling proof of farthest-in-future optimality.

              namespace CLRSopen Finsetopen scoped BigOperatorsnamespace Caching

A legal cache execution on σ, with cache states at request boundaries.

structure LegalTrace (C₀ : Finset Page) (σ : List Page) where
  cache : ℕ → Finset Page
  evict : ℕ → Page
  init : cache 0 = C₀
  step : ∀ t, t < σ.length →
    cache (t + 1) =
      if σ.getD t 0 ∈ cache t then cache t
      else insert (σ.getD t 0) ((cache t).erase (evict t))
  evict_mem : ∀ t, t < σ.length →
    σ.getD t 0 ∉ cache t → evict t ∈ cache t

The miss indicator of a legal trace at request position t.

def traceFaultAt (T : LegalTrace C₀ σ) (t : ℕ) : ℕ :=
  if σ.getD t 0 ∈ T.cache t then 0 else 1

The total number of misses of a legal trace over the request sequence.

def traceMisses (T : LegalTrace C₀ σ) : ℕ :=
  ∑ t ∈ Finset.range σ.length, traceFaultAt T t

On a hit, a legal trace leaves the cache unchanged.


lemma LegalTrace.cache_succ_of_mem (T : LegalTrace C₀ σ)
    (t : ℕ) (ht : t < σ.length) (hrequest : σ.getD t 0 ∈ T.cache t) :
    T.cache (t + 1) = T.cache t := by
  rw [T.step t ht, if_pos hrequest]

On a fault, a legal trace evicts its recorded resident and loads the request.


lemma LegalTrace.cache_succ_of_not_mem (T : LegalTrace C₀ σ)
    (t : ℕ) (ht : t < σ.length) (hrequest : σ.getD t 0 ∉ T.cache t) :
    T.cache (t + 1) =
      insert (σ.getD t 0) ((T.cache t).erase (T.evict t)) := by
  rw [T.step t ht, if_neg hrequest]

The legal trace generated by an eviction policy.

def policyTrace (π : Policy) (C₀ : Finset Page) (σ : List Page)
    (hC₀ : C₀.Nonempty) : LegalTrace C₀ σ where
  cache := cacheSeq π C₀ σ
  evict := fun t => π.evict t (cacheSeq π C₀ σ t) (σ.getD t 0)
  init := rfl
  step := by
    intro t _ht
    rfl
  evict_mem := by
    intro t _ht hmiss
    exact π.evict_mem t (cacheSeq π C₀ σ t) (σ.getD t 0) hmiss
      (cacheSeq_nonempty π C₀ σ t hC₀)

The legal trace generated by farthest-in-future.

noncomputable def fifoTrace (C₀ : Finset Page) (σ : List Page)
    (hC₀ : C₀.Nonempty) : LegalTrace C₀ σ :=
  policyTrace (fifoPolicy σ) C₀ σ hC₀

A policy trace has the same pointwise miss indicator as the policy run.

lemma traceFaultAt_policyTrace (π : Policy) (C₀ : Finset Page)
    (σ : List Page) (hC₀ : C₀.Nonempty) (t : ℕ) :
    traceFaultAt (policyTrace π C₀ σ hC₀) t = faultAt π C₀ σ t := by
  rfl

A policy trace has exactly the policy's miss count.

lemma traceMisses_policyTrace (π : Policy) (C₀ : Finset Page)
    (σ : List Page) (hC₀ : C₀.Nonempty) :
    traceMisses (policyTrace π C₀ σ hC₀) = misses π C₀ σ := by
  rfl

The farthest-in-future trace has exactly the policy-level FIF miss count.

lemma traceMisses_fifoTrace (C₀ : Finset Page) (σ : List Page)
    (hC₀ : C₀.Nonempty) :
    traceMisses (fifoTrace C₀ σ hC₀) = misses (fifoPolicy σ) C₀ σ := by
  rfl

Every reachable cache boundary in a legal trace preserves cache size.


lemma legalTrace_card (T : LegalTrace C₀ σ) (hC₀ : C₀.Nonempty)
    (t : ℕ) (ht : t ≤ σ.length) :
    (T.cache t).card = C₀.card := by
  induction t with
  | zero => simpa using congrArg Finset.card T.init
  | succ t ih =>
      have htlt : t < σ.length := Nat.lt_of_succ_le ht
      have htprev : t ≤ σ.length := Nat.le_trans (Nat.le_succ t) ht
      rw [T.step t htlt]
      by_cases hrequest : σ.getD t 0 ∈ T.cache t
      · rw [if_pos hrequest]
        exact ih htprev
      · rw [if_neg hrequest]
        have hevict : T.evict t ∈ T.cache t := T.evict_mem t htlt hrequest
        have hnotmem : σ.getD t 0 ∉ (T.cache t).erase (T.evict t) := by
          intro hmem
          exact hrequest (Finset.mem_erase.mp hmem).2
        rw [Finset.card_insert_of_notMem hnotmem]
        rw [Finset.card_erase_of_mem hevict]
        rw [ih htprev]
        have hpos : 0 < C₀.card := Finset.card_pos.mpr hC₀
        omega

end Cachingend CLRS

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.Optimality.Trace.A2_OnePageDiff

Section 15.4 optimality: exact one-page cache difference

The exchange proof needs a precise relation for two equal-size caches that differ in exactly one resident page on each side.

              namespace CLRSopen Finsetnamespace Caching

A contains only a, B contains only b, and their common cores agree.

def OnePageDiff (A B : Finset Page) (a b : Page) : Prop :=
  a ∈ A ∧ a ∉ B ∧ b ∉ A ∧ b ∈ B ∧ A.erase a = B.erase b

              namespace OnePageDifflemma left_mem (h : OnePageDiff A B a b) : a ∈ A := h.1lemma left_not_mem_right (h : OnePageDiff A B a b) : a ∉ B := h.2.1lemma right_not_mem_left (h : OnePageDiff A B a b) : b ∉ A := h.2.2.1lemma right_mem (h : OnePageDiff A B a b) : b ∈ B := h.2.2.2.1lemma erase_eq (h : OnePageDiff A B a b) : A.erase a = B.erase b := h.2.2.2.2

The two distinguished pages of an exact one-page difference are distinct.

lemma ne (h : OnePageDiff A B a b) : a ≠ b := by
  intro hab
  subst b
  exact h.right_not_mem_left h.left_mem

Exact one-page-different caches are not equal.

lemma cache_ne (h : OnePageDiff A B a b) : A ≠ B := by
  intro hAB
  subst B
  exact h.left_not_mem_right h.left_mem

Reversing the caches reverses the two distinguished pages.

lemma symm (h : OnePageDiff A B a b) : OnePageDiff B A b a := by
  exact ⟨h.right_mem, h.right_not_mem_left, h.left_not_mem_right,
    h.left_mem, h.erase_eq.symm⟩

Membership agrees away from the two distinguished pages.


lemma mem_iff (h : OnePageDiff A B a b)
    (hxa : x ≠ a) (hxb : x ≠ b) : x ∈ A ↔ x ∈ B := by
  constructor
  · intro hx
    have hxe : x ∈ A.erase a := Finset.mem_erase.mpr ⟨hxa, hx⟩
    rw [h.erase_eq] at hxe
    exact (Finset.mem_erase.mp hxe).2
  · intro hx
    have hxe : x ∈ B.erase b := Finset.mem_erase.mpr ⟨hxb, hx⟩
    rw [← h.erase_eq] at hxe
    exact (Finset.mem_erase.mp hxe).2

Exact one-page-different caches have equal cardinality.

lemma card_eq (h : OnePageDiff A B a b) : A.card = B.card := by
  calc
    A.card = (A.erase a).card + 1 := (Finset.card_erase_add_one h.left_mem).symm
    _ = (B.erase b).card + 1 :=
      congrArg (fun S : Finset Page => S.card + 1) h.erase_eq
    _ = B.card := Finset.card_erase_add_one h.right_mem

Removing the unique page on each side and loading the same request merges caches.


lemma merge (h : OnePageDiff A B a b) (r : Page) :
    insert r (A.erase a) = insert r (B.erase b) := by
  rw [h.erase_eq]

Loading A's unique page after removing B's unique page recovers A.


lemma insert_left_erase_right (h : OnePageDiff A B a b) :
    insert a (B.erase b) = A := by
  rw [← h.erase_eq, Finset.insert_erase h.left_mem]

Loading B's unique page after removing A's unique page recovers B.


lemma insert_right_erase_left (h : OnePageDiff A B a b) :
    insert b (A.erase a) = B := by
  rw [h.erase_eq, Finset.insert_erase h.right_mem]

If A hits its unique page while B faults and evicts a common page y, the new exact difference is y on A's side and the old b on B's side.


lemma hit_left_fault (h : OnePageDiff A B a b) (y : Page)
    (hyB : y ∈ B) (hyb : y ≠ b) :
    OnePageDiff A (insert a (B.erase y)) y b := by
  have hya : y ≠ a := by
    intro hya
    subst y
    exact h.left_not_mem_right hyB
  have hyA : y ∈ A := (h.mem_iff hya hyb).2 hyB
  refine ⟨hyA, ?_, h.right_not_mem_left, ?_, ?_⟩
  · simp [hya]
  · exact Finset.mem_insert_of_mem (Finset.mem_erase.mpr ⟨hyb.symm, h.right_mem⟩)
  · calc
      A.erase y = (insert a (A.erase a)).erase y := by
        rw [Finset.insert_erase h.left_mem]
      _ = insert a ((A.erase a).erase y) := by
        rw [Finset.erase_insert_of_ne hya.symm]
      _ = insert a ((B.erase b).erase y) := by rw [h.erase_eq]
      _ = insert a ((B.erase y).erase b) := by rw [Finset.erase_right_comm]
      _ = (insert a (B.erase y)).erase b := by
        rw [Finset.erase_insert_of_ne h.ne]

Erasing the same non-distinguished page preserves the exact difference.


lemma erase_common (h : OnePageDiff A B a b) (x : Page)
    (hxa : x ≠ a) (hxb : x ≠ b) :
    OnePageDiff (A.erase x) (B.erase x) a b := by
  refine ⟨?_, ?_, ?_, ?_, ?_⟩
  · exact Finset.mem_erase.mpr ⟨hxa.symm, h.left_mem⟩
  · intro ha
    exact h.left_not_mem_right (Finset.mem_erase.mp ha).2
  · intro hb
    exact h.right_not_mem_left (Finset.mem_erase.mp hb).2
  · exact Finset.mem_erase.mpr ⟨hxb.symm, h.right_mem⟩
  · rw [Finset.erase_right_comm, h.erase_eq, Finset.erase_right_comm]

Inserting a page absent from both caches preserves their exact difference.


lemma insert_common (h : OnePageDiff A B a b) (r : Page)
    (hrA : r ∉ A) (hrB : r ∉ B) :
    OnePageDiff (insert r A) (insert r B) a b := by
  have hra : r ≠ a := by
    intro hra
    subst a
    exact hrA h.left_mem
  have hrb : r ≠ b := by
    intro hrb
    subst b
    exact hrB h.right_mem
  refine ⟨?_, ?_, ?_, ?_, ?_⟩
  · exact Finset.mem_insert_of_mem h.left_mem
  · simpa [hra.symm] using h.left_not_mem_right
  · simpa [hrb.symm] using h.right_not_mem_left
  · exact Finset.mem_insert_of_mem h.right_mem
  · rw [Finset.erase_insert_of_ne hra, Finset.erase_insert_of_ne hrb, h.erase_eq]

Mirroring a common fault preserves the exact one-page difference.

lemma fault_common (h : OnePageDiff A B a b) (x r : Page)
    (hxa : x ≠ a) (hxb : x ≠ b) (hrA : r ∉ A) (hrB : r ∉ B) :
    OnePageDiff (insert r (A.erase x)) (insert r (B.erase x)) a b := by
  apply (h.erase_common x hxa hxb).insert_common r
  · intro hr
    exact hrA (Finset.mem_erase.mp hr).2
  · intro hr
    exact hrB (Finset.mem_erase.mp hr).2

Loading the same absent request after evicting distinct residents produces an exact one-page difference: the first cache keeps q, the second keeps p.


lemma of_common_fault {C : Finset Page} {request p q : Page}
    (hrequest : request ∉ C) (hp : p ∈ C) (hq : q ∈ C) (hqp : q ≠ p) :
    OnePageDiff (insert request (C.erase p)) (insert request (C.erase q)) q p := by
  have hqr : q ≠ request := by
    intro h
    subst q
    exact hrequest hq
  have hpr : p ≠ request := by
    intro h
    subst p
    exact hrequest hp
  refine ⟨?_, ?_, ?_, ?_, ?_⟩
  · exact Finset.mem_insert_of_mem (Finset.mem_erase.mpr ⟨hqp, hq⟩)
  · simp [hqr]
  · simp [hpr]
  · exact Finset.mem_insert_of_mem (Finset.mem_erase.mpr ⟨hqp.symm, hp⟩)
  · rw [Finset.erase_insert_of_ne hqr.symm, Finset.erase_insert_of_ne hpr.symm]
    rw [Finset.erase_right_comm]

              end OnePageDiffend Cachingend CLRS

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.Optimality.Trace.A3_CouplingCore

Section 15.4 optimality: recursive coupling core

This file defines the transformed execution used by the local exchange. The definitions are total; their legality and miss accounting are proved in A4.

              namespace CLRSopen Finsetnamespace Caching

The phase of the one-page coupling.

inductive CouplingMode where
  | same
  | ordered (a b : Page)
  | credited (a b : Page)
deriving DecidableEq, Repr

Apply one recorded eviction decision to a cache request.

def traceStepCache (C : Finset Page) (evict request : Page) : Finset Page :=
  if request ∈ C then C else insert request (C.erase evict)

Choose the transformed eviction while mirroring the source. If the source hits its unique page, or evicts its unique page, the transformed side removes its own unique page so that the caches merge.

def coupledEvict (mode : CouplingMode) (A B : Finset Page)
    (sourceEvict request : Page) : Page :=
  match mode with
  | .same => sourceEvict
  | .ordered a b =>
      if request ∈ B ∧ request ∉ A then a
      else if sourceEvict = b then a else sourceEvict
  | .credited a b =>
      if request ∈ B ∧ request ∉ A then a
      else if sourceEvict = b then a else sourceEvict

Update the coupling phase after both caches take one step.

def nextCouplingMode (mode : CouplingMode) (request sourceEvict : Page)
    (transformedNext sourceNext : Finset Page) : CouplingMode :=
  if transformedNext = sourceNext then .same
  else
    match mode with
    | .same => .same
    | .ordered a b =>
        if request = a then .credited sourceEvict b else .ordered a b
    | .credited a b =>
        if request = a then .credited sourceEvict b else .credited a b

State of the transformed execution at one request boundary.

structure CouplingState where
  cache : Finset Page
  evict : Page
  mode : CouplingMode

The transformed suffix at relative boundary n; absolute request positions are start + n.

def couplingCore (source : LegalTrace C₀ σ) (start : ℕ)
    (initialCache : Finset Page) (initialMode : CouplingMode) :
    ℕ → CouplingState
  | 0 =>
      let sourceCache := source.cache start
      let request := σ.getD start 0
      let evict := coupledEvict initialMode initialCache sourceCache
        (source.evict start) request
      ⟨initialCache, evict, initialMode⟩
  | n + 1 =>
      let previous := couplingCore source start initialCache initialMode n
      let absolute := start + n
      let request := σ.getD absolute 0
      let transformedNext := traceStepCache previous.cache previous.evict request
      let sourceNext := source.cache (absolute + 1)
      let modeNext := nextCouplingMode previous.mode request (source.evict absolute)
        transformedNext sourceNext
      let nextAbsolute := absolute + 1
      let nextRequest := σ.getD nextAbsolute 0
      let nextEvict := coupledEvict modeNext transformedNext sourceNext
        (source.evict nextAbsolute) nextRequest
      ⟨transformedNext, nextEvict, modeNext⟩

@[simp] lemma couplingCore_zero (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) :
    (couplingCore source start A mode 0).cache = A := by
  rfl

Cache states of the full trace splice: source prefix, transformed suffix.

def coupledCache (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) (s : ℕ) : Finset Page :=
  if s < start then source.cache s
  else (couplingCore source start A mode (s - start)).cache

Evictions of the full trace splice. The replacement boundary decision is at start - 1; core decisions begin at start.

def coupledTraceEvict (source : LegalTrace C₀ σ) (start : ℕ)
    (boundaryEvict : Page) (A : Finset Page) (mode : CouplingMode)
    (s : ℕ) : Page :=
  if s + 1 < start then source.evict s
  else if s + 1 = start then boundaryEvict
  else (couplingCore source start A mode (s - start)).evict

              @[simp] lemma coupledCache_of_lt (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) (s : ℕ) (hs : s < start) :
    coupledCache source start A mode s = source.cache s := by
  simp [coupledCache, hs]@[simp] lemma coupledCache_start (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) :
    coupledCache source start A mode start = A := by
  simp [coupledCache]end Cachingend CLRS

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.Optimality.Trace.A4_CouplingCorrect

Section 15.4 optimality: coupling correctness

This file proves that the recursive coupling is legal, preserves the exact cache relation, and never spends more misses than the local credit permits.

              namespace CLRSopen Finsetopen scoped BigOperatorsnamespace Caching

Cache relation represented by each coupling phase.

def ModeRel : CouplingMode → Finset Page → Finset Page → Prop
  | .same, A, B => A = B
  | .ordered a b, A, B => OnePageDiff A B a b
  | .credited a b, A, B => OnePageDiff A B a b

The miss indicator of one request against one cache.

def faultInCache (C : Finset Page) (request : Page) : ℕ :=
  if request ∈ C then 0 else 1

A cache-only miss indicator used while the transformed trace is unpackaged.

def cacheFaultAt (cache : ℕ → Finset Page) (σ : List Page) (t : ℕ) : ℕ :=
  faultInCache (cache t) (σ.getD t 0)

Misses of a cache sequence on a finite interval starting at start.

def cacheMissesFrom (cache : ℕ → Finset Page) (σ : List Page)
    (start count : ℕ) : ℕ :=
  ∑ n ∈ Finset.range count, cacheFaultAt cache σ (start + n)

Ordered mode has no credit; credited mode has one saved source miss.

def AccountingRel : CouplingMode → ℕ → ℕ → Prop
  | .same, transformed, source => transformed ≤ source
  | .ordered _ _, transformed, source => transformed ≤ source
  | .credited _ _, transformed, source => transformed + 1 ≤ source

Ordered mode is safe only while the source-only page is not requested.

def OrderedSafe : CouplingMode → Page → Prop
  | .ordered _ b, request => request ≠ b
  | _, _ => True

              lemma faultInCache_le_one (C : Finset Page) (request : Page) :
    faultInCache C request ≤ 1 := by
  unfold faultInCache
  split <;> omega

lemma OnePageDiff.fault_eq_of_ne (h : OnePageDiff A B a b)
    (request : Page) (hrequesta : request ≠ a) (hrequestb : request ≠ b) :
    faultInCache A request = faultInCache B request := by
  have hmem := h.mem_iff hrequesta hrequestb
  unfold faultInCache
  by_cases hrequestA : request ∈ A
  · have hrequestB := hmem.mp hrequestA
    simp [hrequestA, hrequestB]
  · have hrequestB : request ∉ B := by
      intro hmemB
      exact hrequestA (hmem.mpr hmemB)
    simp [hrequestA, hrequestB]

lemma OnePageDiff.fault_le_of_ne_right (h : OnePageDiff A B a b)
    (request : Page) (hrequestb : request ≠ b) :
    faultInCache A request ≤ faultInCache B request := by
  by_cases hrequesta : request = a
  · subst request
    simp [faultInCache, h.left_mem, h.left_not_mem_right]
  · rw [h.fault_eq_of_ne request hrequesta hrequestb]lemma faultInCache_le_add_one (A B : Finset Page) (request : Page) :
    faultInCache A request ≤ faultInCache B request + 1 := by
  have hA := faultInCache_le_one A request
  omega

The common eviction rule used by both one-page-difference modes.

private def diffCoupledEvict (A B : Finset Page) (a b sourceEvict request : Page) : Page :=
  if request ∈ B ∧ request ∉ A then a
  else if sourceEvict = b then a else sourceEvict

A transformed fault always removes a transformed resident.


lemma coupledEvict_mem (mode : CouplingMode) (A B : Finset Page)
    (sourceEvict request : Page) (hrel : ModeRel mode A B)
    (hsource : request ∉ B → sourceEvict ∈ B)
    (htransformed : request ∉ A) :
    coupledEvict mode A B sourceEvict request ∈ A := by
  cases mode with
  | same =>
      simp only [ModeRel] at hrel
      subst B
      simpa [coupledEvict] using hsource htransformed
  | ordered a b =>
      simp only [ModeRel] at hrel
      by_cases hunique : request ∈ B ∧ request ∉ A
      · simp [coupledEvict, hunique, hrel.left_mem]
      · have hrequestB : request ∉ B := by
          intro hmem
          exact hunique ⟨hmem, htransformed⟩
        have hsourceB : sourceEvict ∈ B := hsource hrequestB
        by_cases hsb : sourceEvict = b
        · simp [coupledEvict, hunique, hsb, hrel.left_mem]
        · have hsa : sourceEvict ≠ a := by
            intro hsa
            subst sourceEvict
            exact hrel.left_not_mem_right hsourceB
          have hsourceA : sourceEvict ∈ A := (hrel.mem_iff hsa hsb).2 hsourceB
          simpa [coupledEvict, hunique, hsb] using hsourceA
  | credited a b =>
      simp only [ModeRel] at hrel
      by_cases hunique : request ∈ B ∧ request ∉ A
      · simp [coupledEvict, hunique, hrel.left_mem]
      · have hrequestB : request ∉ B := by
          intro hmem
          exact hunique ⟨hmem, htransformed⟩
        have hsourceB : sourceEvict ∈ B := hsource hrequestB
        by_cases hsb : sourceEvict = b
        · simp [coupledEvict, hunique, hsb, hrel.left_mem]
        · have hsa : sourceEvict ≠ a := by
            intro hsa
            subst sourceEvict
            exact hrel.left_not_mem_right hsourceB
          have hsourceA : sourceEvict ∈ A := (hrel.mem_iff hsa hsb).2 hsourceB
          simpa [coupledEvict, hunique, hsb] using hsourceA

Complete transition classification for exact one-page-different caches.


lemma onePageDiff_step_cases (h : OnePageDiff A B a b)
    (sourceEvict request : Page)
    (hsource : request ∉ B → sourceEvict ∈ B) :
    let evict := diffCoupledEvict A B a b sourceEvict request
    let transformedNext := traceStepCache A evict request
    let sourceNext := traceStepCache B sourceEvict request
    transformedNext = sourceNext ∨
      (request = a ∧ sourceEvict ≠ b ∧
        OnePageDiff transformedNext sourceNext sourceEvict b) ∨
      (request ≠ a ∧ OnePageDiff transformedNext sourceNext a b) := by
  dsimp only
  by_cases hrequestA : request ∈ A
  · by_cases hrequestB : request ∈ B
    · have hrequesta : request ≠ a := by
        intro hrequesta
        subst request
        exact h.left_not_mem_right hrequestB
      right
      right
      refine ⟨hrequesta, ?_⟩
      simpa [traceStepCache, hrequestA, hrequestB]
    · have hrequestb : request ≠ b := by
        intro hrequestb
        subst request
        exact h.right_not_mem_left hrequestA
      have hrequesta : request = a := by
        by_contra hne
        exact hrequestB ((h.mem_iff hne hrequestb).1 hrequestA)
      subst request
      have hsourceB : sourceEvict ∈ B := hsource h.left_not_mem_right
      by_cases hsourceb : sourceEvict = b
      · subst sourceEvict
        left
        simpa [traceStepCache, h.left_mem, h.left_not_mem_right] using
          h.insert_left_erase_right.symm
      · right
        left
        refine ⟨rfl, hsourceb, ?_⟩
        simpa [traceStepCache, h.left_mem, h.left_not_mem_right] using
          h.hit_left_fault sourceEvict hsourceB hsourceb
  · by_cases hrequestB : request ∈ B
    · have hrequesta : request ≠ a := by
        intro hrequesta
        subst request
        exact hrequestA h.left_mem
      have hrequestb : request = b := by
        by_contra hne
        exact hrequestA ((h.mem_iff hrequesta hne).2 hrequestB)
      subst request
      left
      simpa [diffCoupledEvict, traceStepCache, h.right_not_mem_left,
        h.right_mem] using h.insert_right_erase_left
    · have hsourceB : sourceEvict ∈ B := hsource hrequestB
      by_cases hsourceb : sourceEvict = b
      · subst sourceEvict
        left
        simpa [diffCoupledEvict, traceStepCache, hrequestA, hrequestB] using
          h.merge request
      · have hsourcea : sourceEvict ≠ a := by
          intro hsourcea
          subst sourceEvict
          exact h.left_not_mem_right hsourceB
        have hrequesta : request ≠ a := by
          intro hrequesta
          subst request
          exact hrequestA h.left_mem
        right
        right
        refine ⟨hrequesta, ?_⟩
        simpa [diffCoupledEvict, traceStepCache, hrequestA, hrequestB,
          hsourceb] using
          h.fault_common sourceEvict request hsourcea hsourceb hrequestA hrequestB

One coupling step preserves the relation represented by the next mode.


lemma modeRel_step (mode : CouplingMode) (A B : Finset Page)
    (sourceEvict request : Page) (hrel : ModeRel mode A B)
    (hsource : request ∉ B → sourceEvict ∈ B) :
    let transformedNext :=
      traceStepCache A (coupledEvict mode A B sourceEvict request) request
    let sourceNext := traceStepCache B sourceEvict request
    ModeRel (nextCouplingMode mode request sourceEvict transformedNext sourceNext)
      transformedNext sourceNext := by
  dsimp only
  cases mode with
  | same =>
      simp only [ModeRel] at hrel
      subst B
      simp [coupledEvict, nextCouplingMode, ModeRel]
  | ordered a b =>
      simp only [ModeRel] at hrel
      have hcases := onePageDiff_step_cases hrel sourceEvict request hsource
      simp only [diffCoupledEvict] at hcases
      rcases hcases with hequal | hchanged | hstable
      · have hequal' :
            traceStepCache A (coupledEvict (.ordered a b) A B sourceEvict request) request =
              traceStepCache B sourceEvict request := by
          simpa [coupledEvict] using hequal
        simp [nextCouplingMode, hequal', ModeRel]
      · rcases hchanged with ⟨hrequest, hsourceb, hdiff⟩
        subst request
        have hdiff' : OnePageDiff
            (traceStepCache A (coupledEvict (.ordered a b) A B sourceEvict a) a)
            (traceStepCache B sourceEvict a) sourceEvict b := by
          simpa [coupledEvict] using hdiff
        have hne := hdiff'.cache_ne
        simpa [nextCouplingMode, hne, ModeRel] using hdiff'
      · rcases hstable with ⟨hrequest, hdiff⟩
        have hdiff' : OnePageDiff
            (traceStepCache A (coupledEvict (.ordered a b) A B sourceEvict request) request)
            (traceStepCache B sourceEvict request) a b := by
          simpa [coupledEvict] using hdiff
        have hne := hdiff'.cache_ne
        simpa [nextCouplingMode, hne, hrequest, ModeRel] using hdiff'
  | credited a b =>
      simp only [ModeRel] at hrel
      have hcases := onePageDiff_step_cases hrel sourceEvict request hsource
      simp only [diffCoupledEvict] at hcases
      rcases hcases with hequal | hchanged | hstable
      · have hequal' :
            traceStepCache A (coupledEvict (.credited a b) A B sourceEvict request) request =
              traceStepCache B sourceEvict request := by
          simpa [coupledEvict] using hequal
        simp [nextCouplingMode, hequal', ModeRel]
      · rcases hchanged with ⟨hrequest, hsourceb, hdiff⟩
        subst request
        have hdiff' : OnePageDiff
            (traceStepCache A (coupledEvict (.credited a b) A B sourceEvict a) a)
            (traceStepCache B sourceEvict a) sourceEvict b := by
          simpa [coupledEvict] using hdiff
        have hne := hdiff'.cache_ne
        simpa [nextCouplingMode, hne, ModeRel] using hdiff'
      · rcases hstable with ⟨hrequest, hdiff⟩
        have hdiff' : OnePageDiff
            (traceStepCache A (coupledEvict (.credited a b) A B sourceEvict request) request)
            (traceStepCache B sourceEvict request) a b := by
          simpa [coupledEvict] using hdiff
        have hne := hdiff'.cache_ne
        simpa [nextCouplingMode, hne, hrequest, ModeRel] using hdiff'

One request preserves the local miss-accounting invariant.


lemma accounting_step (mode : CouplingMode) (A B : Finset Page)
    (sourceEvict request : Page) (transformedMisses sourceMisses : ℕ)
    (hrel : ModeRel mode A B)
    (hsource : request ∉ B → sourceEvict ∈ B)
    (hsafe : OrderedSafe mode request)
    (haccount : AccountingRel mode transformedMisses sourceMisses) :
    let transformedNext :=
      traceStepCache A (coupledEvict mode A B sourceEvict request) request
    let sourceNext := traceStepCache B sourceEvict request
    AccountingRel
      (nextCouplingMode mode request sourceEvict transformedNext sourceNext)
      (transformedMisses + faultInCache A request)
      (sourceMisses + faultInCache B request) := by
  dsimp only
  cases mode with
  | same =>
      simp only [ModeRel] at hrel
      simp only [AccountingRel] at haccount
      subst B
      simp [coupledEvict, nextCouplingMode, AccountingRel]
      omega
  | ordered a b =>
      simp only [ModeRel] at hrel
      simp only [OrderedSafe] at hsafe
      simp only [AccountingRel] at haccount
      have hcases := onePageDiff_step_cases hrel sourceEvict request hsource
      simp only [diffCoupledEvict] at hcases
      rcases hcases with hequal | hchanged | hstable
      · have hequal' :
            traceStepCache A (coupledEvict (.ordered a b) A B sourceEvict request) request =
              traceStepCache B sourceEvict request := by
          simpa [coupledEvict] using hequal
        have hfault := hrel.fault_le_of_ne_right request hsafe
        simp [nextCouplingMode, hequal', AccountingRel]
        omega
      · rcases hchanged with ⟨hrequest, hsourceb, hdiff⟩
        subst request
        have hdiff' : OnePageDiff
            (traceStepCache A (coupledEvict (.ordered a b) A B sourceEvict a) a)
            (traceStepCache B sourceEvict a) sourceEvict b := by
          simpa [coupledEvict] using hdiff
        have hne := hdiff'.cache_ne
        simp [nextCouplingMode, hne, AccountingRel, faultInCache,
          hrel.left_mem, hrel.left_not_mem_right]
        omega
      · rcases hstable with ⟨hrequesta, hdiff⟩
        have hdiff' : OnePageDiff
            (traceStepCache A (coupledEvict (.ordered a b) A B sourceEvict request) request)
            (traceStepCache B sourceEvict request) a b := by
          simpa [coupledEvict] using hdiff
        have hne := hdiff'.cache_ne
        have hfault := hrel.fault_eq_of_ne request hrequesta hsafe
        simp [nextCouplingMode, hne, hrequesta, AccountingRel]
        omega
  | credited a b =>
      simp only [ModeRel] at hrel
      simp only [AccountingRel] at haccount
      have hcases := onePageDiff_step_cases hrel sourceEvict request hsource
      simp only [diffCoupledEvict] at hcases
      rcases hcases with hequal | hchanged | hstable
      · have hequal' :
            traceStepCache A (coupledEvict (.credited a b) A B sourceEvict request) request =
              traceStepCache B sourceEvict request := by
          simpa [coupledEvict] using hequal
        have hfault := faultInCache_le_add_one A B request
        simp [nextCouplingMode, hequal', AccountingRel]
        omega
      · rcases hchanged with ⟨hrequest, hsourceb, hdiff⟩
        subst request
        have hdiff' : OnePageDiff
            (traceStepCache A (coupledEvict (.credited a b) A B sourceEvict a) a)
            (traceStepCache B sourceEvict a) sourceEvict b := by
          simpa [coupledEvict] using hdiff
        have hne := hdiff'.cache_ne
        simp [nextCouplingMode, hne, AccountingRel, faultInCache,
          hrel.left_mem, hrel.left_not_mem_right]
        omega
      · rcases hstable with ⟨hrequesta, hdiff⟩
        have hdiff' : OnePageDiff
            (traceStepCache A (coupledEvict (.credited a b) A B sourceEvict request) request)
            (traceStepCache B sourceEvict request) a b := by
          simpa [coupledEvict] using hdiff
        have hrequestb : request ≠ b := by
          intro hrequestb
          subst request
          have hequal' :
              traceStepCache A (coupledEvict (.credited a b) A B sourceEvict b) b =
                traceStepCache B sourceEvict b := by
            simpa [coupledEvict, traceStepCache, hrel.right_not_mem_left,
              hrel.right_mem] using hrel.insert_right_erase_left
          exact hdiff'.cache_ne hequal'
        have hne := hdiff'.cache_ne
        have hfault := hrel.fault_eq_of_ne request hrequesta hrequestb
        simp [nextCouplingMode, hne, hrequesta, AccountingRel]
        omega

For distinct pages, non-strict Farther yields a strict first-use order.


lemma farther_distinct_order {σ : List Page} {start : ℕ} {a b : Page}
    (hab : a ≠ b)
    (hfarther : Farther (nextUse σ start b) (nextUse σ start a)) :
    nextUse σ start b = none ∨
      ∃ ja jb, nextUse σ start a = some ja ∧
        nextUse σ start b = some jb ∧ ja < jb := by
  rcases farther_cases hfarther with hnone | ⟨jb, ja, hb, ha, hle⟩
  · exact Or.inl hnone
  · right
    refine ⟨ja, jb, ha, hb, ?_⟩
    have hne : ja ≠ jb := by
      intro heq
      subst jb
      have hgeta := getD_eq_nextUse ha
      have hgetb := getD_eq_nextUse hb
      exact hab (hgeta.symm.trans hgetb)
    omega

No request of the farther page occurs up to the first nearer-page request.


lemma getD_ne_farther_until {σ : List Page} {start n : ℕ} {a b : Page}
    (hab : a ≠ b)
    (hfarther : Farther (nextUse σ start b) (nextUse σ start a))
    (hlen : start + n < σ.length)
    (hdeadline : ∀ j, nextUse σ start a = some j → n ≤ j) :
    σ.getD (start + n) 0 ≠ b := by
  rcases farther_distinct_order hab hfarther with hnone | ⟨ja, jb, ha, hb, hjlt⟩
  · have hnone' := nextUse_eq_none_iff.mp hnone
    apply hnone' (σ.getD (start + n) 0)
    have hnDrop : n < (σ.drop start).length := by
      rw [List.length_drop]
      omega
    have hget : (σ.drop start).getD n 0 = σ.getD (start + n) 0 := by
      rw [getD_drop]
    rw [← hget]
    rw [List.getD_eq_getElem _ 0 hnDrop]
    exact List.getElem_mem hnDrop
  · exact getD_ne_nextUse hb (by omega) (by
      have hnle := hdeadline ja ha
      omega)

An ordered next mode can only come from the same ordered pair before a.

lemma nextCouplingMode_eq_ordered {mode : CouplingMode} {request sourceEvict a b : Page}
    {transformedNext sourceNext : Finset Page}
    (hnext : nextCouplingMode mode request sourceEvict transformedNext sourceNext =
      .ordered a b) :
    mode = .ordered a b ∧ request ≠ a := by
  by_cases hequal : transformedNext = sourceNext
  · simp [nextCouplingMode, hequal] at hnext
  · cases mode with
    | same => simp [nextCouplingMode, hequal] at hnext
    | ordered x y =>
        by_cases hrequest : request = x
        · simp [nextCouplingMode, hequal, hrequest] at hnext
        · simp [nextCouplingMode, hequal, hrequest] at hnext
          rcases hnext with ⟨rfl, rfl⟩
          exact ⟨rfl, hrequest⟩
    | credited x y =>
        by_cases hrequest : request = x <;>
          simp [nextCouplingMode, hequal, hrequest] at hnext

Source misses over a suffix, expressed with the legal trace cache.

def traceMissesFrom (T : LegalTrace C₀ σ) (start count : ℕ) : ℕ :=
  cacheMissesFrom T.cache σ start count

Misses of the unpackaged recursive transformed suffix.

def couplingMisses (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) (count : ℕ) : ℕ :=
  ∑ n ∈ Finset.range count,
    faultInCache (couplingCore source start A mode n).cache (σ.getD (start + n) 0)

              @[simp] lemma couplingCore_cache_succ (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) (n : ℕ) :
    (couplingCore source start A mode (n + 1)).cache =
      traceStepCache (couplingCore source start A mode n).cache
        (couplingCore source start A mode n).evict (σ.getD (start + n) 0) := by
  rfl@[simp] lemma couplingCore_mode_succ (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) (n : ℕ) :
    (couplingCore source start A mode (n + 1)).mode =
      nextCouplingMode (couplingCore source start A mode n).mode
        (σ.getD (start + n) 0) (source.evict (start + n))
        (couplingCore source start A mode (n + 1)).cache
        (source.cache (start + n + 1)) := by
  rfllemma couplingCore_evict_eq (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) (n : ℕ) :
    (couplingCore source start A mode n).evict =
      coupledEvict (couplingCore source start A mode n).mode
        (couplingCore source start A mode n).cache (source.cache (start + n))
        (source.evict (start + n)) (σ.getD (start + n) 0) := by
  cases n <;> rfl

The recursive core preserves the cache relation at every in-range boundary.


lemma couplingCore_modeRel (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (a b : Page) (hdiff : OnePageDiff A (source.cache start) a b)
    (n : ℕ) (hbound : start + n ≤ σ.length) :
    ModeRel (couplingCore source start A (.ordered a b) n).mode
      (couplingCore source start A (.ordered a b) n).cache
      (source.cache (start + n)) := by
  induction n with
  | zero => simpa [couplingCore, ModeRel] using hdiff
  | succ n ih =>
      have hlt : start + n < σ.length := by omega
      have hprev : start + n ≤ σ.length := by omega
      have hrel := ih hprev
      have hsource : σ.getD (start + n) 0 ∉ source.cache (start + n) →
          source.evict (start + n) ∈ source.cache (start + n) :=
        source.evict_mem (start + n) hlt
      have hstep := modeRel_step
        (couplingCore source start A (.ordered a b) n).mode
        (couplingCore source start A (.ordered a b) n).cache
        (source.cache (start + n)) (source.evict (start + n))
        (σ.getD (start + n) 0) hrel hsource
      have hsourceStep : source.cache (start + n + 1) =
          traceStepCache (source.cache (start + n)) (source.evict (start + n))
            (σ.getD (start + n) 0) := by
        simpa [traceStepCache] using source.step (start + n) hlt
      have hsourceStep' : source.cache (start + (n + 1)) =
          traceStepCache (source.cache (start + n)) (source.evict (start + n))
            (σ.getD (start + n) 0) := by
        simpa [Nat.add_assoc] using hsourceStep
      rw [couplingCore_mode_succ, couplingCore_cache_succ]
      rw [hsourceStep, hsourceStep']
      rw [couplingCore_evict_eq]
      exact hstep

Every transformed core fault evicts a transformed resident.


lemma couplingCore_evict_mem (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (a b : Page) (hdiff : OnePageDiff A (source.cache start) a b)
    (n : ℕ) (hbound : start + n < σ.length)
    (hmiss : σ.getD (start + n) 0 ∉
      (couplingCore source start A (.ordered a b) n).cache) :
    (couplingCore source start A (.ordered a b) n).evict ∈
      (couplingCore source start A (.ordered a b) n).cache := by
  rw [couplingCore_evict_eq]
  apply coupledEvict_mem
  · exact couplingCore_modeRel source start A a b hdiff n (by omega)
  · exact source.evict_mem (start + n) hbound
  · exact hmiss

Ordered mode can only persist for the original pair and through a's deadline.


lemma couplingCore_ordered_deadline (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (a b : Page) (n : ℕ) :
    ∀ x y, (couplingCore source start A (.ordered a b) n).mode = .ordered x y →
      x = a ∧ y = b ∧
        ∀ j, nextUse σ start a = some j → n ≤ j := by
  induction n with
  | zero =>
      intro x y hmode
      simp [couplingCore] at hmode
      rcases hmode with ⟨rfl, rfl⟩
      exact ⟨rfl, rfl, by intro j hj; omega⟩
  | succ n ih =>
      intro x y hmode
      have hnext :
          nextCouplingMode (couplingCore source start A (.ordered a b) n).mode
            (σ.getD (start + n) 0) (source.evict (start + n))
            (couplingCore source start A (.ordered a b) (n + 1)).cache
            (source.cache (start + n + 1)) = .ordered x y := by
        simpa using hmode
      rcases nextCouplingMode_eq_ordered hnext with ⟨hprev, hrequest⟩
      rcases ih x y hprev with ⟨hx, hy, hdeadline⟩
      refine ⟨hx, hy, ?_⟩
      intro j hj
      have hnle := hdeadline j hj
      by_contra hnot
      have hnj : n = j := by omega
      subst j
      have hgeta := getD_eq_nextUse hj
      exact hrequest (hgeta.trans hx.symm)

At every in-range ordered step, the source-only page is not requested.

lemma couplingCore_ordered_safe (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (a b : Page) (hdiff : OnePageDiff A (source.cache start) a b)
    (hfarther : Farther (nextUse σ start b) (nextUse σ start a))
    (n : ℕ) (hbound : start + n < σ.length) :
    OrderedSafe (couplingCore source start A (.ordered a b) n).mode
      (σ.getD (start + n) 0) := by
  cases hmode : (couplingCore source start A (.ordered a b) n).mode with
  | same => simp [OrderedSafe]
  | credited x y => simp [OrderedSafe]
  | ordered x y =>
      rcases couplingCore_ordered_deadline source start A a b n x y hmode with
        ⟨hx, hy, hdeadline⟩
      subst x
      subst y
      simpa [OrderedSafe, hmode] using
        getD_ne_farther_until hdiff.ne hfarther hbound hdeadline

              @[simp] lemma couplingMisses_zero (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) :
    couplingMisses source start A mode 0 = 0 := by
  simp [couplingMisses]lemma couplingMisses_succ (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) (n : ℕ) :
    couplingMisses source start A mode (n + 1) =
      couplingMisses source start A mode n +
        faultInCache (couplingCore source start A mode n).cache
          (σ.getD (start + n) 0) := by
  simp [couplingMisses, Finset.sum_range_succ]@[simp] lemma traceMissesFrom_zero (T : LegalTrace C₀ σ) (start : ℕ) :
    traceMissesFrom T start 0 = 0 := by
  simp [traceMissesFrom, cacheMissesFrom]lemma traceMissesFrom_succ (T : LegalTrace C₀ σ) (start n : ℕ) :
    traceMissesFrom T start (n + 1) =
      traceMissesFrom T start n +
        faultInCache (T.cache (start + n)) (σ.getD (start + n) 0) := by
  simp [traceMissesFrom, cacheMissesFrom, cacheFaultAt, Finset.sum_range_succ]

The recursive suffix maintains the local miss-accounting invariant.


lemma couplingCore_accounting (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (a b : Page) (hdiff : OnePageDiff A (source.cache start) a b)
    (hfarther : Farther (nextUse σ start b) (nextUse σ start a))
    (n : ℕ) (hbound : start + n ≤ σ.length) :
    AccountingRel (couplingCore source start A (.ordered a b) n).mode
      (couplingMisses source start A (.ordered a b) n)
      (traceMissesFrom source start n) := by
  induction n with
  | zero => simp [couplingCore, AccountingRel]
  | succ n ih =>
      have hlt : start + n < σ.length := by omega
      have hprev : start + n ≤ σ.length := by omega
      have haccount := ih hprev
      have hrel := couplingCore_modeRel source start A a b hdiff n hprev
      have hsource : σ.getD (start + n) 0 ∉ source.cache (start + n) →
          source.evict (start + n) ∈ source.cache (start + n) :=
        source.evict_mem (start + n) hlt
      have hsafe := couplingCore_ordered_safe source start A a b hdiff hfarther n hlt
      have hstep := accounting_step
        (couplingCore source start A (.ordered a b) n).mode
        (couplingCore source start A (.ordered a b) n).cache
        (source.cache (start + n)) (source.evict (start + n))
        (σ.getD (start + n) 0)
        (couplingMisses source start A (.ordered a b) n)
        (traceMissesFrom source start n) hrel hsource hsafe haccount
      have hsourceStep : source.cache (start + n + 1) =
          traceStepCache (source.cache (start + n)) (source.evict (start + n))
            (σ.getD (start + n) 0) := by
        simpa [traceStepCache] using source.step (start + n) hlt
      rw [couplingMisses_succ, traceMissesFrom_succ]
      rw [couplingCore_mode_succ, couplingCore_cache_succ]
      rw [hsourceStep, couplingCore_evict_eq]
      exact hstep

lemma AccountingRel.le {mode : CouplingMode} {transformed source : ℕ}
    (h : AccountingRel mode transformed source) : transformed ≤ source := by
  cases mode <;> simp only [AccountingRel] at h <;> omega

The recursive transformed suffix has no more misses than the source suffix.

lemma couplingMisses_le (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (a b : Page) (hdiff : OnePageDiff A (source.cache start) a b)
    (hfarther : Farther (nextUse σ start b) (nextUse σ start a))
    (count : ℕ) (hbound : start + count ≤ σ.length) :
    couplingMisses source start A (.ordered a b) count ≤
      traceMissesFrom source start count :=
  (couplingCore_accounting source start A a b hdiff hfarther count hbound).le

Focused executable checks for the three critical coupling branches.

              

example :
    traceStepCache ({1, 3} : Finset Page)
        (coupledEvict (.ordered 1 2) {1, 3} {2, 3} 2 4) 4 =
      traceStepCache ({2, 3} : Finset Page) 2 4 := by
  have hdiff : OnePageDiff ({1, 3} : Finset Page) {2, 3} 1 2 := by
    simp [OnePageDiff]
  simp [coupledEvict, traceStepCache, hdiff.erase_eq]

example : OnePageDiff
    ({1, 3} : Finset Page)
    (traceStepCache ({2, 3} : Finset Page) 3 1) 3 2 := by
  have hdiff : OnePageDiff ({1, 3} : Finset Page) {2, 3} 1 2 := by
    simp [OnePageDiff]
  simpa [traceStepCache] using hdiff.hit_left_fault 3 (by decide) (by decide)

example :
    traceStepCache ({1, 3} : Finset Page)
        (coupledEvict (.credited 1 2) {1, 3} {2, 3} 0 2) 2 =
      ({2, 3} : Finset Page) := by
  have hdiff : OnePageDiff ({1, 3} : Finset Page) {2, 3} 1 2 := by
    simp [OnePageDiff]
  change insert 2 (({1, 3} : Finset Page).erase 1) = ({2, 3} : Finset Page)
  exact hdiff.insert_right_erase_leftlemma coupledCache_of_le (source : LegalTrace C₀ σ) (start : ℕ)
    (A : Finset Page) (mode : CouplingMode) (s : ℕ) (hs : start ≤ s) :
    coupledCache source start A mode s =
      (couplingCore source start A mode (s - start)).cache := by
  simp [coupledCache, Nat.not_lt.mpr hs]

Package the boundary-aware splice as a legal trace.


def coupledLegalTrace (source : LegalTrace C₀ σ) (start : ℕ)
    (hstartPos : 0 < start) (_hstart : start ≤ σ.length)
    (A : Finset Page) (boundaryEvict a b : Page)
    (hboundaryMem :
      σ.getD (start - 1) 0 ∉ source.cache (start - 1) →
        boundaryEvict ∈ source.cache (start - 1))
    (hboundaryStep :
      A = traceStepCache (source.cache (start - 1)) boundaryEvict
        (σ.getD (start - 1) 0))
    (hdiff : OnePageDiff A (source.cache start) a b) :
    LegalTrace C₀ σ where
  cache := coupledCache source start A (.ordered a b)
  evict := coupledTraceEvict source start boundaryEvict A (.ordered a b)
  init := by
    rw [coupledCache_of_lt source start A (.ordered a b) 0 hstartPos]
    exact source.init
  step := by
    intro t ht
    change coupledCache source start A (.ordered a b) (t + 1) =
      traceStepCache (coupledCache source start A (.ordered a b) t)
        (coupledTraceEvict source start boundaryEvict A (.ordered a b) t)
        (σ.getD t 0)
    by_cases hprefix : t + 1 < start
    · have htstart : t < start := by omega
      simpa [coupledCache, coupledTraceEvict, hprefix, htstart, traceStepCache] using
        source.step t ht
    · by_cases hboundary : t + 1 = start
      · have htEq : t = start - 1 := by omega
        subst t
        have hminus : start - 1 + 1 = start := by omega
        have hltprev : start - 1 < start := by omega
        simpa [coupledCache, coupledTraceEvict, hminus, hltprev] using hboundaryStep
      · have htge : start ≤ t := by omega
        have hsuccge : start ≤ t + 1 := by omega
        have hsubsucc : (t + 1) - start = (t - start) + 1 := by omega
        have habsolute : start + (t - start) = t := by omega
        rw [coupledCache_of_le source start A (.ordered a b) t htge]
        rw [coupledCache_of_le source start A (.ordered a b) (t + 1) hsuccge]
        have hevict :
            coupledTraceEvict source start boundaryEvict A (.ordered a b) t =
              (couplingCore source start A (.ordered a b) (t - start)).evict := by
          simp [coupledTraceEvict, hprefix, hboundary]
        rw [hevict, hsubsucc, couplingCore_cache_succ, habsolute]
  evict_mem := by
    intro t ht hmiss
    by_cases hprefix : t + 1 < start
    · have htstart : t < start := by omega
      have hmissSource : σ.getD t 0 ∉ source.cache t := by
        simpa [coupledCache, htstart] using hmiss
      simpa [coupledCache, coupledTraceEvict, hprefix, htstart] using
        source.evict_mem t ht hmissSource
    · by_cases hboundary : t + 1 = start
      · have htEq : t = start - 1 := by omega
        subst t
        have hminus : start - 1 + 1 = start := by omega
        have hltprev : start - 1 < start := by omega
        have hmissSource :
            σ.getD (start - 1) 0 ∉ source.cache (start - 1) := by
          simpa [coupledCache, hltprev] using hmiss
        simpa [coupledCache, coupledTraceEvict, hminus, hltprev] using
          hboundaryMem hmissSource
      · have htge : start ≤ t := by omega
        have habsolute : start + (t - start) = t := by omega
        have hmissCore : σ.getD (start + (t - start)) 0 ∉
            (couplingCore source start A (.ordered a b) (t - start)).cache := by
          simpa [habsolute, coupledCache, Nat.not_lt.mpr htge] using hmiss
        have hcore := couplingCore_evict_mem source start A a b hdiff (t - start)
          (by simpa [habsolute] using ht) hmissCore
        simpa [coupledCache, coupledTraceEvict, Nat.not_lt.mpr htge,
          hprefix, hboundary] using hcore

Split a legal trace's total misses into a prefix and a shifted suffix.


lemma traceMisses_split (T : LegalTrace C₀ σ) (start : ℕ)
    (hstart : start ≤ σ.length) :
    traceMisses T =
      traceMissesFrom T 0 start +
        traceMissesFrom T start (σ.length - start) := by
  unfold traceMisses traceMissesFrom cacheMissesFrom cacheFaultAt traceFaultAt
  rw [show σ.length = start + (σ.length - start) by omega]
  rw [Finset.sum_range_add]
  simp [faultInCache]

Suffix miss counts agree when the boundary caches agree pointwise.


lemma traceMissesFrom_congr (T U : LegalTrace C₀ σ) (start count : ℕ)
    (hcache : ∀ n, n < count → T.cache (start + n) = U.cache (start + n)) :
    traceMissesFrom T start count = traceMissesFrom U start count := by
  unfold traceMissesFrom cacheMissesFrom
  apply Finset.sum_congr rfl
  intro n hn
  unfold cacheFaultAt
  rw [hcache n (Finset.mem_range.mp hn)]

The splice has the same strict-prefix miss count as the source.

lemma coupledLegalTrace_prefix_misses
    (source : LegalTrace C₀ σ) (start : ℕ)
    (hstartPos : 0 < start) (hstart : start ≤ σ.length)
    (A : Finset Page) (boundaryEvict a b : Page)
    (hboundaryMem :
      σ.getD (start - 1) 0 ∉ source.cache (start - 1) →
        boundaryEvict ∈ source.cache (start - 1))
    (hboundaryStep :
      A = traceStepCache (source.cache (start - 1)) boundaryEvict
        (σ.getD (start - 1) 0))
    (hdiff : OnePageDiff A (source.cache start) a b) :
    traceMissesFrom
        (coupledLegalTrace source start hstartPos hstart A boundaryEvict a b
          hboundaryMem hboundaryStep hdiff)
        0 start =
      traceMissesFrom source 0 start := by
  apply traceMissesFrom_congr
  intro n hn
  change coupledCache source start A (.ordered a b) (0 + n) = source.cache (0 + n)
  simpa using coupledCache_of_lt source start A (.ordered a b) n hn

The splice's shifted suffix miss count is the recursive core miss count.


lemma coupledLegalTrace_suffix_misses
    (source : LegalTrace C₀ σ) (start : ℕ)
    (hstartPos : 0 < start) (hstart : start ≤ σ.length)
    (A : Finset Page) (boundaryEvict a b : Page)
    (hboundaryMem :
      σ.getD (start - 1) 0 ∉ source.cache (start - 1) →
        boundaryEvict ∈ source.cache (start - 1))
    (hboundaryStep :
      A = traceStepCache (source.cache (start - 1)) boundaryEvict
        (σ.getD (start - 1) 0))
    (hdiff : OnePageDiff A (source.cache start) a b)
    (count : ℕ) :
    traceMissesFrom
        (coupledLegalTrace source start hstartPos hstart A boundaryEvict a b
          hboundaryMem hboundaryStep hdiff)
        start count =
      couplingMisses source start A (.ordered a b) count := by
  unfold traceMissesFrom cacheMissesFrom couplingMisses
  apply Finset.sum_congr rfl
  intro n hn
  unfold cacheFaultAt
  change faultInCache (coupledCache source start A (.ordered a b) (start + n))
      (σ.getD (start + n) 0) =
    faultInCache (couplingCore source start A (.ordered a b) n).cache
      (σ.getD (start + n) 0)
  rw [coupledCache_of_le source start A (.ordered a b) (start + n) (by omega)]
  simp

Boundary-aware ordered/credited coupling constructs a legal full trace and does not increase total misses.


theorem exists_coupled_suffix
    (source : LegalTrace C₀ σ) (start : ℕ)
    (hstartPos : 0 < start) (hstart : start ≤ σ.length)
    (A : Finset Page) (boundaryEvict a b : Page)
    (hboundaryMem :
      σ.getD (start - 1) 0 ∉ source.cache (start - 1) →
        boundaryEvict ∈ source.cache (start - 1))
    (hboundaryStep :
      A = traceStepCache (source.cache (start - 1)) boundaryEvict
        (σ.getD (start - 1) 0))
    (hdiff : OnePageDiff A (source.cache start) a b)
    (hfarther : Farther (nextUse σ start b) (nextUse σ start a)) :
    ∃ transformed : LegalTrace C₀ σ,
      (∀ s, s < start → transformed.cache s = source.cache s) ∧
      transformed.cache start = A ∧
      traceMisses transformed ≤ traceMisses source := by
  let transformed := coupledLegalTrace source start hstartPos hstart A boundaryEvict a b
    hboundaryMem hboundaryStep hdiff
  refine ⟨transformed, ?_, ?_, ?_⟩
  · intro s hs
    exact coupledCache_of_lt source start A (.ordered a b) s hs
  · exact coupledCache_start source start A (.ordered a b)
  · have hprefix := coupledLegalTrace_prefix_misses source start hstartPos hstart
      A boundaryEvict a b hboundaryMem hboundaryStep hdiff
    have hsuffixEq := coupledLegalTrace_suffix_misses source start hstartPos hstart
      A boundaryEvict a b hboundaryMem hboundaryStep hdiff (σ.length - start)
    have hbound : start + (σ.length - start) ≤ σ.length := by omega
    have hsuffix := couplingMisses_le source start A a b hdiff hfarther
      (σ.length - start) hbound
    calc
      traceMisses transformed =
          traceMissesFrom transformed 0 start +
            traceMissesFrom transformed start (σ.length - start) :=
        traceMisses_split transformed start hstart
      _ = traceMissesFrom source 0 start +
            couplingMisses source start A (.ordered a b) (σ.length - start) := by
        rw [hprefix, hsuffixEq]
      _ ≤ traceMissesFrom source 0 start +
            traceMissesFrom source start (σ.length - start) :=
        Nat.add_le_add_left hsuffix _
      _ = traceMisses source := (traceMisses_split source start hstart).symm

end Cachingend CLRS

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.Optimality.Trace.A5_Exchange

Section 15.4 optimality: one-step FIF exchange

At the first transition where a legal trace differs from farthest-in-future, replace that eviction and couple the remaining suffix without increasing misses.

              namespace CLRSopen Finsetnamespace Caching

Agreement of cache boundaries with farthest-in-future through n.

def TraceAgreesWithFIF (T : LegalTrace C₀ σ) (n : ℕ) : Prop :=
  ∀ s, s ≤ n → T.cache s = cacheSeq (fifoPolicy σ) C₀ σ s

One local exchange extends FIF agreement by one boundary without more misses.


theorem exchange_trace
    (T : LegalTrace C₀ σ) (t : ℕ) (ht : t < σ.length)
    (hagree : TraceAgreesWithFIF T t)
    (hdis : T.cache (t + 1) ≠ cacheSeq (fifoPolicy σ) C₀ σ (t + 1)) :
    ∃ T' : LegalTrace C₀ σ,
      TraceAgreesWithFIF T' (t + 1) ∧
      traceMisses T' ≤ traceMisses T := by
  have hpre : T.cache t = cacheSeq (fifoPolicy σ) C₀ σ t := hagree t (by omega)
  have hmiss : σ.getD t 0 ∉ T.cache t := by
    intro hmem
    have hTnext := T.cache_succ_of_mem t ht hmem
    have hFmem : σ.getD t 0 ∈ cacheSeq (fifoPolicy σ) C₀ σ t := by
      rw [← hpre]
      exact hmem
    have hFnext : cacheSeq (fifoPolicy σ) C₀ σ (t + 1) =
        cacheSeq (fifoPolicy σ) C₀ σ t := by
      change (fifoPolicy σ).step t (cacheSeq (fifoPolicy σ) C₀ σ t)
          (σ.getD t 0) = cacheSeq (fifoPolicy σ) C₀ σ t
      exact fifo_step_of_mem σ t _ _ hFmem
    apply hdis
    calc
      T.cache (t + 1) = T.cache t := hTnext
      _ = cacheSeq (fifoPolicy σ) C₀ σ t := hpre
      _ = cacheSeq (fifoPolicy σ) C₀ σ (t + 1) := hFnext.symm

  let q : Page := T.evict t
  let p : Page := farthestInFuture (T.cache t) σ t
  have hq : q ∈ T.cache t := T.evict_mem t ht hmiss
  have hnonempty : (T.cache t).Nonempty := ⟨q, hq⟩
  have hp : p ∈ T.cache t := mem_farthestInFuture hnonempty
  have hTnext : T.cache (t + 1) =
      insert (σ.getD t 0) ((T.cache t).erase q) := by
    simpa [q] using T.cache_succ_of_not_mem t ht hmiss
  have hFnext : cacheSeq (fifoPolicy σ) C₀ σ (t + 1) =
      insert (σ.getD t 0) ((T.cache t).erase p) := by
    change (fifoPolicy σ).step t (cacheSeq (fifoPolicy σ) C₀ σ t)
        (σ.getD t 0) = _
    rw [← hpre]
    simpa [p] using fifo_step_fault σ t (T.cache t) (σ.getD t 0) hmiss
  have hqp : q ≠ p := by
    intro hqp
    apply hdis
    rw [hTnext, hFnext, hqp]
  have hdiff : OnePageDiff
      (cacheSeq (fifoPolicy σ) C₀ σ (t + 1)) (T.cache (t + 1)) q p := by
    rw [hFnext, hTnext]
    exact OnePageDiff.of_common_fault hmiss hp hq hqp
  have hfarther :
      Farther (nextUse σ (t + 1) p) (nextUse σ (t + 1) q) := by
    simpa [p] using farthestInFuture_max (σ := σ) (i := t) (p := q) hq
  have hsub : t + 1 - 1 = t := by omega
  have hboundaryMem :
      σ.getD (t + 1 - 1) 0 ∉ T.cache (t + 1 - 1) →
        p ∈ T.cache (t + 1 - 1) := by
    simpa [hsub] using fun _ : σ.getD t 0 ∉ T.cache t => hp
  have hboundaryStep :
      cacheSeq (fifoPolicy σ) C₀ σ (t + 1) =
        traceStepCache (T.cache (t + 1 - 1)) p (σ.getD (t + 1 - 1) 0) := by
    rw [hsub, hFnext]
    unfold traceStepCache
    split
    · contradiction
    · rfl
  rcases exists_coupled_suffix T (t + 1) (by omega) (by omega)
      (cacheSeq (fifoPolicy σ) C₀ σ (t + 1)) p q p
      hboundaryMem hboundaryStep hdiff hfarther with
    ⟨T', hprefix, hstartCache, hmisses⟩
  refine ⟨T', ?_, hmisses⟩
  intro s hs
  by_cases hsend : s = t + 1
  · subst s
    exact hstartCache
  · have hslt : s < t + 1 := by omega
    calc
      T'.cache s = T.cache s := hprefix s hslt
      _ = cacheSeq (fifoPolicy σ) C₀ σ s := hagree s (by omega)

end Cachingend CLRS

CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching.Optimality.Trace.A6_Iteration

Section 15.4 optimality: finite exchange iteration

Repeatedly extend agreement by one request boundary. The remaining number of boundaries is the sole termination measure.

              namespace CLRSopen Finsetopen scoped BigOperatorsnamespace Caching

Full cache-boundary agreement with FIF gives exactly the FIF miss count.


lemma traceMisses_eq_fifo_of_agree
    (T : LegalTrace C₀ σ)
    (hagree : TraceAgreesWithFIF T σ.length) :
    traceMisses T = misses (fifoPolicy σ) C₀ σ := by
  unfold traceMisses misses traceFaultAt faultAt
  apply Finset.sum_congr rfl
  intro t ht
  rw [hagree t (by
    have := Finset.mem_range.mp ht
    omega)]

Complete FIF agreement when k request boundaries remain.


lemma exists_fully_agreeing_trace_aux
    (k n : ℕ) (hkn : n + k = σ.length)
    (T : LegalTrace C₀ σ) (hagree : TraceAgreesWithFIF T n) :
    ∃ T' : LegalTrace C₀ σ,
      TraceAgreesWithFIF T' σ.length ∧
      traceMisses T' ≤ traceMisses T := by
  induction k generalizing n T with
  | zero =>
      have hn : n = σ.length := by omega
      refine ⟨T, ?_, le_rfl⟩
      simpa [hn] using hagree
  | succ k ih =>
      have hnlt : n < σ.length := by omega
      by_cases hnext :
          T.cache (n + 1) = cacheSeq (fifoPolicy σ) C₀ σ (n + 1)
      · have hagreeNext : TraceAgreesWithFIF T (n + 1) := by
          intro s hs
          by_cases hsn : s = n + 1
          · subst s
            exact hnext
          · exact hagree s (by omega)
        exact ih (n + 1) (by omega) T hagreeNext
      · rcases exchange_trace T n hnlt hagree hnext with
          ⟨T₁, hagree₁, hmiss₁⟩
        rcases ih (n + 1) (by omega) T₁ hagree₁ with
          ⟨T₂, hagree₂, hmiss₂⟩
        exact ⟨T₂, hagree₂, Nat.le_trans hmiss₂ hmiss₁⟩

Every legal trace can be exchanged into a fully FIF-agreeing trace.


theorem exists_fully_agreeing_trace (T : LegalTrace C₀ σ) :
    ∃ T' : LegalTrace C₀ σ,
      TraceAgreesWithFIF T' σ.length ∧
      traceMisses T' ≤ traceMisses T := by
  have hagreeZero : TraceAgreesWithFIF T 0 := by
    intro s hs
    have hs0 : s = 0 := by omega
    subst s
    change T.cache 0 = C₀
    exact T.init
  exact exists_fully_agreeing_trace_aux σ.length 0 (by simp) T hagreeZero

Development theorem: farthest-in-future is optimal among all policies.

theorem fifo_optimal_trace
    (π : Policy) (C₀ : Finset Page) (σ : List Page)
    (hC₀ : C₀.Nonempty) :
    misses (fifoPolicy σ) C₀ σ ≤ misses π C₀ σ := by
  rcases exists_fully_agreeing_trace (policyTrace π C₀ σ hC₀) with
    ⟨T, hagree, hmisses⟩
  calc
    misses (fifoPolicy σ) C₀ σ = traceMisses T :=
      (traceMisses_eq_fifo_of_agree T hagree).symm
    _ ≤ traceMisses (policyTrace π C₀ σ hC₀) := hmisses
    _ = misses π C₀ σ := traceMisses_policyTrace π C₀ σ hC₀

end Cachingend CLRS

Scope and implementation notes

Imports

import CLRSLean.Chapter_16
import CLRSLean.FourthEdition.Chapter_15.Section_15_1_Activity_Selection
import CLRSLean.FourthEdition.Chapter_15.Section_15_1_Activity_Selection.TextbookModel
import CLRSLean.FourthEdition.Chapter_15.Section_15_1_Activity_Selection.Iterative
import CLRSLean.FourthEdition.Chapter_15.Section_15_2_Greedy_Meta
import CLRSLean.FourthEdition.Chapter_15.Section_15_2_Greedy_Meta.ActivitySelection
import CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes
import CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.TextbookCost
import CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.TextbookLemmas
import CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.Complexity
import CLRSLean.FourthEdition.Chapter_15.Section_15_3_Huffman_Codes.HeapExecution
import CLRSLean.FourthEdition.Chapter_15.Section_15_4_Offline_Caching

Current source

Sections 15.1--15.3 are native fourth-edition sections (activity selection, the greedy-choice/optimal-substructure meta-theorems, and Huffman codes). Their textbook-facing companion modules add the iterative activity selector and exact scan count, a concrete activity-selection instance of the meta-theorem, Huffman equation (15.4), named Lemma 15.2/15.3 interfaces, and explicit cost models. They are imported directly from Section 15.1, Section 15.2, and Section 15.3. Declarations keep their legacy namespaces (CLRS.ActivitySelection, CLRS.GreedyMeta, CLRS.HuffmanV2); the third-edition-numbered imports CLRSLean.Chapter_16 and CLRSLean.Chapter_16.Section_16_* forward to these sources during the compatibility period.

Coverage boundary

Section 15.4 (offline caching) is a native fourth-edition section. Its finite cache model, farthest-in-future policy, legal-trace exchange construction, and public optimality theorems CLRS.Caching.fifo_optimal and CLRS.Caching.fifo_optimal_from_empty prove optimality for every finite request sequence from a nonempty eviction-phase cache, and from a literal empty cache whose core execution has capacity one after the first load. It is imported through Section 15.4. The section is split into the sub-modules:

This completion is at the mathematical cache-policy level. Pointer/RAM implementations and hardware caching costs remain optional refinements outside the advertised theorem boundary. An arbitrary-capacity compulsory-fill phase is not implemented here. The policy-independent compulsoryFillCost bridge assumes a supplied fill cost, resident set, and remaining suffix. It proves the arithmetic transfer of optimality, not a general-capacity empty-start execution.

The third-edition Sections 16.4 (matroids) and 16.5 (task scheduling) are retained as supplementary online material (reachable through CLRSLean.OnlineMaterial).

See docs/clrs-fourth-edition-map.csv for the section-level mapping and docs/migrations/clrs4.md for compatibility and deprecation policy.

CLRS, fourth edition · Chapter 15 of 35

15.1. Activity Selection

Activities and feasibility

Earliest finishing activity

Subproblems and greedy selection

Maximum-cardinality certificates

Definitions and proofs

CLRS GREEDY-ACTIVITY-SELECTOR

Exact scan cost

CLRS §15.1 textbook activity inputs

15.2. Greedy-Choice Property and Optimal Substructure (Meta-Theorems)

The abstract GreedyProblem structure

Generic recursive greedy solver

Meta-theorem (CLRS §15.2)

Predicate form of the greedy properties

Definitions and proofs

Activity selection as a GreedyProblem

15.3. Huffman Codes

Trees, forests, and the Huffman algorithm

Alphabet, frequency, and depth lemmas

splitLeaf infrastructure

Basic swap invariants

Frequency and depth behavior under swaps

Consistency and cost behavior under exchanges

Merging sibling leaves

Commuting split leaves through Huffman merging

insortTree commutation with map splitLeaf

insortTree membership

General commutation theorem

Special case for optimum_huffman

Preservation of forest frequencies and alphabets

Core exchange and split-leaf optimality theorem

Split-leaf optimality interface

Bundled forest invariant and greedy-step certificate

Specification of mergeCheapest

Frequency-table interface

Definitions and proofs

Huffman comparison accounting

List-backed binary heap execution

Costed binary-heap Huffman execution

Costed heap construction

Costed Huffman merge loop

Public costed program

Stable entries for the executable Huffman heap

Complete heap-based Huffman execution

One verified merge transition

Total heap execution

Verified structural operations for the Huffman binary heap

Controller erasure and structural laws

Heap invariant preservation

Packaged ranked heap

Bounded binary min-heap for Huffman priorities

Order-preserving finite ranks for Huffman heap entries

Refinement from binary heaps to sorted Huffman queues

Heap operation observations

Erasing stable entries to the existing sorted forest

Verified binary-heap Huffman interface

Huffman textbook cost

Textbook interfaces for Huffman Lemmas 15.2 and 15.3

15.4. Offline caching

Implementation details

Definitions and proofs

S1. Cache model

S2. The farthest-in-future eviction

S3. Optimality of the farthest-in-future policy

Empty-start boundary for offline caching

Section 15.4 optimality: legal cache traces

Section 15.4 optimality: exact one-page cache difference

Section 15.4 optimality: recursive coupling core

Section 15.4 optimality: coupling correctness

Section 15.4 optimality: one-step FIF exchange

Section 15.4 optimality: finite exchange iteration

Scope and implementation notes

Current source

Coverage boundary

The abstract `GreedyProblem` structure

Activity selection as a `GreedyProblem`

`insortTree` commutation with `map splitLeaf`

`insortTree` membership

Special case for `optimum_huffman`

Specification of `mergeCheapest`