import .lovelib

/- # LoVe Demo 8: Operational Semantics

In this and the next two lectures, we will see how to use Lean to specify the
syntax and semantics of programming languages and to reason about the
semantics. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/- ## Formal Semantics

A formal semantics helps specify and reason about the programming language
itself, and about individual programs.

It can form the basis of verified compilers, interpreters, verifiers, static
analyzers, type checkers, etc. Without formal proofs, these tools are
**almost always wrong**.

In this area, proof assistants are widely used. Every year, about 10-20% of POPL
papers are partially or totally formalized. Reasons for this success:

* Little machinery (background libraries, tactics) is needed to get started,
  beyond inductive types and predicates and recursive functions.

* The proofs tend to have lots of cases, which is a good match for computers.

* Proof assistants keep track of what needs to be changed when as extend the
  programming language with more features.

Case in point: WebAssembly. To quote Conrad Watt (with some abbreviations):

    We have produced a full Isabelle mechanisation of the core execution
    semantics and type system of the WebAssembly language. To complete this
    proof, **several deficiencies** in the official WebAssembly specification,
    uncovered by our proof and modelling work, needed to be corrected. In some
    cases, these meant that the type system was **originally unsound**.

    We have maintained a constructive dialogue with the working group,
    verifying new features as they are added. In particular, the mechanism by
    which a WebAssembly implementation interfaces with its host environment was
    not formally specified in the working group's original paper. Extending our
    mechanisation to model this feature revealed a deficiency in the WebAssembly
    specification that **sabotaged the soundness** of the type system.

## A Minimalistic Imperative Language

__WHILE__ is a minimalistic imperative language with the following grammar:

    S  ::=  skip                 -- no-op
         |  x := a               -- assignment
         |  S ; S                -- sequential composition
         |  if b then S else S   -- conditional statement
         |  while b do S         -- while loop

where `S` stands for a statement (also called command or program), `x` for a
variable, `a` for an arithmetic expression, and `b` for a Boolean expression. -/

inductive stmt : Type
| skip   : stmt
| assign : string → (state → ℕ) → stmt
| seq    : stmt → stmt → stmt
| ite    : (state → Prop) → stmt → stmt → stmt
| while  : (state → Prop) → stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

/- In our grammar, we deliberately leave the syntax of arithmetic and Boolean
expressions unspecified. In Lean, we have the choice:

* We could use a type such as `aexp` from lecture 1 and similarly for Boolean
  expressions.

* Supposing a state `s` is a function from variable names to values
  (`string → ℕ`), we could decide that an arithmetic expression is simply a
  function from states to natural numbers (`state → ℕ`) and a Boolean expression
  is a predicate (`state → Prop` or `state → bool`).

This corresponds to the difference between deep and shallow embeddings:

* A __deep embedding__ of some syntax (expression, formula, program, etc.)
  consists of an abstract syntax tree specified in the proof assistant
  (e.g., `aexp`) with a semantics (e.g., `eval`).

* In contrast, a __shallow embedding__ simply reuses the corresponding
  mechanisms from the logic (e.g., λ-terms, functions and predicate types).

A deep embedding allows us to reason about the syntax (and its semantics). A
shallow embedding is more lightweight, because we can use it directly, without
having to define a semantics.

We will use a deep embedding of programs (which we find interesting), and
shallow embeddings of assignments and Boolean expressions (which we find
boring).

Examples:

    `λs : state, s "x" + s "y" + 1`   -- x + y + 1
    `λs : state, s "a" ≠ s "b"`       -- a ≠ b

## Big-Step Semantics

An __operational semantics__ corresponds to an idealized interpreter (specified
in a Prolog-like language). Two main variants:

* big-step semantics;

* small-step semantics.

In a __big-step semantics__ (also called __natural semantics__), judgments have
the form `(S, s) ⟹ t`:

    Starting in a state `s`, executing `S` terminates in the state `t`.

Example:

    `(x := x + y; y := 0, [x ↦ 3, y ↦ 5]) ⟹ [x ↦ 8, y ↦ 0]`

Derivation rules:

    ——————————————— Skip
    (skip, s) ⟹ s

    ——————————————————————————— Asn
    (x := a, s) ⟹ s[x ↦ s(a)]

    (S, s) ⟹ t   (T, t) ⟹ u
    ——————————————————————————— Seq
    (S; T, s) ⟹ u

    (S, s) ⟹ t
    ————————————————————————————— If-True   if s(b) is true
    (if b then S else T, s) ⟹ t

    (T, s) ⟹ t
    ————————————————————————————— If-False   if s(b) is false
    (if b then S else T, s) ⟹ t

    (S, s) ⟹ t   (while b do S, t) ⟹ u
    —————————————————————————————————————— While-True   if s(b) is true
    (while b do S, s) ⟹ u

    ————————————————————————— While-False   if s(b) is false
    (while b do S, s) ⟹ s

Above, `s(e)` denotes the value of expression `e` in state `s`.

In Lean, the judgment corresponds to an inductive predicate, and the derivation
rules correspond to the predicate's introduction rules. Using an inductive
predicate as opposed to a recursive function allows us to cope with
nontermination (e.g., a diverging `while`) and nondeterminism (e.g.,
multithreading). -/

inductive big_step : stmt × state → state → Prop
| skip {s} :
  big_step (stmt.skip, s) s
| assign {x a s} :
  big_step (stmt.assign x a, s) (s{x ↦ a s})
| seq {S T s t u} (hS : big_step (S, s) t)
    (hT : big_step (T, t) u) :
  big_step (S ;; T, s) u
| ite_true {b : state → Prop} {S T s t} (hcond : b s)
    (hbody : big_step (S, s) t) :
  big_step (stmt.ite b S T, s) t
| ite_false {b : state → Prop} {S T s t} (hcond : ¬ b s)
    (hbody : big_step (T, s) t) :
  big_step (stmt.ite b S T, s) t
| while_true {b : state → Prop} {S s t u} (hcond : b s)
    (hbody : big_step (S, s) t)
    (hrest : big_step (stmt.while b S, t) u) :
  big_step (stmt.while b S, s) u
| while_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  big_step (stmt.while b S, s) s

infix ` ⟹ ` : 110 := big_step

/- ## Properties of the Big-Step Semantics

Equipped with a big-step semantics, we can

* prove properties of the programming language, such as **equivalence proofs**
  between programs and **determinism**;

* reason about **concrete programs**, proving theorems relating final states `t`
  with initial states `s`. -/

lemma big_step_deterministic {S s l r} (hl : (S, s) ⟹ l)
    (hr : (S, s) ⟹ r) :
  l = r :=
begin
  induction' hl,
  case skip {
    cases' hr,
    refl },
  case assign {
    cases' hr,
    refl },
  case seq : S T s t l hS hT ihS ihT {
    cases' hr with _ _ _ _ _ _ _ t' _ hS' hT',
    cases' ihS hS',
    cases' ihT hT',
    refl },
  case ite_true : b S T s t hb hS ih {
    cases' hr,
    { apply ih hr },
    { cc } },
  case ite_false : b S T s t hb hT ih {
    cases' hr,
    { cc },
    { apply ih hr } },
  case while_true : b S s t u hb hS hw ihS ihw {
    cases' hr,
    { cases' ihS hr,
      cases' ihw hr_1,
      refl },
    { cc } },
  { cases' hr,
    { cc },
    { refl } }
end

lemma big_step_terminates {S s} :
  ∃t, (S, s) ⟹ t :=
sorry   -- unprovable

lemma big_step_doesnt_terminate {S s t} :
  ¬ (stmt.while (λ_, true) S, s) ⟹ t :=
begin
  intro hw,
  induction' hw,
  case while_true {
    assumption },
  case while_false {
    cc }
end

/- We can define inversion rules about the big-step semantics: -/

@[simp] lemma big_step_skip_iff {s t} :
  (stmt.skip, s) ⟹ t ↔ t = s :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.skip }
end

@[simp] lemma big_step_assign_iff {x a s t} :
  (stmt.assign x a, s) ⟹ t ↔ t = s{x ↦ a s} :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.assign }
end

@[simp] lemma big_step_seq_iff {S T s t} :
  (S ;; T, s) ⟹ t ↔ (∃u, (S, s) ⟹ u ∧ (T, u) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    apply exists.intro,
    apply and.intro; assumption },
  { intro h,
    cases' h,
    cases' h,
    apply big_step.seq; assumption }
end

@[simp] lemma big_step_ite_iff {b S T s t} :
  (stmt.ite b S T, s) ⟹ t ↔
  (b s ∧ (S, s) ⟹ t) ∨ (¬ b s ∧ (T, s) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h; cases' h,
    { apply big_step.ite_true; assumption },
    { apply big_step.ite_false; assumption } }
end

lemma big_step_while_iff {b S s u} :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, b s ∧ (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u)
  ∨ (¬ b s ∧ u = s) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro t,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    case inl {
      cases' h with t h,
      cases' h with hb h,
      cases' h with hS hwhile,
      exact big_step.while_true hb hS hwhile },
    case inr {
      cases' h with hb hus,
      rw hus,
      exact big_step.while_false hb } }
end

lemma big_step_while_true_iff {b : state → Prop} {S s u}
    (hcond : b s) :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u) :=
by rw big_step_while_iff; simp [hcond]

@[simp] lemma big_step_while_false_iff {b : state → Prop}
    {S s t} (hcond : ¬ b s) :
  (stmt.while b S, s) ⟹ t ↔ t = s :=
by rw big_step_while_iff; simp [hcond]

/- ## Small-Step Semantics

A big-step semantics

* does not let us reason about intermediate states;

* does not let us express nontermination or interleaving (for multithreading).

__Small-step semantics__ (also called __structural operational semantics__)
solve the above issues.

A judgment has the form `(S, s) ⇒ (T, t)`:

    Starting in a state `s`, executing one step of `S` leaves us in the
    state `t`, with the program `T` remaining to be executed.

An execution is a finite or infinite chain `(S₀, s₀) ⇒ (S₁, s₁) ⇒ …`.

A pair `(S, s)` is called a __configuration__. It is __final__ if no transition
of the form `(S, s) ⇒ _` is possible.

Example:

      `(x := x + y; y := 0, [x ↦ 3, y ↦ 5])`
    `⇒ (skip; y := 0,       [x ↦ 8, y ↦ 5])`
    `⇒ (y := 0,             [x ↦ 8, y ↦ 5])`
    `⇒ (skip,               [x ↦ 8, y ↦ 0])`

Derivation rules:

    ————————————————————————————————— Asn
    (x := a, s) ⇒ (skip, s[x ↦ s(a)])

    (S, s) ⇒ (S', s')
    ———-————————————————————— Seq-Step
    (S ; T, s) ⇒ (S' ; T, s')

    —————————————————————— Seq-Skip
    (skip ; S, s) ⇒ (S, s)

    ———————————————————————————————— If-True   if s(b) is true
    (if b then S else T, s) ⇒ (S, s)

    ———————————————————————————————— If-False   if s(b) is false
    (if b then S else T, s) ⇒ (T, s)

    ——————————————————————————————————————————————————————————————— While
    (while b do S, s) ⇒ (if b then (S ; while b do S) else skip, s)

There is no rule for `skip` (why?). -/

inductive small_step : stmt × state → stmt × state → Prop
| assign {x a s} :
  small_step (stmt.assign x a, s) (stmt.skip, s{x ↦ a s})
| seq_step {S S' T s s'} (hS : small_step (S, s) (S', s')) :
  small_step (S ;; T, s) (S' ;; T, s')
| seq_skip {T s} :
  small_step (stmt.skip ;; T, s) (T, s)
| ite_true {b : state → Prop} {S T s} (hcond : b s) :
  small_step (stmt.ite b S T, s) (S, s)
| ite_false {b : state → Prop} {S T s} (hcond : ¬ b s) :
  small_step (stmt.ite b S T, s) (T, s)
| while {b : state → Prop} {S s} :
  small_step (stmt.while b S, s)
    (stmt.ite b (S ;; stmt.while b S) stmt.skip, s)

infixr ` ⇒ ` := small_step
infixr ` ⇒* ` : 100 := star small_step

/- Equipped with a small-step semantics, we can **define** a big-step
semantics:

    `(S, s) ⟹ t` if and only if `(S, s) ⇒* (skip, t)`

where `r*` denotes the reflexive transitive closure of a relation `r`.

Alternatively, if we have already defined a big-step semantics, we can **prove**
the above equivalence theorem to validate our definitions.

The main disadvantage of small-step semantics is that we now have two relations,
`⇒` and `⇒*`, and reasoning tends to be more complicated.

## Properties of the Small-Step Semantics

We can prove that a configuration `(S, s)` is final if and only if `S = skip`.
This ensures that we have not forgotten a derivation rule. -/

lemma small_step_final (S s) :
  (¬ ∃T t, (S, s) ⇒ (T, t)) ↔ S = stmt.skip :=
begin
  induction' S,
  case skip {
    simp,
    intros T t hstep,
    cases' hstep },
  case assign : x a {
    simp,
    apply exists.intro stmt.skip,
    apply exists.intro (s{x ↦ a s}),
    exact small_step.assign },
  case seq : S T ihS ihT {
    simp,
    cases' classical.em (S = stmt.skip),
    case inl {
      rw h,
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.seq_skip },
    case inr {
      simp [h, auto.not_forall_eq, auto.not_not_eq] at ihS,
      cases' ihS s with S' hS',
      cases' hS' with s' hs',
      apply exists.intro (S' ;; T),
      apply exists.intro s',
      exact small_step.seq_step hs' } },
  case ite : b S T ihS ihT {
    simp,
    cases' classical.em (b s),
    case inl {
      apply exists.intro S,
      apply exists.intro s,
      exact small_step.ite_true h },
    case inr {
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.ite_false h } },
  case while : b S ih {
    simp,
    apply exists.intro (stmt.ite b (S ;; stmt.while b S) stmt.skip),
    apply exists.intro s,
    exact small_step.while }
end

lemma small_step_deterministic {S s Ll Rr}
    (hl : (S, s) ⇒ Ll) (hr : (S, s) ⇒ Rr) :
  Ll = Rr :=
begin
  induction' hl,
  case assign : x a s {
    cases' hr,
    refl },
  case seq_step : S S₁ T s s₁ hS₁ ih {
    cases' hr,
    case seq_step : S S₂ _ _ s₂ hS₂ {
      have hSs₁₂ := ih hS₂,
      cc },
    case seq_skip {
      cases' hS₁ } },
  case seq_skip : T s {
    cases' hr,
    { cases' hr },
    { refl } },
  case ite_true : b S T s hcond {
    cases' hr,
    case ite_true {
      refl },
    case ite_false {
      cc } },
  case ite_false : b S T s hcond {
    cases' hr,
    case ite_true {
      cc },
    case ite_false {
      refl } },
  case while : b S s {
    cases' hr,
    refl }
end

/- We can define inversion rules also about the small-step semantics. Here are
three examples: -/

lemma small_step_skip {S s t} :
  ¬ ((stmt.skip, s) ⇒ (S, t)) :=
by intro h; cases' h

@[simp] lemma small_step_seq_iff {S T s Ut} :
  (S ;; T, s) ⇒ Ut ↔
  (∃S' t, (S, s) ⇒ (S', t) ∧ Ut = (S' ;; T, t))
  ∨ (S = stmt.skip ∧ Ut = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro S',
      apply exists.intro s',
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      cases' h,
      cases' h,
      rw right,
      apply small_step.seq_step,
      assumption },
    { cases' h,
      rw left,
      rw right,
      apply small_step.seq_skip } }
end

@[simp] lemma small_step_ite_iff {b S T s Us} :
  (stmt.ite b S T, s) ⇒ Us ↔
  (b s ∧ Us = (S, s)) ∨ (¬ b s ∧ Us = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      rw right,
      apply small_step.ite_true,
      assumption },
    { cases' h,
      rw right,
      apply small_step.ite_false,
      assumption } }
end

/- ### Equivalence of the Big-Step and the Small-Step Semantics (**optional**)

A more important result is the connection between the big-step and the
small-step semantics:

    `(S, s) ⟹ t ↔ (S, s) ⇒* (stmt.skip, t)`

Its proof, given below, is beyond the scope of this course. -/

lemma star_small_step_seq {S T s u}
    (h : (S, s) ⇒* (stmt.skip, u)) :
  (S ;; T, s) ⇒* (stmt.skip ;; T, u) :=
begin
  apply star.lift (λSs, (prod.fst Ss ;; T, prod.snd Ss)) _ h,
  intros Ss Ss' h,
  cases' Ss,
  cases' Ss',
  apply small_step.seq_step,
  assumption
end

lemma star_small_step_of_big_step {S s t} (h : (S, s) ⟹ t) :
  (S, s) ⇒* (stmt.skip, t) :=
begin
  induction' h,
  case skip {
    refl },
  case assign {
    exact star.single small_step.assign },
  case seq : S T s t u hS hT ihS ihT {
    transitivity,
    exact star_small_step_seq ihS,
    apply star.head small_step.seq_skip ihT },
  case ite_true : b S T s t hs hst ih {
    exact star.head (small_step.ite_true hs) ih },
  case ite_false : b S T s t hs hst ih {
    exact star.head (small_step.ite_false hs) ih },
  case while_true : b S s t u hb hS hw ihS ihw {
    exact (star.head small_step.while
      (star.head (small_step.ite_true hb)
         (star.trans (star_small_step_seq ihS)
            (star.head small_step.seq_skip ihw)))) },
  case while_false : b S s hb {
    exact star.tail (star.single small_step.while)
      (small_step.ite_false hb) }
end

lemma big_step_of_small_step_of_big_step {S₀ S₁ s₀ s₁ s₂}
  (h₁ : (S₀, s₀) ⇒ (S₁, s₁)) :
  (S₁, s₁) ⟹ s₂ → (S₀, s₀) ⟹ s₂ :=
begin
  induction' h₁;
    simp [*, big_step_while_true_iff] {contextual := tt},
  case seq_step {
    intros u hS' hT,
    apply exists.intro u,
    exact and.intro (ih hS') hT }
end

lemma big_step_of_star_small_step {S s t} :
  (S, s) ⇒* (stmt.skip, t) → (S, s) ⟹ t :=
begin
  generalize hSs : (S, s) = Ss,
  intro h,
  induction h
      using LoVe.rtc.star.head_induction_on
      with _ S's' h h' ih
      generalizing S s;
    cases' hSs,
  { exact big_step.skip },
  { cases' S's' with S' s',
    apply big_step_of_small_step_of_big_step h,
    apply ih,
    refl }
end

lemma big_step_iff_star_small_step {S s t} :
  (S, s) ⟹ t ↔ (S, s) ⇒* (stmt.skip, t) :=
iff.intro star_small_step_of_big_step
  big_step_of_star_small_step

/- ## Parallelism (**optional**) -/

inductive par_step :
    nat → list stmt × state → list stmt × state → Prop
| intro {Ss Ss' S S' s s' i}
    (hi : i < list.length Ss)
    (hS : S = list.nth_le Ss i hi)
    (hs : (S, s) ⇒ (S', s'))
    (hS' : Ss' = list.update_nth Ss i S') :
  par_step i (Ss, s) (Ss', s')

lemma par_step_diamond {i j Ss Ts Ts' s t t'}
    (hi : i < list.length Ss)
    (hj : j < list.length Ss)
    (hij : i ≠ j)
    (hT : par_step i (Ss, s) (Ts, t))
    (hT' : par_step j (Ss, s) (Ts', t')) :
  ∃u Us, par_step j (Ts, t) (Us, u) ∧
    par_step i (Ts', t') (Us, u) :=
sorry   -- unprovable

def stmt.W : stmt → set string
| stmt.skip         := ∅
| (stmt.assign x _) := {x}
| (stmt.seq S T)    := stmt.W S ∪ stmt.W T
| (stmt.ite _ S T)  := stmt.W S ∪ stmt.W T
| (stmt.while _ S)  := stmt.W S

def exp.R {α : Type} : (state → α) → set string
| f := {x | ∀s n, f (s{x ↦ n}) ≠ f s}

def stmt.R : stmt → set string
| stmt.skip         := ∅
| (stmt.assign _ a) := exp.R a
| (stmt.seq S T)    := stmt.R S ∪ stmt.R T
| (stmt.ite b S T)  := exp.R b ∪ stmt.R S ∪ stmt.R T
| (stmt.while b S)  := exp.R b ∪ stmt.R S

def stmt.V : stmt → set string
| S := stmt.W S ∪ stmt.R S

lemma par_step_diamond_VW_disjoint {i j Ss Ts Ts' s t t'}
    (hiS : i < list.length Ss)
    (hjT : j < list.length Ts)
    (hij : i ≠ j)
    (hT : par_step i (Ss, s) (Ts, t))
    (hT' : par_step j (Ss, s) (Ts', t'))
    (hWV : stmt.W (list.nth_le Ss i hiS)
       ∩ stmt.V (list.nth_le Ts j hjT) = ∅)
    (hVW : stmt.V (list.nth_le Ss i hiS)
       ∩ stmt.W (list.nth_le Ts j hjT) = ∅) :
  ∃u Us, par_step j (Ts, t) (Us, u) ∧
    par_step i (Ts', t') (Us, u) :=
sorry   -- this should be provable

end LoVe


import Graph.Graph
import Graph.UndirectedGraph
import Std.Data.Queue
import Std.Data.Stack
import Std.Data.HashSet

/-!
## Traverse (old)

*Note that this module in not imported by default through `import Graph`, import it explicitly using `import Graph.TraverseDeprecated`.*

This is a nice implementation of depth- and breadth-first search using shared code and a stack and queue respectively. However, due to the limitations of such an implementation these functions are fairly inefficient, in general you should rather use `Graph.Traverse`.
-/

import Graph.Container

namespace Graph

open Internal

variable {α : Type} [Inhabited α] {β : Type}

private def traverseAux {containerType : Type _} (g : Graph α β) (startingContainer : Container (Nat × Bool) containerType) (startingSources : Array Nat) (startingState : γ) (visit : Nat -> γ -> γ × Bool) (leave : Option (Nat -> γ -> γ)) : γ := do
  let mut visited : Array Bool := mkArray g.vertexCount false
  let mut state := startingState
  let mut container := startingContainer
  let mut sources := startingSources
  let mut terminate? : Bool := false
  for i in [0:maximumIterationCount] do
    match container.remove? with
      | none =>
        if terminate? || sources.isEmpty then break
        container := container.add (sources.back, true)
        sources := sources.pop
      | some ((currentNodeId, true), newContainer) =>
        container := newContainer
        if terminate? || visited[currentNodeId] then continue
        (state, terminate?) := visit currentNodeId state
        if !leave.isSome && terminate? then break
        visited := visited.set! currentNodeId true
        container := if leave.isSome then container.add (currentNodeId, false) else container
        container := if terminate? then container else
          let unvisitedNeighborIds := (g.vertices[currentNodeId].adjacencyList.map (λ e => e.target)).filter (λ e => !visited[e])
          let unvisitedNeighborIdsWithArrivingFlags := unvisitedNeighborIds.map (λ id => (id, true))
          container.addAll unvisitedNeighborIdsWithArrivingFlags
      | some ((currentNodeId, false), newContainer) =>
        container := newContainer
        match leave with
          | some leaveFunction => state := leaveFunction currentNodeId state
          | none => panic! "This should not be possible"

  return state
  where
    maximumIterationCount : Nat := visitingAndLeavingEachVertex + addingAllSourcesToContainer + visitingSameVertexMultipleTimes + goodMeasure
    visitingAndLeavingEachVertex := g.vertexCount * 2
    addingAllSourcesToContainer := startingSources.size
    visitingSameVertexMultipleTimes := g.edgeCount
    goodMeasure := 1

/-- A breadth-first traversal of the graph starting at the sources in order. Nodes on the same "level" of the traversal are visited in order of the edges added.
    Visit is a function executed at each vertex, its parameters are the vertex ID and the current state,
    it returns a new state and a boolean which terminates the traversal if true. Please provide a starting state.
    *Note that this function scales significantly worse than `breadthFirstTraverse`.*
    See example uses in Graph/TraverseExample.lean -/
def breadthFirstTraverseDeprecated (g : Graph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) : γ :=
  traverseAux g Container.emptyQueue sources.reverse startingState visit none

/-- A depth-first traversal of the graph starting at the sources in order. Nodes on the same "level" of the traversal are visited in order of the edges added.
    Visit is a function executed at each vertex, its parameters are the vertex ID and the current state,
    it returns a new state and a boolean which terminates the traversal if true (but will still leave the already visited nodes).
    Leave is executed when the node is left, when all its successors have been visited, uses the same state. Please provide a starting state.
    *Note that this function scales significantly worse than `dephtFirstTraverse`.*
    See example uses in Graph/TraverseExample.lean -/
def depthFirstTraverseDeprecated (g : Graph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (leave : Option (Nat -> γ -> γ ) := none) : γ :=
  traverseAux g Container.emptyStack sources.reverse startingState visit leave

namespace UndirectedGraph

/-- See directed graph. -/
def breadthFirstTraverseDeprecated (ug : UndirectedGraph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) : γ :=
  ug.graph.breadthFirstTraverseDeprecated sources startingState visit

/-- See directed graph. -/
def depthFirstTraverseDeprecated (ug : UndirectedGraph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (leave : Option (Nat -> γ -> γ ) := none) : γ :=
  ug.graph.depthFirstTraverseDeprecated sources startingState visit leave

end UndirectedGraph
end Graph


import category_theory.concrete_category
import o_minimal.definable

/-
The category of (literal) definable subsets of Rⁿ
and definable functions between them (not just continuous ones).
Used as the index category for "definable sheaves".
-/

namespace o_minimal

universe u

variables {R : Type u} (S : struc R)

structure Def : Type u :=
(ambdim : ℕ)
(to_set : set (finvec ambdim R))
(is_definable : def_set S to_set)

variables {S}

instance : has_coe_to_sort (Def S) :=
⟨Type u, λ X, X.to_set⟩

instance is_definable.Def (K : Def S) : is_definable S K :=
is_definable.subtype K.is_definable

@[ext] structure Hom (X Y : Def S) : Type u :=
(to_fun : X → Y)
(is_definable : def_fun S to_fun)

instance {X Y : Def S} : has_coe_to_fun (Hom X Y) :=
⟨_, λ f, f.to_fun⟩

instance : category_theory.small_category (Def S) :=
{ hom := Hom,
  id := λ X, ⟨id, def_fun.id⟩,
  comp := λ X Y Z f g, ⟨g.1 ∘ f.1, g.2.comp f.2⟩ }

instance : category_theory.concrete_category.{u} (Def S) :=
{ forget := { obj := λ X, X, map := λ X Y f, f },
  forget_faithful := by tidy }

section pullback

variables {X Y Z : Def S} (f : X ⟶ Z) (g : Y ⟶ Z)

def Def.pullback : Def S :=
{ ambdim := X.ambdim + Y.ambdim,
  to_set :=
    {p | ∃ (hX : p.left ∈ X.to_set) (hY : p.right ∈ Y.to_set),
         f.to_fun ⟨p.left, hX⟩ = g.to_fun ⟨p.right, hY⟩},
  is_definable := begin
    -- TODO: This proof is bad; but how to fix it?
    have := def_set_eq (f.is_definable.comp def_fun.fst) (g.is_definable.comp def_fun.snd),
    change S.definable _ at this,
    change S.definable _,
    convert this using 1,
    ext u,
    revert u,
    refine finvec.rec (λ v w, _),
    simp only [has_coordinates.subtype_coords, set.mem_image,
      function.comp_app, has_coordinates.finvec_coords, set.mem_set_of_eq,
      set.image_id', has_coordinates.prod_coords, subtype.val_eq_coe, prod.exists],
    change (∃ (hX : (v.append w).left ∈ X.to_set) (hY : (v.append w).right ∈ Y.to_set), _) ↔ _,
    split; rintro ⟨x, y, H⟩,
    { exact ⟨⟨v, by simpa using x⟩, ⟨w, by simpa using y⟩, by simpa using H, rfl⟩ },
    { obtain ⟨H₁, H₂⟩ := H,
      obtain ⟨rfl, rfl⟩ := finvec.append.inj_iff.mp H₂, clear H₂,
      refine ⟨by simp, by simp, by simp [H₁]⟩ }
  end }

def Def.pullback.π₁ : Def.pullback f g ⟶ X :=
{ to_fun := λ p, ⟨p.val.left, p.property.fst⟩,
  is_definable := def_fun_subtype_mk (def_fun.finvec.left.comp def_fun_subtype_val) _ }

def Def.pullback.π₂ : Def.pullback f g ⟶ Y :=
{ to_fun := λ p, ⟨p.val.right, p.property.snd.fst⟩,
  is_definable := def_fun_subtype_mk (def_fun.finvec.right.comp def_fun_subtype_val) _ }

end pullback

/-- A (generating) covering family of a given object `K : Def S`.
By definition, it is a finite family of definable maps which is
jointly surjective. -/
structure Def.cover (K : Def S) :=
(n : ℕ)
(obj : fin n → Def S)
(map : Π i, obj i ⟶ K)
(jointly_surjective : ∀ k, ∃ i l, map i l = k)

lemma Def.set_subcanonical
  {K : Def S} (𝓛 : K.cover) (s : set K) (h : Π i, def_set S (𝓛.map i ⁻¹' s)) :
  def_set S s :=
begin
  have : ∀ i, def_set S (𝓛.map i '' (𝓛.map i ⁻¹' s)) :=
    λ i, (𝓛.map i).is_definable.image (h i),
  convert def_set_Union this,
  ext k,
  simp only [set.mem_Union, set.mem_image, set.mem_preimage],
  split; intro hk,
  { obtain ⟨i, l, rfl⟩ := 𝓛.jointly_surjective k,
    refine ⟨i, l, hk, rfl⟩ },
  { obtain ⟨i, l, hl, rfl⟩ := hk,
    exact hl }
end

lemma Def.subcanonical {Y : Type*} [has_coordinates R Y] [is_definable S Y]
  {K : Def S} (𝓛 : K.cover) (f : K → Y) (h : Π i, def_fun S (f ∘ 𝓛.map i)) :
  def_fun S f :=
begin
  unfold def_fun at ⊢ h,
  -- We could pull back the cover to K × Y and use the previous proof,
  -- but it seems easier to just repeat it
  have : ∀ i, def_set S ((λ (p : 𝓛.obj i × Y), (𝓛.map i p.1, p.2)) '' _) :=
    λ i, ((𝓛.map i).is_definable.prod def_fun.id).image (h i),
  convert def_set_Union this using 1,
  ext ⟨k, y⟩,
  simp only [set.mem_Union, set.mem_image, prod.mk.inj_iff, function.comp_app,
    set.mem_set_of_eq, exists_eq_left', prod.exists],
  split,
  { rintro rfl,
    obtain ⟨i, l, rfl⟩ := 𝓛.jointly_surjective k,
    refine ⟨i, l, rfl, rfl⟩ },
  { rintro ⟨i, l, hl, rfl⟩,
    rw hl }
end

def Def.cover.pullback {K : Def S} (𝓛 : K.cover) {K' : Def S} (φ : K' ⟶ K) : K'.cover :=
{ n := 𝓛.n,
  obj := λ i, Def.pullback φ (𝓛.map i),
  map := λ i, Def.pullback.π₁ φ (𝓛.map i),
  jointly_surjective := λ k',
    let ⟨i, l, h⟩ := 𝓛.jointly_surjective (φ k') in
    ⟨i, ⟨finvec.append k' l, by simp, by simp, by simpa using h.symm⟩,
     by { ext1, apply finvec.left_append }⟩ }

-- TODO: add lemmas for the properties of `Def.cover.pullback` that we actually use
-- (for example, we probably don't actually need it to be formed from pullbacks)

end o_minimal


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

! This file was ported from Lean 3 source module testing.slim_check.sampleable
! leanprover-community/mathlib commit e1bccd6e40ae78370f01659715d3c948716e3b7e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.LazyList.Basic
import Mathbin.Data.Tree
import Mathbin.Data.Pnat.Basic
import Mathbin.Control.Bifunctor
import Mathbin.Control.Ulift
import Mathbin.Testing.SlimCheck.Gen
import Mathbin.Tactic.Linarith.Default

/-!
# `sampleable` Class

This class permits the creation samples of a given type
controlling the size of those values using the `gen` monad`. It also
helps minimize examples by creating smaller versions of given values.

When testing a proposition like `∀ n : ℕ, prime n → n ≤ 100`,
`slim_check` requires that `ℕ` have an instance of `sampleable` and for
`prime n` to be decidable.  `slim_check` will then use the instance of
`sampleable` to generate small examples of ℕ and progressively increase
in size. For each example `n`, `prime n` is tested. If it is false,
the example will be rejected (not a test success nor a failure) and
`slim_check` will move on to other examples. If `prime n` is true, `n
≤ 100` will be tested. If it is false, `n` is a counter-example of `∀
n : ℕ, prime n → n ≤ 100` and the test fails. If `n ≤ 100` is true,
the test passes and `slim_check` moves on to trying more examples.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `sampleable` class
  * `sampleable_functor` and `sampleable_bifunctor` class
  * `sampleable_ext` class

### `sampleable`

`sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.

### `sampleable_ext`

`sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type.

### `sampleable_functor` and `sampleable_bifunctor`

`sampleable_functor F` and `sampleable_bifunctor F` makes it possible
to create samples of and shrink `F α` given a sampling function and a
shrinking function for arbitrary `α`.

This allows us to separate the logic for generating the shape of a
collection from the logic for generating its contents. Specifically,
the contents could be generated using either `sampleable` or
`sampleable_ext` instance and the `sampleable_(bi)functor` does not
need to use that information

## Shrinking

Shrinking happens when `slim_check` find a counter-example to a
property.  It is likely that the example will be more complicated than
necessary so `slim_check` proceeds to shrink it as much as
possible. Although equally valid, a smaller counter-example is easier
for a user to understand and use.

The `sampleable` class, beside having the `sample` function, has a
`shrink` function so that we can use specialized knowledge while
shrinking a value. It is not responsible for the whole shrinking process
however. It only has to take one step in the shrinking process.
`slim_check` will repeatedly call `shrink` until no more steps can
be taken. Because `shrink` guarantees that the size of the candidates
it produces is strictly smaller than the argument, we know that
`slim_check` is guaranteed to terminate.

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/

universe u v w

namespace SlimCheck

variable (α : Type u)

-- mathport name: «expr ≺ »
local infixl:50 " ≺ " => WellFoundedRelation.R

/-- `sizeof_lt x y` compares the sizes of `x` and `y`. -/
def SizeofLt {α} [SizeOf α] (x y : α) :=
  SizeOf.sizeOf x < SizeOf.sizeOf y
#align slim_check.sizeof_lt SlimCheck.SizeofLt

/-- `shrink_fn α` is the type of functions that shrink an
argument of type `α` -/
@[reducible]
def ShrinkFn (α : Type _) [SizeOf α] :=
  ∀ x : α, LazyList { y : α // SizeofLt y x }
#align slim_check.shrink_fn SlimCheck.ShrinkFn

/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`sample] [] -/
/-- `sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.  -/
class Sampleable where
  [wf : SizeOf α]
  sample : Gen α
  shrink : ∀ x : α, LazyList { y : α // @SizeOf.sizeOf _ wf y < @SizeOf.sizeOf _ wf x } := fun _ =>
    LazyList.nil
#align slim_check.sampleable SlimCheck.Sampleable

attribute [instance] hasWellFoundedOfHasSizeof defaultHasSizeof

attribute [instance] sampleable.wf

/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`sample] [] -/
/-- `sampleable_functor F` makes it possible to create samples of and
shrink `F α` given a sampling function and a shrinking function for
arbitrary `α` -/
class SampleableFunctor (F : Type u → Type v) [Functor F] where
  [wf : ∀ (α) [SizeOf α], SizeOf (F α)]
  sample : ∀ {α}, Gen α → Gen (F α)
  shrink : ∀ (α) [SizeOf α], ShrinkFn α → ShrinkFn (F α)
  pRepr : ∀ α, Repr α → Repr (F α)
#align slim_check.sampleable_functor SlimCheck.SampleableFunctor

/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`sample] [] -/
/-- `sampleable_bifunctor F` makes it possible to create samples of
and shrink `F α β` given a sampling function and a shrinking function
for arbitrary `α` and `β` -/
class SampleableBifunctor (F : Type u → Type v → Type w) [Bifunctor F] where
  [wf : ∀ (α β) [SizeOf α] [SizeOf β], SizeOf (F α β)]
  sample : ∀ {α β}, Gen α → Gen β → Gen (F α β)
  shrink : ∀ (α β) [SizeOf α] [SizeOf β], ShrinkFn α → ShrinkFn β → ShrinkFn (F α β)
  pRepr : ∀ α β, Repr α → Repr β → Repr (F α β)
#align slim_check.sampleable_bifunctor SlimCheck.SampleableBifunctor

export Sampleable (sample shrink)

/-- This function helps infer the proxy representation and
interpretation in `sampleable_ext` instances. -/
unsafe def sampleable.mk_trivial_interp : tactic Unit :=
  tactic.refine ``(id)
#align slim_check.sampleable.mk_trivial_interp slim_check.sampleable.mk_trivial_interp

/- warning: slim_check.sampleable_ext -> SlimCheck.SampleableExt is a dubious translation:
lean 3 declaration is
  Sort.{u1} -> Sort.{max (imax (succ u2) u1) (succ (succ u2))}
but is expected to have type
  Sort.{u1} -> Sort.{max u1 (succ (succ u2))}
Case conversion may be inaccurate. Consider using '#align slim_check.sampleable_ext SlimCheck.SampleableExtₓ'. -/
/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`interp] [] -/
/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`sample] [] -/
/-- `sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type. -/
class SampleableExt (α : Sort u) where
  ProxyRepr : Type v
  [wf : SizeOf proxy_repr]
  interp : proxy_repr → α := by refine id.1
  [pRepr : Repr proxy_repr]
  sample : Gen proxy_repr
  shrink : ShrinkFn proxy_repr
#align slim_check.sampleable_ext SlimCheck.SampleableExt

attribute [instance] sampleable_ext.p_repr sampleable_ext.wf

open Nat LazyList

section Prio

open SampleableExt

/- ./././Mathport/Syntax/Translate/Basic.lean:334:40: warning: unsupported option default_priority -/
set_option default_priority 50

instance SampleableExt.ofSampleable {α} [Sampleable α] [Repr α] : SampleableExt α
    where
  ProxyRepr := α
  sample := Sampleable.sample α
  shrink := shrink
#align slim_check.sampleable_ext.of_sampleable SlimCheck.SampleableExt.ofSampleable

instance Sampleable.functor {α} {F} [Functor F] [SampleableFunctor F] [Sampleable α] :
    Sampleable (F α) where
  wf := _
  sample := SampleableFunctor.sample F (Sampleable.sample α)
  shrink := SampleableFunctor.shrink α Sampleable.shrink
#align slim_check.sampleable.functor SlimCheck.Sampleable.functor

instance Sampleable.bifunctor {α β} {F} [Bifunctor F] [SampleableBifunctor F] [Sampleable α]
    [Sampleable β] : Sampleable (F α β) where
  wf := _
  sample := SampleableBifunctor.sample F (Sampleable.sample α) (Sampleable.sample β)
  shrink := SampleableBifunctor.shrink α β Sampleable.shrink Sampleable.shrink
#align slim_check.sampleable.bifunctor SlimCheck.Sampleable.bifunctor

/- ./././Mathport/Syntax/Translate/Basic.lean:334:40: warning: unsupported option default_priority -/
set_option default_priority 100

instance SampleableExt.functor {α} {F} [Functor F] [SampleableFunctor F] [SampleableExt α] :
    SampleableExt (F α) where
  wf := _
  ProxyRepr := F (ProxyRepr α)
  interp := Functor.map (interp _)
  sample := SampleableFunctor.sample F (SampleableExt.sample α)
  shrink := SampleableFunctor.shrink _ SampleableExt.shrink
  pRepr := SampleableFunctor.pRepr _ SampleableExt.pRepr
#align slim_check.sampleable_ext.functor SlimCheck.SampleableExt.functor

instance SampleableExt.bifunctor {α β} {F} [Bifunctor F] [SampleableBifunctor F] [SampleableExt α]
    [SampleableExt β] : SampleableExt (F α β)
    where
  wf := _
  ProxyRepr := F (ProxyRepr α) (ProxyRepr β)
  interp := Bifunctor.bimap (interp _) (interp _)
  sample := SampleableBifunctor.sample F (SampleableExt.sample α) (SampleableExt.sample β)
  shrink := SampleableBifunctor.shrink _ _ SampleableExt.shrink SampleableExt.shrink
  pRepr := SampleableBifunctor.pRepr _ _ SampleableExt.pRepr SampleableExt.pRepr
#align slim_check.sampleable_ext.bifunctor SlimCheck.SampleableExt.bifunctor

end Prio

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- `nat.shrink' k n` creates a list of smaller natural numbers by
successively dividing `n` by 2 and subtracting the difference from
`k`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def Nat.shrink' (k : ℕ) :
    ∀ n : ℕ,
      n ≤ k →
        List { m : ℕ // WellFoundedRelation.R m k } → List { m : ℕ // WellFoundedRelation.R m k }
  | n, hn, ls =>
    if h : n ≤ 1 then ls.reverse
    else
      have h₂ : 0 < n := by linarith
      have : 1 * n / 2 < n := Nat.div_lt_of_lt_mul (Nat.mul_lt_mul_of_pos_right (by norm_num) h₂)
      have : n / 2 < n := by simpa
      let m := n / 2
      have h₀ : m ≤ k := le_trans (le_of_lt this) hn
      have h₃ : 0 < m := by
        simp only [m, lt_iff_add_one_le, zero_add] <;> rw [Nat.le_div_iff_mul_le] <;> linarith
      have h₁ : k - m < k := Nat.sub_lt (lt_of_lt_of_le h₂ hn) h₃
      nat.shrink' m h₀ (⟨k - m, h₁⟩::ls)
#align slim_check.nat.shrink' SlimCheck.Nat.shrink'

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
#print SlimCheck.Nat.shrink /-
/-- `nat.shrink n` creates a list of smaller natural numbers by
successively dividing by 2 and subtracting the difference from
`n`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def Nat.shrink (n : ℕ) : List { m : ℕ // WellFoundedRelation.R m n } :=
  if h : n > 0 then
    have : ∀ k, 1 < k → n / k < n := fun k hk =>
      Nat.div_lt_of_lt_mul
        (suffices 1 * n < k * n by simpa
        Nat.mul_lt_mul_of_pos_right hk h)
    ⟨n / 11, this _ (by norm_num)⟩::⟨n / 3, this _ (by norm_num)⟩::Nat.shrink' n n le_rfl []
  else []
#align slim_check.nat.shrink SlimCheck.Nat.shrink
-/

open Gen

/-- Transport a `sampleable` instance from a type `α` to a type `β` using
functions between the two, going in both directions.

Function `g` is used to define the well-founded order that
`shrink` is expected to follow.
-/
def Sampleable.lift (α : Type u) {β : Type u} [Sampleable α] (f : α → β) (g : β → α)
    (h : ∀ a : α, SizeOf.sizeOf (g (f a)) ≤ SizeOf.sizeOf a) : Sampleable β
    where
  wf := ⟨SizeOf.sizeOf ∘ g⟩
  sample := f <$> sample α
  shrink x :=
    have :
      ∀ a, SizeOf.sizeOf a < SizeOf.sizeOf (g x) → SizeOf.sizeOf (g (f a)) < SizeOf.sizeOf (g x) :=
      by introv h' <;> solve_by_elim [lt_of_le_of_lt]
    Subtype.map f this <$> shrink (g x)
#align slim_check.sampleable.lift SlimCheck.Sampleable.lift

instance Nat.sampleable : Sampleable ℕ
    where
  sample :=
    sized fun sz =>
      freq [(1, coe <$> chooseAny (Fin <| succ (sz ^ 3))), (3, coe <$> chooseAny (Fin <| succ sz))]
        (by decide)
  shrink x := LazyList.ofList <| Nat.shrink x
#align slim_check.nat.sampleable SlimCheck.Nat.sampleable

/-- `iterate_shrink p x` takes a decidable predicate `p` and a
value `x` of some sampleable type and recursively shrinks `x`.
It first calls `shrink x` to get a list of candidate sample,
finds the first that satisfies `p` and recursively tries
to shrink that one. -/
def iterateShrink {α} [ToString α] [Sampleable α] (p : α → Prop) [DecidablePred p] : α → Option α :=
  WellFounded.fix WellFoundedRelation.wf fun x f_rec => do
    (trace s! "{x} : {(Shrink x).toList}") <| pure ()
    let y ← (shrink x).find fun a => p a
    f_rec y y <|> some y
#align slim_check.iterate_shrink SlimCheck.iterateShrink

instance Fin.sampleable {n : ℕ} [NeZero n] : Sampleable (Fin n) :=
  Sampleable.lift ℕ Fin.ofNat'' Fin.val fun i => (mod_le _ _ : i % n ≤ i)
#align slim_check.fin.sampleable SlimCheck.Fin.sampleable

instance (priority := 100) Fin.sampleable' {n} : Sampleable (Fin (succ n)) :=
  Sampleable.lift ℕ Fin.ofNat Fin.val fun i => (mod_le _ _ : i % succ n ≤ i)
#align slim_check.fin.sampleable' SlimCheck.Fin.sampleable'

instance Pnat.sampleable : Sampleable ℕ+ :=
  Sampleable.lift ℕ Nat.succPNat PNat.natPred fun a => by
    unfold_wf <;> simp only [PNat.natPred, succ_pnat, PNat.mk_coe, tsub_zero, succ_sub_succ_eq_sub]
#align slim_check.pnat.sampleable SlimCheck.Pnat.sampleable

/-- Redefine `sizeof` for `int` to make it easier to use with `nat` -/
def Int.hasSizeof : SizeOf ℤ :=
  ⟨Int.natAbs⟩
#align slim_check.int.has_sizeof SlimCheck.Int.hasSizeof

attribute [local instance] int.has_sizeof

instance Int.sampleable : Sampleable ℤ where
  wf := _
  sample :=
    sized fun sz =>
      freq
        [(1, Subtype.val <$> choose (-(sz ^ 3 + 1) : ℤ) (sz ^ 3 + 1) (neg_le_self (by decide))),
          (3, Subtype.val <$> choose (-(sz + 1)) (sz + 1) (neg_le_self (by decide)))]
        (by decide)
  shrink x :=
    LazyList.ofList <|
      (Nat.shrink <| Int.natAbs x).bind fun ⟨y, h⟩ =>
        [⟨y, h⟩, ⟨-y, by dsimp [SizeOf.sizeOf, SizeOf.sizeOf] <;> rw [Int.natAbs_neg] <;> exact h⟩]
#align slim_check.int.sampleable SlimCheck.Int.sampleable

instance Bool.sampleable : Sampleable Bool
    where
  wf := ⟨fun b => if b then 1 else 0⟩
  sample := do
    let x ← chooseAny Bool
    return x
  shrink b := if h : b then LazyList.singleton ⟨false, by cases h <;> unfold_wf⟩ else LazyList.nil
#align slim_check.bool.sampleable SlimCheck.Bool.sampleable

/-- Provided two shrinking functions `prod.shrink` shrinks a pair `(x, y)` by
first shrinking `x` and pairing the results with `y` and then shrinking
`y` and pairing the results with `x`.

All pairs either contain `x` untouched or `y` untouched. We rely on
shrinking being repeated for `x` to get maximally shrunken and then
for `y` to get shrunken too.
-/
def Prod.shrink {α β} [SizeOf α] [SizeOf β] (shr_a : ShrinkFn α) (shr_b : ShrinkFn β) :
    ShrinkFn (α × β)
  | ⟨x₀, x₁⟩ =>
    let xs₀ : LazyList { y : α × β // SizeofLt y (x₀, x₁) } :=
      (shr_a x₀).map <|
        Subtype.map (fun a => (a, x₁)) fun x h => by dsimp [sizeof_lt] <;> unfold_wf <;> apply h
    let xs₁ : LazyList { y : α × β // SizeofLt y (x₀, x₁) } :=
      (shr_b x₁).map <|
        Subtype.map (fun a => (x₀, a)) fun x h => by dsimp [sizeof_lt] <;> unfold_wf <;> apply h
    xs₀.append xs₁
#align slim_check.prod.shrink SlimCheck.Prod.shrink

instance Prod.sampleable : SampleableBifunctor.{u, v} Prod
    where
  wf := _
  sample α β sama samb := do
    let ⟨x⟩ ← (Uliftable.up <| sama : Gen (ULift.{max u v} α))
    let ⟨y⟩ ← (Uliftable.up <| samb : Gen (ULift.{max u v} β))
    pure (x, y)
  shrink := @Prod.shrink
  pRepr := @Prod.hasRepr
#align slim_check.prod.sampleable SlimCheck.Prod.sampleable

instance Sigma.sampleable {α β} [Sampleable α] [Sampleable β] : Sampleable (Σ_ : α, β) :=
  Sampleable.lift (α × β) (fun ⟨x, y⟩ => ⟨x, y⟩) (fun ⟨x, y⟩ => ⟨x, y⟩) fun ⟨x, y⟩ => le_rfl
#align slim_check.sigma.sampleable SlimCheck.Sigma.sampleable

/-- shrinking function for sum types -/
def Sum.shrink {α β} [SizeOf α] [SizeOf β] (shrink_α : ShrinkFn α) (shrink_β : ShrinkFn β) :
    ShrinkFn (Sum α β)
  | Sum.inr x =>
    (shrink_β x).map <|
      Subtype.map Sum.inr fun a => by dsimp [sizeof_lt] <;> unfold_wf <;> solve_by_elim
  | Sum.inl x =>
    (shrink_α x).map <|
      Subtype.map Sum.inl fun a => by dsimp [sizeof_lt] <;> unfold_wf <;> solve_by_elim
#align slim_check.sum.shrink SlimCheck.Sum.shrink

instance Sum.sampleable : SampleableBifunctor.{u, v} Sum
    where
  wf := _
  sample (α : Type u) (β : Type v) sam_α sam_β :=
    @Uliftable.upMap Gen.{u} Gen.{max u v} _ _ _ _ (@Sum.inl α β) sam_α <|>
      @Uliftable.upMap Gen.{v} Gen.{max v u} _ _ _ _ (@Sum.inr α β) sam_β
  shrink α β Iα Iβ shr_α shr_β := @Sum.shrink _ _ Iα Iβ shr_α shr_β
  pRepr := @Sum.hasRepr
#align slim_check.sum.sampleable SlimCheck.Sum.sampleable

instance Rat.sampleable : Sampleable ℚ :=
  (Sampleable.lift (ℤ × ℕ+) (fun x => Prod.casesOn x [anonymous]) fun r =>
      (r.Num, ⟨r.den, r.Pos⟩)) <|
    by
    intro i
    rcases i with ⟨x, ⟨y, hy⟩⟩ <;> unfold_wf <;> dsimp [[anonymous]]
    mono*
    · rw [← Int.ofNat_le, Int.coe_natAbs, Int.coe_natAbs]
      apply Int.abs_ediv_le_abs
    · change _ - 1 ≤ y - 1
      apply tsub_le_tsub_right
      apply Nat.div_le_of_le_mul
      suffices 1 * y ≤ x.nat_abs.gcd y * y by simpa
      apply Nat.mul_le_mul_right
      apply gcd_pos_of_pos_right _ hy
#align slim_check.rat.sampleable SlimCheck.Rat.sampleable

/-- `sampleable_char` can be specialized into customized `sampleable char` instances.

The resulting instance has `1 / length` chances of making an unrestricted choice of characters
and it otherwise chooses a character from `characters` with uniform probabilities.  -/
def sampleableChar (length : Nat) (characters : String) : Sampleable Char
    where
  sample := do
    let x ← chooseNat 0 length (by decide)
    if x = 0 then do
        let n ← sample ℕ
        pure <| Char.ofNat n
      else do
        let i ← choose_nat 0 (characters - 1) (by decide)
        pure (characters i).curr
  shrink _ := LazyList.nil
#align slim_check.sampleable_char SlimCheck.sampleableChar

/- warning: slim_check.char.sampleable -> SlimCheck.Char.sampleable is a dubious translation:
lean 3 declaration is
  SlimCheck.Sampleable.{0} Char
but is expected to have type
  Nat -> (forall (chars : List.{0} Char), (LT.lt.{0} Nat instLTNat (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)) (List.length.{0} Char chars)) -> (SlimCheck.SampleableExt.{1, 0} Char))
Case conversion may be inaccurate. Consider using '#align slim_check.char.sampleable SlimCheck.Char.sampleableₓ'. -/
instance Char.sampleable : Sampleable Char :=
  sampleableChar 3 " 0123abcABC:,;`\\/"
#align slim_check.char.sampleable SlimCheck.Char.sampleable

variable {α}

section ListShrink

variable [SizeOf α] (shr : ∀ x : α, LazyList { y : α // SizeofLt y x })

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem List.sizeOf_drop_lt_sizeOf_of_lt_length {xs : List α} {k} (hk : 0 < k)
    (hk' : k < xs.length) : SizeOf.sizeOf (List.drop k xs) < SizeOf.sizeOf xs :=
  by
  induction' xs with x xs generalizing k
  · cases hk'
  cases k
  · cases hk
  have : SizeOf.sizeOf xs < SizeOf.sizeOf (x::xs) := by unfold_wf
  cases k
  · simp only [this, List.drop]
  · simp only [List.drop]
    trans
    · solve_by_elim [xs_ih, lt_of_succ_lt_succ hk', zero_lt_succ]
    · assumption
#align slim_check.list.sizeof_drop_lt_sizeof_of_lt_length SlimCheck.List.sizeOf_drop_lt_sizeOf_of_lt_length

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem List.sizeOf_cons_lt_right (a b : α) {xs : List α} (h : SizeOf.sizeOf a < SizeOf.sizeOf b) :
    SizeOf.sizeOf (a::xs) < SizeOf.sizeOf (b::xs) := by unfold_wf <;> assumption
#align slim_check.list.sizeof_cons_lt_right SlimCheck.List.sizeOf_cons_lt_right

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem List.sizeOf_cons_lt_left (x : α) {xs xs' : List α}
    (h : SizeOf.sizeOf xs < SizeOf.sizeOf xs') : SizeOf.sizeOf (x::xs) < SizeOf.sizeOf (x::xs') :=
  by unfold_wf <;> assumption
#align slim_check.list.sizeof_cons_lt_left SlimCheck.List.sizeOf_cons_lt_left

theorem List.sizeOf_append_lt_left {xs ys ys' : List α} (h : SizeOf.sizeOf ys < SizeOf.sizeOf ys') :
    SizeOf.sizeOf (xs ++ ys) < SizeOf.sizeOf (xs ++ ys') :=
  by
  induction xs
  · apply h
  · unfold_wf
    simp only [List.sizeof, add_lt_add_iff_left]
    exact xs_ih
#align slim_check.list.sizeof_append_lt_left SlimCheck.List.sizeOf_append_lt_left

theorem List.one_le_sizeOf (xs : List α) : 1 ≤ SizeOf.sizeOf xs := by
  cases xs <;> unfold_wf <;> linarith
#align slim_check.list.one_le_sizeof SlimCheck.List.one_le_sizeOf

/-- `list.shrink_removes` shrinks a list by removing chunks of size `k` in
the middle of the list.
-/
def List.shrinkRemoves (k : ℕ) (hk : 0 < k) :
    ∀ (xs : List α) (n), n = xs.length → LazyList { ys : List α // SizeofLt ys xs }
  | xs, n, hn =>
    if hkn : k > n then LazyList.nil
    else
      if hkn' : k = n then
        have : 1 < xs.sizeOf := by
          subst_vars
          cases xs
          · contradiction
          unfold_wf
          apply lt_of_lt_of_le
          show 1 < 1 + SizeOf.sizeOf xs_hd + 1
          · linarith
          · mono
            apply list.one_le_sizeof
        LazyList.singleton ⟨[], this⟩
      else
        have h₂ : k < xs.length := hn ▸ lt_of_le_of_ne (le_of_not_gt hkn) hkn'
        match (motive := ∀ ys, ys = List.splitAt k xs → _) List.splitAt k xs, rfl with
        | ⟨xs₁, xs₂⟩, h =>
          have h₄ : xs₁ = xs.take k := by
            simp only [List.splitAt_eq_take_drop, Prod.mk.inj_iff] at h <;> tauto
          have h₃ : xs₂ = xs.drop k := by
            simp only [List.splitAt_eq_take_drop, Prod.mk.inj_iff] at h <;> tauto
          have : SizeOf.sizeOf xs₂ < SizeOf.sizeOf xs := by
            rw [h₃] <;> solve_by_elim [list.sizeof_drop_lt_sizeof_of_lt_length]
          have h₁ : n - k = xs₂.length := by simp only [h₃, ← hn, List.length_drop]
          have h₅ : ∀ a : List α, SizeofLt a xs₂ → SizeofLt (xs₁ ++ a) xs := by
            intro a h <;> rw [← List.take_append_drop k xs, ← h₃, ← h₄] <;>
              solve_by_elim [list.sizeof_append_lt_left]
          LazyList.cons ⟨xs₂, this⟩ <|
            Subtype.map ((· ++ ·) xs₁) h₅ <$> list.shrink_removes xs₂ (n - k) h₁
#align slim_check.list.shrink_removes SlimCheck.List.shrinkRemoves

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:228:8: unsupported: ambiguous notation -/
/-- `list.shrink_one xs` shrinks list `xs` by shrinking only one item in
the list.
-/
def List.shrinkOne : ShrinkFn (List α)
  | [] => LazyList.nil
  | x::xs =>
    LazyList.append
      ((Subtype.map (fun x' => x'::xs) fun a => List.sizeOf_cons_lt_right _ _) <$> shr x)
      ((Subtype.map ((·::·) x) fun _ => List.sizeOf_cons_lt_left _) <$> list.shrink_one xs)
#align slim_check.list.shrink_one SlimCheck.List.shrinkOne

/-- `list.shrink_with shrink_f xs` shrinks `xs` by first
considering `xs` with chunks removed in the middle (starting with
chunks of size `xs.length` and halving down to `1`) and then
shrinks only one element of the list.

This strategy is taken directly from Haskell's QuickCheck -/
def List.shrinkWith (xs : List α) : LazyList { ys : List α // SizeofLt ys xs } :=
  let n := xs.length
  LazyList.append
    ((LazyList.cons n <| (shrink n).reverse.map Subtype.val).bind fun k =>
      if hk : 0 < k then List.shrinkRemoves k hk xs n rfl else LazyList.nil)
    (List.shrinkOne shr _)
#align slim_check.list.shrink_with SlimCheck.List.shrinkWith

end ListShrink

instance List.sampleable : SampleableFunctor List.{u}
    where
  wf := _
  sample α sam_α := listOf sam_α
  shrink α Iα shr_α := @List.shrinkWith _ Iα shr_α
  pRepr := @List.hasRepr
#align slim_check.list.sampleable SlimCheck.List.sampleable

#print SlimCheck.Prop.sampleableExt /-
instance Prop.sampleableExt : SampleableExt Prop
    where
  ProxyRepr := Bool
  interp := coe
  sample := chooseAny Bool
  shrink _ := LazyList.nil
#align slim_check.Prop.sampleable_ext SlimCheck.Prop.sampleableExt
-/

#print SlimCheck.NoShrink /-
/-- `no_shrink` is a type annotation to signal that
a certain type is not to be shrunk. It can be useful in
combination with other types: e.g. `xs : list (no_shrink ℤ)`
will result in the list being cut down but individual
integers being kept as is. -/
def NoShrink (α : Type _) :=
  α
#align slim_check.no_shrink SlimCheck.NoShrink
-/

#print SlimCheck.NoShrink.inhabited /-
instance NoShrink.inhabited {α} [Inhabited α] : Inhabited (NoShrink α) :=
  ⟨(default : α)⟩
#align slim_check.no_shrink.inhabited SlimCheck.NoShrink.inhabited
-/

#print SlimCheck.NoShrink.mk /-
/-- Introduction of the `no_shrink` type. -/
def NoShrink.mk {α} (x : α) : NoShrink α :=
  x
#align slim_check.no_shrink.mk SlimCheck.NoShrink.mk
-/

#print SlimCheck.NoShrink.get /-
/-- Selector of the `no_shrink` type. -/
def NoShrink.get {α} (x : NoShrink α) : α :=
  x
#align slim_check.no_shrink.get SlimCheck.NoShrink.get
-/

instance NoShrink.sampleable {α} [Sampleable α] : Sampleable (NoShrink α)
    where sample := NoShrink.mk <$> sample α
#align slim_check.no_shrink.sampleable SlimCheck.NoShrink.sampleable

instance String.sampleable : Sampleable String :=
  { Sampleable.lift (List Char) List.asString String.toList fun _ => le_rfl with
    sample := do
      let x ← listOf (sample Char)
      pure x }
#align slim_check.string.sampleable SlimCheck.String.sampleable

/-- implementation of `sampleable (tree α)` -/
def Tree.sample (sample : Gen α) : ℕ → Gen (Tree α)
  | n =>
    if h : n > 0 then
      have : n / 2 < n := div_lt_self h (by norm_num)
      Tree.node <$> sample <*> tree.sample (n / 2) <*> tree.sample (n / 2)
    else pure Tree.nil
#align slim_check.tree.sample SlimCheck.Tree.sample

/-- `rec_shrink x f_rec` takes the recursive call `f_rec` introduced
by `well_founded.fix` and turns it into a shrinking function whose
result is adequate to use in a recursive call. -/
def recShrink {α : Type _} [SizeOf α] (t : α)
    (sh : ∀ x : α, SizeofLt x t → LazyList { y : α // SizeofLt y x }) :
    ShrinkFn { t' : α // SizeofLt t' t }
  | ⟨t', ht'⟩ =>
    (fun t'' : { y : α // SizeofLt y t' } =>
        ⟨⟨t''.val, lt_trans t''.property ht'⟩, t''.property⟩) <$>
      sh t' ht'
#align slim_check.rec_shrink SlimCheck.recShrink

theorem Tree.one_le_sizeOf {α} [SizeOf α] (t : Tree α) : 1 ≤ SizeOf.sizeOf t := by
  cases t <;> unfold_wf <;> linarith
#align slim_check.tree.one_le_sizeof SlimCheck.Tree.one_le_sizeOf

instance : Functor Tree where map := @Tree.map

/-- Recursion principle for shrinking tree-like structures.
-/
def recShrinkWith [SizeOf α]
    (shrink_a :
      ∀ x : α, ShrinkFn { y : α // SizeofLt y x } → List (LazyList { y : α // SizeofLt y x })) :
    ShrinkFn α :=
  WellFounded.fix (sizeofMeasure_wf _) fun t f_rec =>
    LazyList.join (LazyList.ofList <| shrink_a t fun ⟨t', h⟩ => recShrink _ f_rec _)
#align slim_check.rec_shrink_with SlimCheck.recShrinkWith

theorem recShrinkWith_eq [SizeOf α]
    (shrink_a :
      ∀ x : α, ShrinkFn { y : α // SizeofLt y x } → List (LazyList { y : α // SizeofLt y x }))
    (x : α) :
    recShrinkWith shrink_a x =
      LazyList.join
        (LazyList.ofList <|
          shrink_a x fun t' => recShrink _ (fun x h' => recShrinkWith shrink_a x) _) :=
  by
  conv_lhs => rw [rec_shrink_with, WellFounded.fix_eq]
  congr ; ext ⟨y, h⟩; rfl
#align slim_check.rec_shrink_with_eq SlimCheck.recShrinkWith_eq

/-- `tree.shrink_with shrink_f t` shrinks `xs` by using the empty tree,
each subtrees, and by shrinking the subtree to recombine them.

This strategy is taken directly from Haskell's QuickCheck -/
def Tree.shrinkWith [SizeOf α] (shrink_a : ShrinkFn α) : ShrinkFn (Tree α) :=
  recShrinkWith fun t =>
    match t with
    | Tree.nil => fun f_rec => []
    | Tree.node x t₀ t₁ => fun f_rec =>
      have h₂ : SizeofLt Tree.nil (Tree.node x t₀ t₁) := by
        clear _match <;> have := tree.one_le_sizeof t₀ <;>
              dsimp [sizeof_lt, SizeOf.sizeOf, SizeOf.sizeOf] at * <;>
            unfold_wf <;>
          linarith
      have h₀ : SizeofLt t₀ (Tree.node x t₀ t₁) := by dsimp [sizeof_lt] <;> unfold_wf <;> linarith
      have h₁ : SizeofLt t₁ (Tree.node x t₀ t₁) := by dsimp [sizeof_lt] <;> unfold_wf <;> linarith
      [LazyList.ofList [⟨Tree.nil, h₂⟩, ⟨t₀, h₀⟩, ⟨t₁, h₁⟩],
        (Prod.shrink shrink_a (Prod.shrink f_rec f_rec) (x, ⟨t₀, h₀⟩, ⟨t₁, h₁⟩)).map
          fun ⟨⟨y, ⟨t'₀, _⟩, ⟨t'₁, _⟩⟩, hy⟩ =>
          ⟨Tree.node y t'₀ t'₁, by
            revert hy <;> dsimp [sizeof_lt] <;> unfold_wf <;> intro <;> linarith⟩]
#align slim_check.tree.shrink_with SlimCheck.Tree.shrinkWith

instance sampleableTree : SampleableFunctor Tree
    where
  wf := _
  sample α sam_α := sized <| Tree.sample sam_α
  shrink α Iα shr_α := @Tree.shrinkWith _ Iα shr_α
  pRepr := @Tree.hasRepr
#align slim_check.sampleable_tree SlimCheck.sampleableTree

/-- Type tag that signals to `slim_check` to use small values for a given type. -/
def Small (α : Type _) :=
  α
#align slim_check.small SlimCheck.Small

/-- Add the `small` type tag -/
def Small.mk {α} (x : α) : Small α :=
  x
#align slim_check.small.mk SlimCheck.Small.mk

/-- Type tag that signals to `slim_check` to use large values for a given type. -/
def Large (α : Type _) :=
  α
#align slim_check.large SlimCheck.Large

/-- Add the `large` type tag -/
def Large.mk {α} (x : α) : Large α :=
  x
#align slim_check.large.mk SlimCheck.Large.mk

instance Small.functor : Functor Small :=
  id.monad.toFunctor
#align slim_check.small.functor SlimCheck.Small.functor

instance Large.functor : Functor Large :=
  id.monad.toFunctor
#align slim_check.large.functor SlimCheck.Large.functor

instance Small.inhabited [Inhabited α] : Inhabited (Small α) :=
  ⟨(default : α)⟩
#align slim_check.small.inhabited SlimCheck.Small.inhabited

instance Large.inhabited [Inhabited α] : Inhabited (Large α) :=
  ⟨(default : α)⟩
#align slim_check.large.inhabited SlimCheck.Large.inhabited

instance Small.sampleableFunctor : SampleableFunctor Small
    where
  wf := _
  sample α samp := Gen.resize (fun n => n / 5 + 5) samp
  shrink α _ := id
  pRepr α := id
#align slim_check.small.sampleable_functor SlimCheck.Small.sampleableFunctor

instance Large.sampleableFunctor : SampleableFunctor Large
    where
  wf := _
  sample α samp := Gen.resize (fun n => n * 5) samp
  shrink α _ := id
  pRepr α := id
#align slim_check.large.sampleable_functor SlimCheck.Large.sampleableFunctor

instance Ulift.sampleableFunctor : SampleableFunctor ULift.{u, v}
    where
  wf α h := ⟨fun ⟨x⟩ => @SizeOf.sizeOf α h x⟩
  sample α samp := Uliftable.upMap ULift.up <| samp
  shrink := fun α _ shr ⟨x⟩ => (shr x).map (Subtype.map ULift.up fun a h => h)
  pRepr α h := ⟨@repr α h ∘ ULift.down⟩
#align slim_check.ulift.sampleable_functor SlimCheck.Ulift.sampleableFunctor

/-!
## Subtype instances

The following instances are meant to improve the testing of properties of the form
`∀ i j, i ≤ j, ...`

The naive way to test them is to choose two numbers `i` and `j` and check that
the proper ordering is satisfied. Instead, the following instances make it
so that `j` will be chosen with considerations to the required ordering
constraints. The benefit is that we will not have to discard any choice
of `j`.
 -/

/-! ### Subtypes of `ℕ` -/

instance NatLe.sampleable {y} : SlimCheck.Sampleable { x : ℕ // x ≤ y }
    where
  sample := do
    let ⟨x, h⟩ ← SlimCheck.Gen.chooseNat 0 y (by decide)
    pure ⟨x, h.2⟩
  shrink := fun ⟨x, h⟩ =>
    (fun a : Subtype _ => Subtype.recOn a fun x' h' => ⟨⟨x', le_trans (le_of_lt h') h⟩, h'⟩) <$>
      shrink x
#align slim_check.nat_le.sampleable SlimCheck.NatLe.sampleable

instance NatGe.sampleable {x} : SlimCheck.Sampleable { y : ℕ // x ≤ y }
    where
  sample := do
    let (y : ℕ) ← SlimCheck.Sampleable.sample ℕ
    pure ⟨x + y, by norm_num⟩
  shrink := fun ⟨y, h⟩ =>
    (fun a : { y' // SizeOf.sizeOf y' < SizeOf.sizeOf (y - x) } =>
        Subtype.recOn a fun δ h' => ⟨⟨x + δ, Nat.le_add_right _ _⟩, lt_tsub_iff_left.mp h'⟩) <$>
      shrink (y - x)
#align slim_check.nat_ge.sampleable SlimCheck.NatGe.sampleable

/- there is no `nat_lt.sampleable` instance because if `y = 0`, there is no valid choice
to satisfy `x < y` -/
instance NatGt.sampleable {x} : SlimCheck.Sampleable { y : ℕ // x < y }
    where
  sample := do
    let (y : ℕ) ← SlimCheck.Sampleable.sample ℕ
    pure ⟨x + y + 1, by linarith⟩
  shrink x := shrink _
#align slim_check.nat_gt.sampleable SlimCheck.NatGt.sampleable

/-! ### Subtypes of any `linear_ordered_add_comm_group` -/

instance Le.sampleable {y : α} [Sampleable α] [LinearOrderedAddCommGroup α] :
    SlimCheck.Sampleable { x : α // x ≤ y }
    where
  sample := do
    let x ← sample α
    pure ⟨y - |x|, sub_le_self _ (abs_nonneg _)⟩
  shrink _ := LazyList.nil
#align slim_check.le.sampleable SlimCheck.Le.sampleable

instance Ge.sampleable {x : α} [Sampleable α] [LinearOrderedAddCommGroup α] :
    SlimCheck.Sampleable { y : α // x ≤ y }
    where
  sample := do
    let y ← sample α
    pure ⟨x + |y|, by norm_num [abs_nonneg] ⟩
  shrink _ := LazyList.nil
#align slim_check.ge.sampleable SlimCheck.Ge.sampleable

/-!
### Subtypes of `ℤ`

Specializations of `le.sampleable` and `ge.sampleable` for `ℤ` to help instance search.
-/

instance IntLe.sampleable {y : ℤ} : SlimCheck.Sampleable { x : ℤ // x ≤ y } :=
  Sampleable.lift ℕ (fun n => ⟨y - n, Int.sub_left_le_of_le_add <| by simp⟩)
    (fun ⟨i, h⟩ => (y - i).natAbs) fun n => by
    unfold_wf <;> simp [int_le.sampleable._match_1] <;> ring
#align slim_check.int_le.sampleable SlimCheck.IntLe.sampleable

instance IntGe.sampleable {x : ℤ} : SlimCheck.Sampleable { y : ℤ // x ≤ y } :=
  Sampleable.lift ℕ (fun n => ⟨x + n, by simp⟩) (fun ⟨i, h⟩ => (i - x).natAbs) fun n => by
    unfold_wf <;> simp [int_ge.sampleable._match_1] <;> ring
#align slim_check.int_ge.sampleable SlimCheck.IntGe.sampleable

instance IntLt.sampleable {y} : SlimCheck.Sampleable { x : ℤ // x < y } :=
  Sampleable.lift ℕ
    (fun n => ⟨y - (n + 1), Int.sub_left_lt_of_lt_add <| by linarith [Int.coe_nat_nonneg n]⟩)
    (fun ⟨i, h⟩ => (y - i - 1).natAbs) fun n => by
    unfold_wf <;> simp [int_lt.sampleable._match_1] <;> ring
#align slim_check.int_lt.sampleable SlimCheck.IntLt.sampleable

instance IntGt.sampleable {x} : SlimCheck.Sampleable { y : ℤ // x < y } :=
  Sampleable.lift ℕ (fun n => ⟨x + (n + 1), by linarith⟩) (fun ⟨i, h⟩ => (i - x - 1).natAbs)
    fun n => by unfold_wf <;> simp [int_gt.sampleable._match_1] <;> ring
#align slim_check.int_gt.sampleable SlimCheck.IntGt.sampleable

/-! ### Subtypes of any `list` -/

instance Perm.slimCheck {xs : List α} : SlimCheck.Sampleable { ys : List α // List.Perm xs ys }
    where
  sample := permutationOf xs
  shrink _ := LazyList.nil
#align slim_check.perm.slim_check SlimCheck.Perm.slimCheck

instance Perm'.slimCheck {xs : List α} : SlimCheck.Sampleable { ys : List α // List.Perm ys xs }
    where
  sample := Subtype.map id (@List.Perm.symm α _) <$> permutationOf xs
  shrink _ := LazyList.nil
#align slim_check.perm'.slim_check SlimCheck.Perm'.slimCheck

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
open Tactic

/-- Print (at most) 10 samples of a given type to stdout for debugging.
-/
def printSamples {t : Type u} [Repr t] (g : Gen t) : Io Unit := do
  let xs ←
    Io.runRand <|
        Uliftable.down do
          let xs ← (List.range 10).mapM <| g.run ∘ ULift.up
          pure ⟨xs repr⟩
  xs Io.putStrLn
#align slim_check.print_samples SlimCheck.printSamples

/-- Create a `gen α` expression from the argument of `#sample` -/
unsafe def mk_generator (e : expr) : tactic (expr × expr) := do
  let t ← infer_type e
  match t with
    | q(Gen $(t)) => do
      let repr_inst ← mk_app `` Repr [t] >>= mk_instance
      pure (repr_inst, e)
    | _ => do
      let samp_inst ← to_expr ``(SampleableExt $(e)) >>= mk_instance
      let repr_inst ← mk_mapp `` sampleable_ext.p_repr [e, samp_inst]
      let gen ← mk_mapp `` sampleable_ext.sample [none, samp_inst]
      pure (repr_inst, gen)
#align slim_check.mk_generator slim_check.mk_generator

/-- `#sample my_type`, where `my_type` has an instance of `sampleable`, prints ten random
values of type `my_type` of using an increasing size parameter.

```lean
#sample nat
-- prints
-- 0
-- 0
-- 2
-- 24
-- 64
-- 76
-- 5
-- 132
-- 8
-- 449
-- or some other sequence of numbers

#sample list int
-- prints
-- []
-- [1, 1]
-- [-7, 9, -6]
-- [36]
-- [-500, 105, 260]
-- [-290]
-- [17, 156]
-- [-2364, -7599, 661, -2411, -3576, 5517, -3823, -968]
-- [-643]
-- [11892, 16329, -15095, -15461]
-- or whatever
```
-/
@[user_command]
unsafe def sample_cmd (_ : parse <| tk "#sample") : lean.parser Unit := do
  let e ← texpr
  of_tactic do
      let e ← i_to_expr e
      let (repr_inst, gen) ← mk_generator e
      let print_samples ← mk_mapp `` print_samples [none, repr_inst, gen]
      let sample ← eval_expr (Io Unit) print_samples
      unsafe_run_io sample
#align slim_check.sample_cmd slim_check.sample_cmd

end SlimCheck


import category_theory.limits.shapes
import category_theory.limits.preserves.limits

import subobject_classifier
import pullbacks

/-!
# Image inside a topos

Prove that there is an image factorisation for each morphism inside a topos
TODO : prove that e is epi, will be needed for the forcing.
-/
open category_theory category_theory.category category_theory.limits classifier

noncomputable theory
universes u v
variables {C : Type u} [category.{v} C] [has_finite_limits C] [has_subobject_classifier C]

/- We need to prove some statement about the image now -/
namespace image

def monic_to_canonical_fork {X Y : C} (m : X ⟶ Y) [mono m] :
  fork (lift_truth Y) (classifier_of m) :=
begin
  apply fork.of_ι m, rw [←assoc', terminal.comp_from m, pb_classifier_condition]
end

@[simp] lemma monic_to_canonical_fork_simp {X Y : C} (m : X ⟶ Y) [mono m] :
  (monic_to_canonical_fork m).ι = m := by refl

/-
  In a topos, every monic is an equalizer, [SML94] pp167
-/
lemma monic_is_limit_fork {X Y : C} (m : X ⟶ Y) [mono m] : is_limit (monic_to_canonical_fork m) :=
begin
  refine fork.is_limit.mk (monic_to_canonical_fork m) _ _ _; intro s;
  have comm : s.ι ≫ classifier_of m = terminal.from s.X ≫ truth C :=
  begin
    rw [←s.condition, ←assoc, cancel_mono], exact terminal.comp_from _
  end,
  { apply pb_lift_from_monic.map m s.ι comm },
  { apply pb_lift_from_monic.comm m s.ι comm },
  { apply pb_lift_from_monic.unique m s.ι comm },
end

def monic_to_fork_lift {X Y : C} (m : X ⟶ Y) [mono m]
  (f : fork (lift_truth Y) (classifier_of m)) :=
fork.is_limit.lift' (monic_is_limit_fork m) (fork.ι f) (fork.condition f)

variable [has_pushouts C]

abbreviation cokernel {X Y : C} (f : X ⟶ Y) := pushout f f
abbreviation cokernel.x {X Y : C} (f : X ⟶ Y) := (pushout.inl : Y ⟶ cokernel f)
abbreviation cokernel.y {X Y : C} (f : X ⟶ Y) := (pushout.inr : Y ⟶ cokernel f)

def canonical_factorisation {X Y : C} (f : X ⟶ Y) : mono_factorisation f :=
{ I := equalizer.{v} (cokernel.x f) (cokernel.y f),
  m := equalizer.ι (cokernel.x f) (cokernel.y f),
  e := equalizer.lift f pushout.condition }

def canonical_factorisation_condition {X Y : C} (f : X ⟶ Y) :
  (canonical_factorisation f).m ≫ (cokernel.x f) =
  (canonical_factorisation f).m ≫ (cokernel.y f) :=
equalizer.condition _ _

/- from [SML94] p185 -/
lemma is_image_make {X Y : C} (f : X ⟶ Y) (F' : mono_factorisation f) :
  {l // l ≫ (monic_to_canonical_fork F'.m).ι = (canonical_factorisation f).m} :=
begin
  let s := lift_truth Y,
  let t := classifier_of F'.m,
  have h : f ≫ s = f ≫ t := by rw [←F'.fac, assoc, ←(monic_to_canonical_fork_simp F'.m),
                                    fork.condition (monic_to_canonical_fork F'.m), assoc],
  have h1 : (canonical_factorisation f).m ≫ s = (canonical_factorisation f).m ≫ t :=
  begin
    rw [←pushout.inl_desc s t h, ←assoc, canonical_factorisation_condition f], simp
  end,
  exact fork.is_limit.lift' (monic_is_limit_fork F'.m) (canonical_factorisation f).m (h1)
end

def is_image_canonical_factorisation {X Y : C} (f : X ⟶ Y) :
  is_image (canonical_factorisation f) :=
{ lift := λ F', (is_image_make f F').val,
  lift_fac' := λ F', (is_image_make f F').prop }

def image_facto {X Y : C} (f : X ⟶ Y) : image_factorisation f :=
{ F := canonical_factorisation f,
  is_image := is_image_canonical_factorisation f }

instance has_image_topos : has_images C :=
{ has_image := λ _ _ f, has_image.mk (image_facto f) }

end image


import pseudo_normed_group.bounded_limits
import category_theory.limits.concrete_category

open category_theory
open category_theory.limits
open_locale nnreal

universes u
variables {J : Type u} [small_category J]
  {F : J ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (C : cone F)

namespace CompHaus

lemma comp_apply {X Y Z : CompHaus} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  (f ≫ g) x = g (f x) := rfl

lemma id_apply (X : CompHaus) (x : X) : (𝟙 X : X ⟶ X) x = x := rfl

lemma continuous_of_is_limit (F : J ⥤ CompHaus.{u}) (C : cone F) (hC : is_limit C)
  (Y : Type u) [topological_space Y] (t : Y → C.X)
  (h : ∀ j, continuous (C.π.app j ∘ t)) : continuous t :=
begin
  let CC := CompHaus_to_Top.map_cone C,
  let hCC : is_limit CC := is_limit_of_preserves CompHaus_to_Top hC,
  let E : cone (F ⋙ CompHaus_to_Top) := ⟨Top.of Y, λ j, ⟨_,h j⟩, _⟩,
  { convert (hCC.lift E).continuous,
    ext1 a,
    apply concrete.is_limit_ext _ hCC, intros j,
    change _ = (hCC.lift E ≫ CC.π.app j) _,
    rw hCC.fac, refl },
  { intros i j f, ext,
    change _ = (C.π.app _ ≫ F.map _) _,
    rw C.w,
    refl }
end

lemma injective_of_is_iso {X Y : CompHaus} (f : X ⟶ Y) [is_iso f] :
  function.injective f :=
begin
  intros x y h,
  apply_fun (inv f) at h,
  simp only [← CompHaus.comp_apply, is_iso.hom_inv_id] at h,
  exact h
end

end CompHaus

namespace CompHausFiltPseuNormGrp₁

noncomputable theory

/-- A choice of level for some element of an exhaustive
CompHausly filtered pseudo normed group. -/
def lvl (X : CompHausFiltPseuNormGrp₁) (x : X) : ℝ≥0 :=
(X.exhaustive x).some

lemma lvl_spec (X : CompHausFiltPseuNormGrp₁) (x : X) :
  x ∈ pseudo_normed_group.filtration X (X.lvl x) :=
(X.exhaustive x).some_spec

/-- Consider an element of an exhaustive CompHausly filtered pseudo normed group
as an element of its chosen level. -/
def as_lvl (X : CompHausFiltPseuNormGrp₁) (x : X) :
  (level.obj (X.lvl x)).obj X :=
⟨x, (X.lvl_spec x)⟩

@[reassoc]
lemma level_cone_compatible (c₁ c₂ : ℝ≥0) (e : c₁ ⟶ c₂) (j) :
  (level.map e).app _ ≫ ((level.obj _).map_cone C).π.app j =
  ((level.obj _).map_cone C).π.app j ≫ (level.map e).app _ := rfl

namespace level_jointly_reflects_limits

variables (hC : Π c : ℝ≥0, is_limit ((level.obj c).map_cone C))
variables (S : cone F)

/-- An auxiliary definition to be used in the constructions below. -/
def lift_fun : S.X → C.X :=
λ s, ((hC (S.X.lvl s)).lift ((level.obj _).map_cone S) (S.X.as_lvl s)).1

lemma lift_fun_map_zero : lift_fun C hC S 0 = 0 :=
begin
  --dsimp [lift_fun],  -- slows down the proof.  changes to goal to
  -- ⊢ ((hC (S.X.lvl 0)).lift ((level.obj (S.X.lvl 0)).map_cone S)) (S.X.as_lvl 0) = 0
  let a := ((hC (S.X.lvl 0)).lift ((level.obj (S.X.lvl 0)).map_cone S)) (S.X.as_lvl 0),
  let b := (C.X.as_lvl 0),
  let c₁ := S.X.lvl 0,
  let c₂ := C.X.lvl 0,
  let c := c₁ ⊔ c₂,
  let i1 : c₁ ⟶ c := hom_of_le le_sup_left,
  let i2 : c₂ ⟶ c := hom_of_le le_sup_right,
  let e1 := (level.map i1).app C.X,
  let e2 := (level.map i2).app C.X,
  change (e1 a).1 = (e2 b).1, congr' 1,
  apply concrete.is_limit_ext _ (hC c),
  intros j, dsimp only [e1, e2, a, b, ← CompHaus.comp_apply],
  simp only [category.assoc, level_cone_compatible, (hC (S.X.lvl 0)).fac_assoc],
  ext1,
  change (S.π.app j) 0 = (C.π.app j) 0, -- was `dsimp [CompHaus.comp_apply, level, as_lvl],`
  rw [(S.π.app j).map_zero, (C.π.app j).map_zero],
end

lemma fac_aux (c) (x) (j) :
  C.π.app j ((hC c).lift ((level.obj c).map_cone S) x).1 =
  S.π.app j x.1 :=
begin
  change
    (((hC c).lift ((level.obj c).map_cone S) ≫
      (level.obj c).map (C.π.app j)) x).1 = _,
  erw (hC c).fac,
  refl,
end

lemma lift_fun_map_add (x y) : lift_fun C hC S (x + y) =
  lift_fun C hC S x + lift_fun C hC S y :=
begin
  --dsimp [lift_fun],  -- slows down the proof.  changes the goal to
  -- ⊢ ((hC (S.X.lvl 0)).lift ((level.obj (S.X.lvl 0)).map_cone S)) (S.X.as_lvl 0) = 0
  let Axy := ((hC (S.X.lvl (x + y))).lift
    ((level.obj (S.X.lvl (x + y))).map_cone S)) (S.X.as_lvl (x + y)),
  let Ax := ((hC (S.X.lvl x)).lift
    ((level.obj (S.X.lvl x)).map_cone S)) (S.X.as_lvl x),
  let Ay := ((hC (S.X.lvl y)).lift
    ((level.obj (S.X.lvl y)).map_cone S)) (S.X.as_lvl y),
  let cxy := S.X.lvl (x + y),
  let cx := S.X.lvl x,
  let cy := S.X.lvl y,
  let cc := cxy ⊔ (cx + cy),
  let AA : (level.obj (cx + cy)).obj C.X :=
    ⟨Ax.1 + Ay.1, pseudo_normed_group.add_mem_filtration Ax.2 Ay.2⟩,
  let i1 : cxy ⟶ cc := hom_of_le le_sup_left,
  let i2 : (cx + cy) ⟶ cc := hom_of_le le_sup_right,
  let e1 := (level.map i1).app C.X,
  let e2 := (level.map i2).app C.X,
  change (e1 Axy).1 = (e2 AA).1, congr' 1,
  apply concrete.is_limit_ext _ (hC cc), intros j,
--  dsimp only [e1, e2, Axy, ← CompHaus.comp_apply],
  simp only [e1, e2, Axy, ← CompHaus.comp_apply, category.assoc, level_cone_compatible,
    (hC (S.X.lvl (x + y))).fac_assoc],
  ext1,
  dsimp [CompHaus.comp_apply, level, as_lvl, AA],

  rw [(S.π.app j).map_add, (C.π.app j).map_add],
  congr' 1,
  { dsimp only [Ax],
    erw fac_aux, refl },
  { dsimp only [Ay],
    erw fac_aux, refl },
end

/- Lemmas `lift_strict` and `lift_continuous` separately compile *much* faster than when they are
embedded in `CompHausFiltPseuNormGrp₁.level_jointly_reflects_limits.lift`. -/
lemma lift_strict (c : ℝ≥0) (x : S.X) (hx : x ∈ pseudo_normed_group.filtration S.X c) :
  lift_fun C hC S x ∈ pseudo_normed_group.filtration C.X c :=
begin
  let y : (level.obj c).obj S.X := ⟨x,hx⟩,
  let z := (hC c).lift ((level.obj c).map_cone S) y,
  let a := ((hC (S.X.lvl x)).lift ((level.obj (S.X.lvl x)).map_cone S)) (S.X.as_lvl x),
  suffices : a.1 = z.1,
  { dsimp only [lift_fun], rw this, exact z.2, },
  let cc := c ⊔ S.X.lvl x,
  let i1 : c ⟶ cc := hom_of_le le_sup_left,
  let i2 : S.X.lvl x ⟶ cc := hom_of_le le_sup_right,
  suffices : (level.map i1).app _ z = (level.map i2).app _ a,
  { apply_fun (λ e, e.1) at this, exact this.symm },
  dsimp [a,z],
  apply concrete.is_limit_ext _ (hC cc),
  intros j,
  simp only [← CompHaus.comp_apply, category.assoc, level_cone_compatible,
    (hC c).fac_assoc, (hC (S.X.lvl x)).fac_assoc],
  ext, refl,
end

/- Lemmas `lift_strict` and `lift_continuous` separately compile *much* faster than when they are
embedded in `CompHausFiltPseuNormGrp₁.level_jointly_reflects_limits.lift`. -/
lemma lift_continuous (c : ℝ≥0) :
  continuous (pseudo_normed_group.level (lift_fun C hC S) (lift_strict C hC S) c) :=
begin
  let t : _ → (level.obj c).obj C.X := _, change continuous t,
  suffices : ∀ j, continuous (((level.obj c).map (C.π.app j)) ∘ t),
  { exact CompHaus.continuous_of_is_limit (F ⋙ level.obj c)
      ((level.obj c).map_cone C) (hC c) _ _ this },
  intros j,
  convert ((level.obj c).map (S.π.app j)).continuous,
  ext1 a,
  let cc : ℝ≥0 := c ⊔ (S.X.lvl a),
  let i1 : c ⟶ cc := hom_of_le le_sup_left,
  let i2 : (S.X.lvl a) ⟶ cc := hom_of_le le_sup_right,
  apply_fun ((level.map i1).app _), swap,
  { intros x y h, ext1, apply_fun (λ e, e.1) at h, exact h },
  simp only [← CompHaus.comp_apply],
  simp only [nat_trans.naturality],
  dsimp [t],
  generalize_proofs hh,
  let q := ((level.map i1).app C.X) (pseudo_normed_group.level (lift_fun C hC S) hh c a),
  have : q = ((level.map i2).app C.X)
    (((hC (S.X.lvl a)).lift ((level.obj (S.X.lvl a)).map_cone S)) (S.X.as_lvl a)), refl,
  dsimp only [q] at this,
  simp only [this, ← CompHaus.comp_apply, category.assoc],
  erw level_cone_compatible,
  rw (hC (S.X.lvl a)).fac_assoc,
  ext, refl,
end

/-- An auxiliary definition to be used in the constructions below. -/
def lift : S.X ⟶ C.X :=
{ to_fun      := lift_fun _ hC _,
  map_zero'   := lift_fun_map_zero _ _ _,
  map_add'    := lift_fun_map_add _ _ _,
  strict'     := lift_strict _ _ _,
  continuous' := lift_continuous _ _ _ }

end level_jointly_reflects_limits

/--
If `C` is a cone taking values in `CompHausFiltPseuNormGrp₁` such that
the restriction to all the levels is a limit cone, then `C` is a limit cone.
-/
def level_jointly_reflects_limits
  (hC : Π c : ℝ≥0, is_limit ((level.obj c).map_cone C)) :
  is_limit C :=
{ lift := λ S, level_jointly_reflects_limits.lift _ hC _,
  fac' := begin
    intros S j,
    ext1 t,
    -- `show` replaces the slower
    -- `dsimp [level_jointly_reflects_limits.lift, level_jointly_reflects_limits.lift_fun],`
    show (C.π.app j) _ = _,
    erw level_jointly_reflects_limits.fac_aux, refl,
  end,
  uniq' := begin
    intros S m hm,
    ext1 t,
    --  `dsimp [level_jointly_reflects_limits.lift, level_jointly_reflects_limits.lift_fun],`
    --  commented as it slows down the proof.  changes the goal to
    -- ⊢ m t = ((hC (S.X.lvl t)).lift ((level.obj (S.X.lvl t)).map_cone S)) (S.X.as_lvl t)
    let a :=
      ((hC (S.X.lvl t)).lift ((level.obj (S.X.lvl t)).map_cone S)) (S.X.as_lvl t),
    let c := C.X.lvl (m t),
    let d := c ⊔ (S.X.lvl t),
    let i1 : c ⟶ d := hom_of_le le_sup_left,
    let i2 : (S.X.lvl t) ⟶ d := hom_of_le le_sup_right,
    change ((level.map i1).app C.X (C.X.as_lvl (m t))).1 =
      ((level.map i2).app C.X a).1,
    congrm (subtype.val _),
    apply concrete.is_limit_ext _ (hC d), intros j,
    specialize hm j,
    ext1,
    show (C.π.app j) (m t) = (C.π.app j) _, --  `show` replaces a slow `dsimp [level, as_lvl, a]`
    erw [level_jointly_reflects_limits.fac_aux],
    rw ← hm, refl,
  end }

/-- Create a moprhism in `CompHausFiltPseuNormGrp₁` levelwise. -/
@[simps]
def create_hom_from_level {X Y : CompHausFiltPseuNormGrp₁}
  (E : Π c, (level.obj c).obj X ⟶ (level.obj c).obj Y)
  (hE0 : (E (X.lvl 0) (X.as_lvl 0)).1 = 0)
  (hEa : ∀ a b : X, (E _ (X.as_lvl (a + b))).1 =
    (E _ (X.as_lvl a)).1 + (E _ (X.as_lvl b)).1)
  (hE : ∀ (c₁ c₂ : ℝ≥0) (i : c₁ ⟶ c₂),
    E _ ≫ (level.map i).app _ = (level.map i).app _ ≫ E _) :
  X ⟶ Y :=
{ to_fun := λ x, (E _ $ X.as_lvl x).1,
  map_zero' := hE0,
  map_add' := hEa,
  strict' := begin
    intros c x hx,
    let y : (level.obj c).obj X := ⟨x,hx⟩,
    suffices : ((E (X.lvl x)) (X.as_lvl x)).val = (E _ y).1,
    { rw this, exact (E _ y).2, },
    let d := c ⊔ X.lvl x,
    let i1 : c ⟶ d := hom_of_le le_sup_left,
    let i2 : X.lvl x ⟶ d := hom_of_le le_sup_right,
    change ((level.map i2).app Y ((E (X.lvl x)) (X.as_lvl x))).1 =
      ((level.map i1).app _ _).1,
    congr' 1,
    simp only [← CompHaus.comp_apply, hE],
    refl,
  end,
  continuous' := begin
    intros c,
    let t := _, change continuous t,
    convert (E c).continuous,
    ext a,
    let d := X.lvl a ⊔ c,
    let i1 : X.lvl a ⟶ d := hom_of_le le_sup_left,
    let i2 : c ⟶ d := hom_of_le le_sup_right,
    change ((level.map i1).app _ (E _ (X.as_lvl a))).1 =
      ((level.map i2).app _ (E _ a)).1,
    simp only [← CompHaus.comp_apply, hE], refl,
  end }

lemma create_iso_from_level_compat_aux {X Y : CompHausFiltPseuNormGrp₁}
  (E : Π c, (level.obj c).obj X ≅ (level.obj c).obj Y)
  (hE : ∀ (c₁ c₂ : ℝ≥0) (i : c₁ ⟶ c₂),
    (E _).hom ≫ (level.map i).app _ = (level.map i).app _ ≫ (E _).hom) :
  ∀ (c₁ c₂ : ℝ≥0) (i : c₁ ⟶ c₂),
    (E _).inv ≫ (level.map i).app _ = (level.map i).app _ ≫ (E _).inv :=
begin
  intros c₁ c₂ i, rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv, hE],
end

lemma create_iso_from_level_zero_aux {X Y : CompHausFiltPseuNormGrp₁}
  (E : Π c, (level.obj c).obj X ≅ (level.obj c).obj Y)
  (hE0 : ((E (X.lvl 0)).hom (X.as_lvl 0)).1 = 0)
  (hE : ∀ (c₁ c₂ : ℝ≥0) (i : c₁ ⟶ c₂),
    (E _).hom ≫ (level.map i).app _ = (level.map i).app _ ≫ (E _).hom) :
  ((E (Y.lvl 0)).inv (Y.as_lvl 0)).1 = 0 :=
begin
  let x := (((E (Y.lvl 0)).inv) (Y.as_lvl 0)),
  let c := Y.lvl 0 ⊔ X.lvl 0,
  let i1 : Y.lvl 0 ⟶ c := hom_of_le le_sup_left,
  let i2 : X.lvl 0 ⟶ c := hom_of_le le_sup_right,
  change ((level.map i2).app _ _).val = ((level.map i1).app _ (Y.as_lvl 0)).val at hE0,
  have hE0' := hE0,
  replace hE0 : (((level.map i2).app Y) (((E (X.lvl 0)).hom) (X.as_lvl 0))) =
    (((level.map i1).app Y) (Y.as_lvl 0)),
  { ext1, exact hE0 },
  apply_fun (E c).inv at hE0,
  simp only [← CompHaus.comp_apply, hE, category.assoc, iso.hom_inv_id] at hE0,
  apply_fun (λ e, e.val) at hE0,
  change ((level.map i1).app _ x).val = ((level.map i2).app _ (X.as_lvl 0)).val,
  dsimp only [x, ← CompHaus.comp_apply],
  rw [create_iso_from_level_compat_aux, CompHaus.comp_apply],
  exact hE0.symm,
  assumption,
end

/-- An auxiliary definition to be used in the constructions below. -/
def as_lvl_add (X : CompHausFiltPseuNormGrp₁)
  (a b : X) : (level.obj (X.lvl a + X.lvl b)).obj X :=
⟨a+b, pseudo_normed_group.add_mem_filtration (X.lvl_spec a) (X.lvl_spec b)⟩

lemma create_iso_from_level_add_aux_aux {X Y : CompHausFiltPseuNormGrp₁}
  (E : Π c, (level.obj c).obj X ≅ (level.obj c).obj Y) :
  ∀ (a b : X) (c : ℝ≥0)
    (h1 : X.lvl (a + b) ⟶ c)
    (h2 : X.lvl a + X.lvl b ⟶  c),
    (E c).hom ((level.map h1).app _ $ X.as_lvl _) =
    (E c).hom ((level.map h2).app _ $ X.as_lvl_add _ _) :=
begin
  intros, congr,
end

lemma create_iso_from_level_add_aux {X Y : CompHausFiltPseuNormGrp₁}
  (E : Π c, (level.obj c).obj X ≅ (level.obj c).obj Y)
  (hEa : ∀ a b : X, ((E _).hom (X.as_lvl (a + b))).1 =
    ((E _).hom (X.as_lvl a)).1 + ((E _).hom (X.as_lvl b)).1)
  (hE : ∀ (c₁ c₂ : ℝ≥0) (i : c₁ ⟶ c₂),
    (E _).hom ≫ (level.map i).app _ = (level.map i).app _ ≫ (E _).hom) :
  ∀ a b : Y, ((E _).inv (Y.as_lvl (a + b))).1 =
    ((E _).inv (Y.as_lvl a)).1 + ((E _).inv (Y.as_lvl b)).1 :=
begin
  intros a b,
  let a' := (((E (Y.lvl a)).inv) (Y.as_lvl a)).val,
  let b' := (((E (Y.lvl b)).inv) (Y.as_lvl b)).val,
  let ab' := (((E (Y.lvl (a + b))).inv) (Y.as_lvl (a + b))).val,
  let c₁ := Y.lvl (a + b),
  let c₂ := X.lvl a' + X.lvl b',
  let c := c₁ ⊔ c₂,
  let i1 : c₁ ⟶ c := hom_of_le le_sup_left,
  let i2 : c₂ ⟶ c := hom_of_le le_sup_right,
  change ((level.map i1).app _ _).val = ((level.map i2).app _ $ X.as_lvl_add a' b').val,
  congr' 1,
  rw [← CompHaus.comp_apply, create_iso_from_level_compat_aux _ hE],
  apply_fun (E _).hom,
  swap, { apply CompHaus.injective_of_is_iso },
  simp only [← CompHaus.comp_apply, category.assoc, iso.inv_hom_id],
  simp only [CompHaus.comp_apply, CompHaus.id_apply],
  let d := X.lvl (a' + b') ⊔ c,
  let j1 : X.lvl (a' + b') ⟶ d := hom_of_le le_sup_left,
  let j2 : c ⟶ d := hom_of_le le_sup_right,
  apply_fun (level.map j2).app _,
  swap, { intros x y h, ext1, apply_fun (λ e, e.val) at h, exact h },
  simp only [← CompHaus.comp_apply, category.assoc, hE, ← nat_trans.comp_app],
  rw [← category.assoc, ← nat_trans.comp_app, ← functor.map_comp, ← functor.map_comp,
    CompHaus.comp_apply],
  erw create_iso_from_level_add_aux_aux,
  any_goals { assumption },
  swap, refine i2 ≫ j2,
  simp only [functor.map_comp, nat_trans.comp_app, CompHaus.comp_apply],
  let s := _, change _ = (E d).hom s,
  have : s = (level.map j1).app _ (X.as_lvl (a' + b')), by { ext, refl },
  rw this, clear this,
  simp_rw [← CompHaus.comp_apply, ← hE, CompHaus.comp_apply],
  ext1,
--  `show` replaces the `slower `dsimp [level]`
  show ↑(Y.as_lvl _) = ↑(((E (X.lvl (a' + b'))).hom) (X.as_lvl (a' + b'))),
--  show replaces the slower `conv_lhs { dsimp [as_lvl] }`
  show a + b = _,
  rw [← subtype.val_eq_coe, hEa a' b'],
  congrm _ + _,
  { let d₁ := Y.lvl a,
    let d₂ := X.lvl a',
    let d := d₁ ⊔ d₂,
    let e₁ : d₁ ⟶ d := hom_of_le le_sup_left,
    let e₂ : d₂ ⟶ d := hom_of_le le_sup_right,
    change ((level.map e₁).app _ (Y.as_lvl a)).val =
      ((level.map e₂).app _ (((E (X.lvl a')).hom) (X.as_lvl a'))).val,
    rw [← CompHaus.comp_apply, hE],
    congr' 1,
    apply_fun (E d).inv,
    swap, { apply CompHaus.injective_of_is_iso },
    simp_rw [← CompHaus.comp_apply, category.assoc, iso.hom_inv_id],
    rw ← create_iso_from_level_compat_aux,
    ext, refl,
    assumption },
  { let d₁ := Y.lvl b,
    let d₂ := X.lvl b',
    let d := d₁ ⊔ d₂,
    let e₁ : d₁ ⟶ d := hom_of_le le_sup_left,
    let e₂ : d₂ ⟶ d := hom_of_le le_sup_right,
    change ((level.map e₁).app _ (Y.as_lvl b)).val =
      ((level.map e₂).app _ (((E (X.lvl b')).hom) (X.as_lvl b'))).val,
    rw [← CompHaus.comp_apply, hE],
    congr' 1,
    apply_fun (E d).inv,
    swap, { apply CompHaus.injective_of_is_iso },
    simp_rw [← CompHaus.comp_apply, category.assoc, iso.hom_inv_id],
    rw ← create_iso_from_level_compat_aux,
    ext, refl,
    assumption }
end

/-- Create an isomoprhism in `CompHausFiltPseuNormGrp₁` levelwise. -/
def create_iso_from_level {X Y : CompHausFiltPseuNormGrp₁.{u}}
  (E : Π c, (level.obj c).obj X ≅ (level.obj c).obj Y)
  (hE0 : ((E (X.lvl 0)).hom (X.as_lvl 0)).1 = 0)
  (hEa : ∀ a b : X, ((E _).hom (X.as_lvl (a + b))).1 =
    ((E _).hom (X.as_lvl a)).1 + ((E _).hom (X.as_lvl b)).1)
  (hE : ∀ (c₁ c₂ : ℝ≥0) (i : c₁ ⟶ c₂),
    (E _).hom ≫ (level.map i).app _ = (level.map i).app _ ≫ (E _).hom) :
  X ≅ Y :=
{ hom := create_hom_from_level (λ c, (E c).hom) hE0 hEa hE,
  inv := create_hom_from_level (λ c, (E c).inv)
    (create_iso_from_level_zero_aux _ hE0 hE)
    (create_iso_from_level_add_aux _ hEa hE)
    (create_iso_from_level_compat_aux _ hE),
  hom_inv_id' := begin
    ext1 t,
    simp only [comp_apply, create_hom_from_level_to_fun, subtype.val_eq_coe, id_apply],
    let s := (((E (X.lvl t)).hom) (X.as_lvl t)).val,
    let c₁ := Y.lvl s,
    let c₂ := X.lvl t,
    let c := c₁ ⊔ c₂,
    let i1 : c₁ ⟶ c := hom_of_le le_sup_left,
    let i2 : c₂ ⟶ c := hom_of_le le_sup_right,
    change ((level.map i1).app _ _).val = ((level.map i2).app _ (X.as_lvl t)).val,
    simp only [← CompHaus.comp_apply],
    rw create_iso_from_level_compat_aux,
    any_goals { assumption },
    simp only [CompHaus.comp_apply],
    congr' 1,
    apply_fun (E c).hom,
    swap,
    { intros x y h,
      apply_fun (E c).inv at h,
      simp only [← CompHaus.comp_apply, iso.hom_inv_id] at h,
      exact h },
    rw [← CompHaus.comp_apply, iso.inv_hom_id, CompHaus.id_apply],
    rw [← CompHaus.comp_apply, ← hE],
    refl,
  end,
  inv_hom_id' := begin
    ext1 t,
    simp only [comp_apply, create_hom_from_level_to_fun, subtype.val_eq_coe, id_apply],
    let s := (((E (Y.lvl t)).inv) (Y.as_lvl t)).val,
    let c₁ := X.lvl s,
    let c₂ := Y.lvl t,
    let c := c₁ ⊔ c₂,
    let i1 : c₁ ⟶ c := hom_of_le le_sup_left,
    let i2 : c₂ ⟶ c := hom_of_le le_sup_right,
    change ((level.map i1).app _ _).val = ((level.map i2).app _ (Y.as_lvl t)).val,
    simp only [← CompHaus.comp_apply],
    rw hE,
    simp only [CompHaus.comp_apply],
    congr' 1,
    apply_fun (E c).inv,
    swap,
    { intros x y h,
      apply_fun (E c).hom at h,
      simp only [← CompHaus.comp_apply, iso.inv_hom_id] at h,
      exact h },
    rw [← CompHaus.comp_apply, iso.hom_inv_id, CompHaus.id_apply],
    rw [← CompHaus.comp_apply, ← create_iso_from_level_compat_aux],
    any_goals { assumption },
    refl,
  end }

lemma level_create_iso_from_level {X Y : CompHausFiltPseuNormGrp₁}
  (E : Π c, (level.obj c).obj X ≅ (level.obj c).obj Y)
  (hE0 : ((E (X.lvl 0)).hom (X.as_lvl 0)).1 = 0)
  (hEa : ∀ a b : X, ((E _).hom (X.as_lvl (a + b))).1 =
    ((E _).hom (X.as_lvl a)).1 + ((E _).hom (X.as_lvl b)).1)
  (hE : ∀ (c₁ c₂ : ℝ≥0) (i : c₁ ⟶ c₂),
    (E _).hom ≫ (level.map i).app _ = (level.map i).app _ ≫ (E _).hom) (c) :
  (level.obj c).map
  (create_iso_from_level E hE0 hEa hE).hom = (E _).hom :=
begin
  ext t,
  --  `dsimp [create_iso_from_level, create_hom_from_level, level],` -- changes the goal to
  -- ⊢ ↑(⇑((E (X.lvl ↑t)).hom) (X.as_lvl ↑t)) = ↑(⇑((E c).hom) t)
  -- but is not needed and slows down the proof.
  let d := X.lvl t.1 ⊔ c,
  let i1 : X.lvl t.1 ⟶ d := hom_of_le le_sup_left,
  let i2 : c ⟶ d := hom_of_le le_sup_right,
  change ((level.map i1).app _ _).val =
    ((level.map i2).app _ _).val,
  congr' 1,
  simp only [← CompHaus.comp_apply, hE], ext, refl
end

lemma level_jointly_faithful {X Y : CompHausFiltPseuNormGrp₁} (f g : X ⟶ Y)
  (h : ∀ c, (level.obj c).map f = (level.obj c).map g) : f = g :=
begin
  ext t,
  specialize h (X.lvl t),
  apply_fun (λ e, (e (X.as_lvl t)).1) at h,
  exact h
end

end CompHausFiltPseuNormGrp₁