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

import testing.slim_check.sampleable

/-!
# `testable` Class

Testable propositions have a procedure that can generate counter-examples
together with a proof that they invalidate the proposition.

This is a port of the Haskell QuickCheck library.

## Creating Customized Instances

The type classes `testable` and `sampleable` are the means by which
`slim_check` creates samples and tests them. For instance, the proposition
`∀ i j : ℕ, i ≤ j` has a `testable` instance because `ℕ` is sampleable
and `i ≤ j` is decidable. Once `slim_check` finds the `testable`
instance, it can start using the instance to repeatedly creating samples
and checking whether they satisfy the property. This allows the
user to create new instances and apply `slim_check` to new situations.

### Polymorphism

The property `testable.check (∀ (α : Type) (xs ys : list α), xs ++ ys
= ys ++ xs)` shows us that type-polymorphic properties can be
tested. `α` is instantiated with `ℤ` first and then tested as normal
monomorphic properties.

The monomorphisation limits the applicability of `slim_check` to
polymorphic properties that can be stated about integers. The
limitation may be lifted in the future but, for now, if
one wishes to use a different type than `ℤ`, one has to refer to
the desired type.

### What do I do if I'm testing a property about my newly defined type?

Let us consider a type made for a new formalization:

```lean
structure my_type :=
(x y : ℕ)
(h : x ≤ y)
```

How do we test a property about `my_type`? For instance, let us consider
`testable.check $ ∀ a b : my_type, a.y ≤ b.x → a.x ≤ b.y`. Writing this
property as is will give us an error because we do not have an instance
of `sampleable my_type`. We can define one as follows:

```lean
instance : sampleable my_type :=
{ sample := do
  x ← sample ℕ,
  xy_diff ← sample ℕ,
  return { x := x, y := x + xy_diff, h := /- some proof -/ } }
```

We can see that the instance is very simple because our type is built
up from other type that have `sampleable` instances. `sampleable` also
has a `shrink` method but it is optional. We may want to implement one
for ease of testing as:

```lean
/- ... -/
  shrink := λ ⟨x,y,h⟩, (λ ⟨x,y⟩, { x := x, y := x + y, h := /- proof -/}) <$> shrink (x, y - x) }
```

Again, we take advantage of the fact that other types have useful
`shrink` implementations, in this case `prod`.

### Optimizing the sampling

Some properties are guarded by a proposition. For instance, recall this
example:

```lean
#eval testable.check (∀ x : ℕ, 2 ∣ x → x < 100)
```

When testing the above example, we generate a natural number, we check
that it is even and test it if it is even or throw it away and start
over otherwise. Statistically, we can expect half of our samples to be
thrown away by such a filter. Sometimes, the filter is more
restrictive. For instance we might need `x` to be a `prime`
number. This would cause most of our samples to be discarded.

We can help `slim_check` find good samples by providing specialized
sampleable instances. Below, we show an instance for the subtype
of even natural numbers. This means that, when producing
a sample, it is forced to produce a proof that it is even.

```lean
instance {k : ℕ} [fact (0 < k)] : sampleable { x : ℕ // k ∣ x } :=
{ sample := do { n ← sample ℕ, pure ⟨k*n, dvd_mul_right _ _⟩ },
  shrink := λ ⟨x,h⟩, (λ y, ⟨k*y, dvd_mul_right _ _⟩) <$> shrink x }
```

Such instance will be preferred when testing a proposition of the shape
`∀ x : T, p x → q`

We can observe the effect by enabling tracing:

```lean
/- no specialized sampling -/
#eval testable.check (∀ x : ℕ, 2 ∣ x → x < 100) { trace_discarded := tt }
-- discard
--  x := 1
-- discard
--  x := 41
-- discard
--  x := 3
-- discard
--  x := 5
-- discard
--  x := 5
-- discard
--  x := 197
-- discard
--  x := 469
-- discard
--  x := 9
-- discard

-- ===================
-- Found problems!

-- x := 552
-- -------------------

/- let us define a specialized sampling instance -/
instance {k : ℕ} : sampleable { x : ℕ // k ∣ x } :=
{ sample := do { n ← sample ℕ, pure ⟨k*n, dvd_mul_right _ _⟩ },
  shrink := λ ⟨x,h⟩, (λ y, ⟨k*y, dvd_mul_right _ _⟩) <$> shrink x }

#eval testable.check (∀ x : ℕ, 2 ∣ x → x < 100) { enable_tracing := tt }
-- ===================
-- Found problems!

-- x := 358
-- -------------------
```

Similarly, it is common to write properties of the form: `∀ i j, i ≤ j → ...`
as the following example show:

```lean
#eval check (∀ i j k : ℕ, j < k → i - k < i - j)
```

Without subtype instances, the above property discards many samples
because `j < k` does not hold. Fortunately, we have appropriate
instance to choose `k` intelligently.

## Main definitions
  * `testable` class
  * `testable.check`: a way to test a proposition using random examples

## Tags

random testing

## References

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

-/

universes u v

variables var var' : string
variable α : Type u
variable β : α → Prop
variable f : Type → Prop

namespace slim_check

/-- Result of trying to disprove `p`

The constructors are:
  *  `success : (psum unit p) → test_result`
     succeed when we find another example satisfying `p`
     In `success h`, `h` is an optional proof of the proposition.
     Without the proof, all we know is that we found one example
     where `p` holds. With a proof, the one test was sufficient to
     prove that `p` holds and we do not need to keep finding examples.
   * `gave_up {} : ℕ → test_result`
     give up when a well-formed example cannot be generated.
     `gave_up n` tells us that `n` invalid examples were tried.
     Above 100, we give up on the proposition and report that we
     did not find a way to properly test it.
   * `failure : ¬ p → (list string) → ℕ → test_result`
     a counter-example to `p`; the strings specify values for the relevant variables.
     `failure h vs n` also carries a proof that `p` does not hold. This way, we can
     guarantee that there will be no false positive. The last component, `n`,
     is the number of times that the counter-example was shrunk.
-/
@[derive inhabited]
inductive test_result (p : Prop)
| success : (psum unit p) → test_result
| gave_up {} : ℕ → test_result
| failure : ¬ p → (list string) → ℕ → test_result

/-- format a `test_result` as a string. -/
protected def test_result.to_string {p} : test_result p → string
| (test_result.success (psum.inl ())) := "success (without proof)"
| (test_result.success (psum.inr h)) := "success (with proof)"
| (test_result.gave_up n) := sformat!"gave up {n} times"
| (test_result.failure a vs _) := sformat!"failed {vs}"

/-- configuration for testing a property -/
@[derive [has_reflect, inhabited]]
structure slim_check_cfg :=
(num_inst : ℕ                   := 100)  -- number of examples
(max_size : ℕ                   := 100)  -- final size argument
(trace_discarded : bool         := ff)   -- enable the printing out of discarded samples
(trace_success : bool           := ff)   -- enable the printing out of successful tests
(trace_shrink : bool            := ff)   -- enable the printing out of shrinking steps
(trace_shrink_candidates : bool := ff)   -- enable the printing out of shrinking candidates
(random_seed : option ℕ         := none) -- specify a seed to the random number generator to
                                         -- obtain a deterministic behavior
(quiet : bool                   := ff)   -- suppress success message when running `slim_check`

instance {p} : has_to_string (test_result p) := ⟨ test_result.to_string ⟩

/--
`printable_prop p` allows one to print a proposition so that
`slim_check` can indicate how values relate to each other.
-/
class printable_prop (p : Prop) :=
(print_prop : option string)

@[priority 100] -- see [note priority]
instance default_printable_prop {p} : printable_prop p :=
⟨ none ⟩

/-- `testable p` uses random examples to try to disprove `p`. -/
class testable (p : Prop) :=
(run [] (cfg : slim_check_cfg) (minimize : bool) : gen (test_result p))

open _root_.list

open test_result

/-- applicative combinator proof carrying test results -/
def combine {p q : Prop} : psum unit (p → q) → psum unit p → psum unit q
| (psum.inr f) (psum.inr x) := psum.inr (f x)
| _ _ := psum.inl ()

/-- Combine the test result for properties `p` and `q` to create a test for their conjunction. -/
def and_counter_example {p q : Prop} :
  test_result p →
  test_result q →
  test_result (p ∧ q)
| (failure Hce xs n) _ := failure (λ h, Hce h.1) xs n
| _ (failure Hce xs n) := failure (λ h, Hce h.2) xs n
| (success xs) (success ys) := success $ combine (combine (psum.inr and.intro) xs) ys
| (gave_up n) (gave_up m) := gave_up $ n + m
| (gave_up n) _ := gave_up n
| _ (gave_up n) := gave_up n

/-- Combine the test result for properties `p` and `q` to create a test for their disjunction -/
def or_counter_example {p q : Prop} :
  test_result p →
  test_result q →
  test_result (p ∨ q)
| (failure Hce xs n) (failure Hce' ys n') := failure (λ h, or_iff_not_and_not.1 h ⟨Hce, Hce'⟩)
  (xs ++ ys) (n + n')
| (success xs) _ := success $ combine (psum.inr or.inl) xs
| _ (success ys) := success $ combine (psum.inr or.inr) ys
| (gave_up n) (gave_up m) := gave_up $ n + m
| (gave_up n) _ := gave_up n
| _ (gave_up n) := gave_up n

/-- If `q → p`, then `¬ p → ¬ q` which means that testing `p` can allow us
to find counter-examples to `q`. -/
def convert_counter_example {p q : Prop}
  (h : q → p) :
  test_result p →
  opt_param (psum unit (p → q)) (psum.inl ()) →
  test_result q
| (failure Hce xs n) _ := failure (mt h Hce) xs n
| (success Hp) Hpq := success (combine Hpq Hp)
| (gave_up n) _ := gave_up n

/-- Test `q` by testing `p` and proving the equivalence between the two. -/
def convert_counter_example' {p q : Prop}
  (h : p ↔ q) (r : test_result p) :
  test_result q :=
convert_counter_example h.2 r (psum.inr h.1)

/-- When we assign a value to a universally quantified variable,
we record that value using this function so that our counter-examples
can be informative. -/
def add_to_counter_example (x : string) {p q : Prop}
  (h : q → p) :
  test_result p →
  opt_param (psum unit (p → q)) (psum.inl ()) →
  test_result q
| (failure Hce xs n) _ := failure (mt h Hce) (x :: xs) n
| r hpq := convert_counter_example h r hpq

/-- Add some formatting to the information recorded by `add_to_counter_example`. -/
def add_var_to_counter_example {γ : Type v} [has_repr γ]
  (var : string) (x : γ) {p q : Prop}
  (h : q → p) : test_result p →
  opt_param (psum unit (p → q)) (psum.inl ()) →
  test_result q :=
@add_to_counter_example (var ++ " := " ++ repr x) _ _ h

/-- Gadget used to introspect the name of bound variables.

It is used with the `testable` typeclass so that
`testable (named_binder "x" (∀ x, p x))` can use the variable name
of `x` in error messages displayed to the user. If we find that instantiating
the above quantifier with 3 falsifies it, we can print:

```
==============
Problem found!
==============
x := 3
```
 -/
@[simp, nolint unused_arguments]
def named_binder (n : string) (p : Prop) : Prop := p

/-- Is the given test result a failure? -/
def is_failure {p} : test_result p → bool
| (test_result.failure _ _ _) := tt
| _ := ff

instance and_testable (p q : Prop) [testable p] [testable q] :
  testable (p ∧ q) :=
⟨ λ cfg min, do
   xp ← testable.run p cfg min,
   xq ← testable.run q cfg min,
   pure $ and_counter_example xp xq ⟩

instance or_testable (p q : Prop) [testable p] [testable q] :
  testable (p ∨ q) :=
⟨ λ cfg min, do
   xp ← testable.run p cfg min,
   match xp with
   | success (psum.inl h) := pure $ success (psum.inl h)
   | success (psum.inr h) := pure $ success (psum.inr $ or.inl h)
   | _ := do
     xq ← testable.run q cfg min,
     pure $ or_counter_example xp xq
   end ⟩

instance iff_testable (p q : Prop) [testable ((p ∧ q) ∨ (¬ p ∧ ¬ q))] :
  testable (p ↔ q) :=
⟨ λ cfg min, do
   xp ← testable.run ((p ∧ q) ∨ (¬ p ∧ ¬ q)) cfg min,
   return $ convert_counter_example' (by tauto!) xp ⟩

open printable_prop

@[priority 1000]
instance dec_guard_testable (p : Prop) [printable_prop p] [decidable p] (β : p → Prop)
  [∀ h, testable (β h)] : testable (named_binder var $ Π h, β h) :=
⟨ λ cfg min, do
    if h : p
    then
      match print_prop p with
      | none := (λ r, convert_counter_example ($ h) r (psum.inr $ λ q _, q)) <$>
        testable.run (β h) cfg min
      | some str := (λ r, add_to_counter_example (sformat!"guard: {str}") ($ h) r
        (psum.inr $ λ q _, q)) <$> testable.run (β h) cfg min
      end
    else if cfg.trace_discarded ∨ cfg.trace_success then
      match print_prop p with
      | none := trace "discard" $ return $ gave_up 1
      | some str := trace sformat!"discard: {str} does not hold" $ return $ gave_up 1
      end
    else return $ gave_up 1 ⟩

/-- Type tag that replaces a type's `has_repr` instance with its `has_to_string` instance. -/
def use_has_to_string (α : Type*) := α

instance use_has_to_string.inhabited [I : inhabited α] : inhabited (use_has_to_string α) := I

/-- Add the type tag `use_has_to_string` to an expression's type. -/
def use_has_to_string.mk {α} (x : α) : use_has_to_string α := x

instance [has_to_string α] : has_repr (use_has_to_string α) :=
⟨ @to_string α _ ⟩

@[priority 2000]
instance all_types_testable [testable (f ℤ)] : testable (named_binder var $ Π x, f x) :=
⟨ λ cfg min, do
    r ← testable.run (f ℤ) cfg min,
    return $ add_var_to_counter_example var (use_has_to_string.mk "ℤ") ($ ℤ) r ⟩

/-- Trace the value of sampled variables if the sample is discarded. -/
def trace_if_giveup {p α β} [has_repr α] (tracing_enabled : bool) (var : string) (val : α) :
  test_result p → thunk β → β
| (test_result.gave_up _) :=
  if tracing_enabled then trace (sformat!" {var} := {repr val}")
  else ($ ())
| _ := ($ ())

/-- testable instance for a property iterating over the element of a list -/
@[priority 5000]
instance test_forall_in_list
  [∀ x, testable (β x)] [has_repr α] :
  Π xs : list α, testable (named_binder var $ ∀ x, named_binder var' $ x ∈ xs → β x)
| [] := ⟨ λ tracing min, return $ success $ psum.inr (by { introv x h, cases h} ) ⟩
| (x :: xs) :=
⟨ λ cfg min, do
    r ← testable.run (β x) cfg min,
    trace_if_giveup cfg.trace_discarded var x r $
      match r with
      | failure _ _ _ := return $ add_var_to_counter_example var x
                                 (by { intro h, apply h, left, refl }) r
      | success hp := do
         rs ← @testable.run _ (test_forall_in_list xs) cfg min,
         return $ convert_counter_example
                                 (by { intros h i h',
                                       apply h,
                                       right, apply h' })
                                 rs
                                 (combine (psum.inr
                                  $ by { intros j h, simp only [ball_cons, named_binder],
                                         split ; assumption, } ) hp)
      | gave_up n := do
         rs ← @testable.run _ (test_forall_in_list xs) cfg min,
         match rs with
         | (success _) := return $ gave_up n
         | (failure Hce xs n) := return $ failure
                      (by { simp only [ball_cons, named_binder],
                            apply not_and_of_not_right _ Hce, }) xs n
         | (gave_up n') := return $ gave_up (n + n')
         end
      end ⟩

/-- Test proposition `p` by randomly selecting one of the provided
testable instances. -/
def combine_testable (p : Prop)
  (t : list $ testable p) (h : 0 < t.length) : testable p :=
⟨ λ cfg min, have 0 < length (map (λ t, @testable.run _ t cfg min) t),
    by { rw [length_map], apply h },
  gen.one_of (list.map (λ t, @testable.run _ t cfg min) t) this ⟩

open sampleable_ext

/--
Format the counter-examples found in a test failure.
-/
def format_failure (s : string) (xs : list string) (n : ℕ) : string :=
let counter_ex := string.intercalate "\n" xs in
sformat!"
===================
{s}

{counter_ex}
({n} shrinks)
-------------------
"

/--
Format the counter-examples found in a test failure.
-/
def format_failure' (s : string) {p} : test_result p → string
| (success a) := ""
| (gave_up a) := ""
| (test_result.failure _ xs n) := format_failure s xs n

/--
Increase the number of shrinking steps in a test result.
-/
def add_shrinks {p} (n : ℕ) : test_result p → test_result p
| r@(success a) := r
| r@(gave_up a) := r
| (test_result.failure h vs n') := test_result.failure h vs $ n + n'

/-- Shrink a counter-example `x` by using `shrink x`, picking the first
candidate that falsifies a property and recursively shrinking that one.

The process is guaranteed to terminate because `shrink x` produces
a proof that all the values it produces are smaller (according to `sizeof`)
than `x`. -/
def minimize_aux [sampleable_ext α] [∀ x, testable (β x)] (cfg : slim_check_cfg) (var : string) :
  proxy_repr α → ℕ → option_t gen (Σ x, test_result (β (interp α x))) :=
well_founded.fix has_well_founded.wf $ λ x f_rec n, do
  if cfg.trace_shrink_candidates
    then return $ trace sformat!
      "candidates for {var} :=\n{repr (sampleable_ext.shrink x).to_list}\n" ()
    else pure (),
  ⟨y,r,⟨h₁⟩⟩ ← (sampleable_ext.shrink x).mfirst (λ ⟨a,h⟩, do
    ⟨r⟩ ← monad_lift (uliftable.up $ testable.run (β (interp α a)) cfg tt
      : gen (ulift $ test_result $ β $ interp α a)),
    if is_failure r
      then pure (⟨a, r, ⟨h⟩⟩ : (Σ a, test_result (β (interp α a)) × plift (sizeof_lt a x)))
      else failure),
  if cfg.trace_shrink then return $
    trace (sformat!"{var} := {repr y}" ++ format_failure' "Shrink counter-example:" r) ()
    else pure (),
  f_rec y h₁ (n+1) <|> pure ⟨y,add_shrinks (n+1) r⟩

/-- Once a property fails to hold on an example, look for smaller counter-examples
to show the user. -/
def minimize [sampleable_ext α] [∀ x, testable (β x)] (cfg : slim_check_cfg) (var : string)
  (x : proxy_repr α) (r : test_result (β (interp α x))) :
  gen (Σ x, test_result (β (interp α x))) := do
if cfg.trace_shrink then return $
  trace (sformat!"{var} := {repr x}" ++ format_failure' "Shrink counter-example:" r) ()
  else pure (),
x' ← option_t.run $ minimize_aux α _ cfg var x 0,
pure $ x'.get_or_else ⟨x, r⟩

@[priority 2000]
instance exists_testable (p : Prop)
  [testable (named_binder var (∀ x, named_binder var' $ β x → p))] :
  testable (named_binder var' (named_binder var (∃ x, β x) → p)) :=
⟨ λ cfg min, do
    x ← testable.run (named_binder var (∀ x, named_binder var' $ β x → p)) cfg min,
    pure $ convert_counter_example' exists_imp_distrib.symm x ⟩

/-- Test a universal property by creating a sample of the right type and instantiating the
bound variable with it -/
instance var_testable [sampleable_ext α] [∀ x, testable (β x)] :
  testable (named_binder var $ Π x : α, β x) :=
⟨ λ cfg min, do
   uliftable.adapt_down (sampleable_ext.sample α) $
   λ x, do
     r ← testable.run (β (sampleable_ext.interp α x)) cfg ff,
     uliftable.adapt_down (if is_failure r ∧ min
                          then minimize _ _ cfg var x r
                          else if cfg.trace_success
                          then trace (sformat!"  {var} := {repr x}") $ pure ⟨x,r⟩
                          else pure ⟨x,r⟩) $
     λ ⟨x,r⟩, return $ trace_if_giveup cfg.trace_discarded var x r (add_var_to_counter_example var x
      ($ sampleable_ext.interp α x) r) ⟩

/-- Test a universal property about propositions -/
instance prop_var_testable (β : Prop → Prop) [I : ∀ b : bool, testable (β b)] :
  testable (named_binder var $ Π p : Prop, β p) :=
⟨λ cfg min, do
  convert_counter_example (λ h (b : bool), h b) <$> @testable.run
    (named_binder var $ Π b : bool, β b) _ cfg min⟩

@[priority 3000]
instance unused_var_testable (β) [inhabited α] [testable β] :
  testable (named_binder var $ Π x : α, β) :=
⟨ λ cfg min, do
  r ← testable.run β cfg min,
  pure $ convert_counter_example ($ default) r (psum.inr $ λ x _, x) ⟩

@[priority 2000]
instance subtype_var_testable {p : α → Prop}
  [∀ x, printable_prop (p x)]
  [∀ x, testable (β x)]
  [I : sampleable_ext (subtype p)]  :
  testable (named_binder var $ Π x : α, named_binder var' $ p x → β x) :=
⟨ λ cfg min,
   do let test (x : subtype p) : testable (β x) :=
          ⟨ λ cfg min, do
              r ← testable.run (β x.val) cfg min,
              match print_prop (p x) with
              | none := pure r
              | some str := pure $ add_to_counter_example sformat!"guard: {str} (by construction)"
                id r (psum.inr id)
              end ⟩,
      r ← @testable.run (∀ x : subtype p, β x.val) (@slim_check.var_testable var _ _ I test) cfg
        min,
      pure $ convert_counter_example'
                 ⟨λ (h : ∀ x : subtype p, β x) x h', h ⟨x,h'⟩,
                  λ h ⟨x,h'⟩, h x h'⟩
                 r ⟩

@[priority 100]
instance decidable_testable (p : Prop) [printable_prop p] [decidable p] : testable p :=
⟨ λ cfg min, return $
  if h : p then success (psum.inr h)
  else
    match print_prop p with
    | none := failure h [] 0
    | some str := failure h [sformat!"issue: {str} does not hold"] 0
    end ⟩

instance eq.printable_prop {α} [has_repr α] (x y : α) : printable_prop (x = y) :=
⟨ some sformat!"{repr x} = {repr y}" ⟩

instance ne.printable_prop {α} [has_repr α] (x y : α) : printable_prop (x ≠ y) :=
⟨ some sformat!"{repr x} ≠ {repr y}" ⟩

instance le.printable_prop {α} [has_le α] [has_repr α] (x y : α) : printable_prop (x ≤ y) :=
⟨ some sformat!"{repr x} ≤ {repr y}" ⟩

instance lt.printable_prop {α} [has_lt α] [has_repr α] (x y : α) : printable_prop (x < y) :=
⟨ some sformat!"{repr x} < {repr y}" ⟩

instance perm.printable_prop {α} [has_repr α] (xs ys : list α) : printable_prop (xs ~ ys) :=
⟨ some sformat!"{repr xs} ~ {repr ys}" ⟩

instance and.printable_prop (x y : Prop) [printable_prop x] [printable_prop y] :
  printable_prop (x ∧ y) :=
⟨ do x' ← print_prop x,
    y' ← print_prop y,
    some sformat!"({x'} ∧ {y'})" ⟩

instance or.printable_prop (x y : Prop) [printable_prop x] [printable_prop y] :
  printable_prop (x ∨ y) :=
⟨ do x' ← print_prop x,
    y' ← print_prop y,
    some sformat!"({x'} ∨ {y'})" ⟩

instance iff.printable_prop (x y : Prop) [printable_prop x] [printable_prop y] :
  printable_prop (x ↔ y) :=
⟨ do x' ← print_prop x,
    y' ← print_prop y,
    some sformat!"({x'} ↔ {y'})" ⟩

instance imp.printable_prop (x y : Prop) [printable_prop x] [printable_prop y] :
  printable_prop (x → y) :=
⟨ do x' ← print_prop x,
    y' ← print_prop y,
    some sformat!"({x'} → {y'})" ⟩

instance not.printable_prop (x : Prop) [printable_prop x] : printable_prop (¬ x) :=
⟨ do x' ← print_prop x,
    some sformat!"¬ {x'}" ⟩

instance true.printable_prop : printable_prop true :=
⟨ some "true" ⟩

instance false.printable_prop : printable_prop false :=
⟨ some "false" ⟩

instance bool.printable_prop (b : bool) : printable_prop b :=
⟨ some $ if b then "true" else "false" ⟩

section io

open _root_.nat
variable {p : Prop}

/-- Execute `cmd` and repeat every time the result is `gave_up` (at most
`n` times). -/
def retry (cmd : rand (test_result p)) : ℕ → rand (test_result p)
| 0 := return $ gave_up 1
| (succ n) := do
r ← cmd,
match r with
| success hp := return $ success hp
| (failure Hce xs n) := return (failure Hce xs n)
| (gave_up _) := retry n
end

/-- Count the number of times the test procedure gave up. -/
def give_up (x : ℕ) : test_result p → test_result p
| (success (psum.inl ())) := gave_up x
| (success (psum.inr p))  := success (psum.inr p)
| (gave_up n) := gave_up (n+x)
| (failure Hce xs n) := failure Hce xs n

variable (p)

variable [testable p]

/-- Try `n` times to find a counter-example for `p`. -/
def testable.run_suite_aux (cfg : slim_check_cfg) : test_result p → ℕ → rand (test_result p)
| r 0 := return r
| r (succ n) :=
do let size := (cfg.num_inst - n - 1) * cfg.max_size / cfg.num_inst,
   when cfg.trace_success $ return $ trace sformat!"[slim_check: sample]" (),
   x ← retry ( (testable.run p cfg tt).run ⟨ size ⟩) 10,
   match x with
   | (success (psum.inl ())) := testable.run_suite_aux r n
   | (success (psum.inr Hp)) := return $ success (psum.inr Hp)
   | (failure Hce xs n) := return (failure Hce xs n)
   | (gave_up g) := testable.run_suite_aux (give_up g r) n
   end

/-- Try to find a counter-example of `p`. -/
def testable.run_suite (cfg : slim_check_cfg := {}) : rand (test_result p) :=
testable.run_suite_aux p cfg (success $ psum.inl ()) cfg.num_inst

/-- Run a test suite for `p` in `io`. -/
def testable.check' (cfg : slim_check_cfg := {}) : io (test_result p) :=
match cfg.random_seed with
| some seed := io.run_rand_with seed (testable.run_suite p cfg)
| none := io.run_rand (testable.run_suite p cfg)
end

namespace tactic

open _root_.tactic expr

/-!
## Decorations

Instances of `testable` use `named_binder` as a decoration on
propositions in order to access the name of bound variables, as in
`named_binder "x" (forall x, x < y)`.  This helps the
`testable` instances create useful error messages where variables
are matched with values that falsify a given proposition.

The following functions help support the gadget so that the user does
not have to put them in themselves.
-/

/-- `add_existential_decorations p` adds `a `named_binder` annotation at the
root of `p` if `p` is an existential quantification. -/
meta def add_existential_decorations : expr → expr
| e@`(@Exists %%α %%(lam n bi d b)) :=
  let n := to_string n in
  const ``named_binder [] (`(n) : expr) e
| e := e

/-- Traverse the syntax of a proposition to find universal quantifiers
and existential quantifiers and add `named_binder` annotations next to
them. -/
meta def add_decorations : expr → expr | e :=
e.replace $ λ e _,
  match e with
  | (pi n bi d b) :=
    let n := to_string n in
    some $ const ``named_binder [] (`(n) : expr)
      (pi n bi (add_existential_decorations d) (add_decorations b))
  | e := none
  end

/-- `decorations_of p` is used as a hint to `mk_decorations` to specify
that the goal should be satisfied with a proposition equivalent to `p`
with added annotations. -/
@[reducible, nolint unused_arguments]
def decorations_of (p : Prop) := Prop

/-- In a goal of the shape `⊢ tactic.decorations_of p`, `mk_decoration` examines
the syntax of `p` and add `named_binder` around universal quantifications and
existential quantifications to improve error messages.

This tool can be used in the declaration of a function as follows:

```lean
def foo (p : Prop) (p' : tactic.decorations_of p . mk_decorations) [testable p'] : ...
```

`p` is the parameter given by the user, `p'` is an equivalent proposition where
the quantifiers are annotated with `named_binder`.
-/
meta def mk_decorations : tactic unit := do
`(tactic.decorations_of %%p) ← target,
exact $ add_decorations p

end tactic

/-- Run a test suite for `p` and return true or false: should we believe that `p` holds? -/
def testable.check (p : Prop) (cfg : slim_check_cfg := {})
  (p' : tactic.decorations_of p . tactic.mk_decorations) [testable p'] : io punit := do
x ← match cfg.random_seed with
    | some seed := io.run_rand_with seed (testable.run_suite p' cfg)
    | none := io.run_rand (testable.run_suite p' cfg)
    end,
match x with
| (success _) := when (¬ cfg.quiet) $ io.put_str_ln "Success"
| (gave_up n) := io.fail sformat!"Gave up {repr n} times"
| (failure _ xs n) := do
  io.fail $ format_failure "Found problems!" xs n
end

end io

end slim_check


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Theory of complete lattices.
-/
import order.bounded_lattice data.set.basic tactic.pi_instances

set_option old_structure_cmd true
open set

namespace lattice
universes u v w w₂
variables {α : Type u} {β : Type v} {ι : Sort w} {ι₂ : Sort w₂}

/-- class for the `Sup` operator -/
class has_Sup (α : Type u) := (Sup : set α → α)
/-- class for the `Inf` operator -/
class has_Inf (α : Type u) := (Inf : set α → α)
/-- Supremum of a set -/
def Sup [has_Sup α] : set α → α := has_Sup.Sup
/-- Infimum of a set -/
def Inf [has_Inf α] : set α → α := has_Inf.Inf
/-- Indexed supremum -/
def supr [has_Sup α] (s : ι → α) : α := Sup (range s)
/-- Indexed infimum -/
def infi [has_Inf α] (s : ι → α) : α := Inf (range s)

def has_Inf_to_nonempty (α) [has_Inf α] : nonempty α := ⟨Inf ∅⟩
def has_Sup_to_nonempty (α) [has_Sup α] : nonempty α := ⟨Sup ∅⟩

notation `⨆` binders `, ` r:(scoped f, supr f) := r
notation `⨅` binders `, ` r:(scoped f, infi f) := r

/-- A complete lattice is a bounded lattice which
  has suprema and infima for every subset. -/
class complete_lattice (α : Type u) extends bounded_lattice α, has_Sup α, has_Inf α :=
(le_Sup : ∀s, ∀a∈s, a ≤ Sup s)
(Sup_le : ∀s a, (∀b∈s, b ≤ a) → Sup s ≤ a)
(Inf_le : ∀s, ∀a∈s, Inf s ≤ a)
(le_Inf : ∀s a, (∀b∈s, a ≤ b) → a ≤ Inf s)

/-- A complete linear order is a linear order whose lattice structure is complete. -/
class complete_linear_order (α : Type u) extends complete_lattice α, decidable_linear_order α

section
variables [complete_lattice α] {s t : set α} {a b : α}

@[ematch] theorem le_Sup : a ∈ s → a ≤ Sup s := complete_lattice.le_Sup s a

theorem Sup_le : (∀b∈s, b ≤ a) → Sup s ≤ a := complete_lattice.Sup_le s a

@[ematch] theorem Inf_le : a ∈ s → Inf s ≤ a := complete_lattice.Inf_le s a

theorem le_Inf : (∀b∈s, a ≤ b) → a ≤ Inf s := complete_lattice.le_Inf s a

theorem le_Sup_of_le (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
le_trans h (le_Sup hb)

theorem Inf_le_of_le (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
le_trans (Inf_le hb) h

theorem Sup_le_Sup (h : s ⊆ t) : Sup s ≤ Sup t :=
Sup_le (assume a, assume ha : a ∈ s, le_Sup $ h ha)

theorem Inf_le_Inf (h : s ⊆ t) : Inf t ≤ Inf s :=
le_Inf (assume a, assume ha : a ∈ s, Inf_le $ h ha)

@[simp] theorem Sup_le_iff : Sup s ≤ a ↔ (∀b ∈ s, b ≤ a) :=
⟨assume : Sup s ≤ a, assume b, assume : b ∈ s,
  le_trans (le_Sup ‹b ∈ s›) ‹Sup s ≤ a›,
  Sup_le⟩

@[simp] theorem le_Inf_iff : a ≤ Inf s ↔ (∀b ∈ s, a ≤ b) :=
⟨assume : a ≤ Inf s, assume b, assume : b ∈ s,
  le_trans ‹a ≤ Inf s› (Inf_le ‹b ∈ s›),
  le_Inf⟩

-- how to state this? instead a parameter `a`, use `∃a, a ∈ s` or `s ≠ ∅`?
theorem Inf_le_Sup (h : a ∈ s) : Inf s ≤ Sup s :=
by have := le_Sup h; finish
--Inf_le_of_le h (le_Sup h)

-- TODO: it is weird that we have to add union_def
theorem Sup_union {s t : set α} : Sup (s ∪ t) = Sup s ⊔ Sup t :=
le_antisymm
  (by finish)
  (sup_le (Sup_le_Sup $ subset_union_left _ _) (Sup_le_Sup $ subset_union_right _ _))

/- old proof:
le_antisymm
  (Sup_le $ assume a h, or.rec_on h (le_sup_left_of_le ∘ le_Sup) (le_sup_right_of_le ∘ le_Sup))
  (sup_le (Sup_le_Sup $ subset_union_left _ _) (Sup_le_Sup $ subset_union_right _ _))
-/

theorem Sup_inter_le {s t : set α} : Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
by finish
/-
  Sup_le (assume a ⟨a_s, a_t⟩, le_inf (le_Sup a_s) (le_Sup a_t))
-/

theorem Inf_union {s t : set α} : Inf (s ∪ t) = Inf s ⊓ Inf t :=
le_antisymm
  (le_inf (Inf_le_Inf $ subset_union_left _ _) (Inf_le_Inf $ subset_union_right _ _))
  (by finish)

/- old proof:
le_antisymm
  (le_inf (Inf_le_Inf $ subset_union_left _ _) (Inf_le_Inf $ subset_union_right _ _))
  (le_Inf $ assume a h, or.rec_on h (inf_le_left_of_le ∘ Inf_le) (inf_le_right_of_le ∘ Inf_le))
-/

theorem le_Inf_inter {s t : set α} : Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
by finish
/-
le_Inf (assume a ⟨a_s, a_t⟩, sup_le (Inf_le a_s) (Inf_le a_t))
-/

@[simp] theorem Sup_empty : Sup ∅ = (⊥ : α) :=
le_antisymm (by finish) (by finish)
-- le_antisymm (Sup_le (assume _, false.elim)) bot_le

@[simp] theorem Inf_empty : Inf ∅ = (⊤ : α) :=
le_antisymm (by finish) (by finish)
--le_antisymm le_top (le_Inf (assume _, false.elim))

@[simp] theorem Sup_univ : Sup univ = (⊤ : α) :=
le_antisymm (by finish) (le_Sup ⟨⟩) -- finish fails because ⊤ ≤ a simplifies to a = ⊤
--le_antisymm le_top (le_Sup ⟨⟩)

@[simp] theorem Inf_univ : Inf univ = (⊥ : α) :=
le_antisymm (Inf_le ⟨⟩) bot_le

-- TODO(Jeremy): get this automatically
@[simp] theorem Sup_insert {a : α} {s : set α} : Sup (insert a s) = a ⊔ Sup s :=
have Sup {b | b = a} = a,
  from le_antisymm (Sup_le $ assume b b_eq, b_eq ▸ le_refl _) (le_Sup rfl),
calc Sup (insert a s) = Sup {b | b = a} ⊔ Sup s : Sup_union
                  ... = a ⊔ Sup s : by rw [this]

@[simp] theorem Inf_insert {a : α} {s : set α} : Inf (insert a s) = a ⊓ Inf s :=
have Inf {b | b = a} = a,
  from le_antisymm (Inf_le rfl) (le_Inf $ assume b b_eq, b_eq ▸ le_refl _),
calc Inf (insert a s) = Inf {b | b = a} ⊓ Inf s : Inf_union
                  ... = a ⊓ Inf s : by rw [this]

@[simp] theorem Sup_singleton {a : α} : Sup {a} = a :=
by finish [singleton_def]
--eq.trans Sup_insert $ by simp

@[simp] theorem Inf_singleton {a : α} : Inf {a} = a :=
by finish [singleton_def]
--eq.trans Inf_insert $ by simp

@[simp] theorem Inf_eq_top : Inf s = ⊤ ↔ (∀a∈s, a = ⊤) :=
iff.intro
  (assume h a ha, top_unique $ h ▸ Inf_le ha)
  (assume h, top_unique $ le_Inf $ assume a ha, top_le_iff.2 $ h a ha)

@[simp] theorem Sup_eq_bot : Sup s = ⊥ ↔ (∀a∈s, a = ⊥) :=
iff.intro
  (assume h a ha, bot_unique $ h ▸ le_Sup ha)
  (assume h, bot_unique $ Sup_le $ assume a ha, le_bot_iff.2 $ h a ha)

end

section complete_linear_order
variables [complete_linear_order α] {s t : set α} {a b : α}

lemma Inf_lt_iff : Inf s < b ↔ (∃a∈s, a < b) :=
iff.intro
  (assume : Inf s < b, classical.by_contradiction $ assume : ¬ (∃a∈s, a < b),
    have b ≤ Inf s,
      from le_Inf $ assume a ha, le_of_not_gt $ assume h, this ⟨a, ha, h⟩,
    lt_irrefl b (lt_of_le_of_lt ‹b ≤ Inf s› ‹Inf s < b›))
  (assume ⟨a, ha, h⟩, lt_of_le_of_lt (Inf_le ha) h)

lemma lt_Sup_iff : b < Sup s ↔ (∃a∈s, b < a) :=
iff.intro
  (assume : b < Sup s, classical.by_contradiction $ assume : ¬ (∃a∈s, b < a),
    have Sup s ≤ b,
      from Sup_le $ assume a ha, le_of_not_gt $ assume h, this ⟨a, ha, h⟩,
    lt_irrefl b (lt_of_lt_of_le ‹b < Sup s› ‹Sup s ≤ b›))
  (assume ⟨a, ha, h⟩, lt_of_lt_of_le h $ le_Sup ha)

lemma Sup_eq_top : Sup s = ⊤ ↔ (∀b<⊤, ∃a∈s, b < a) :=
iff.intro
  (assume (h : Sup s = ⊤) b hb, by rwa [←h, lt_Sup_iff] at hb)
  (assume h, top_unique $ le_of_not_gt $ assume h',
    let ⟨a, ha, h⟩ := h _ h' in
    lt_irrefl a $ lt_of_le_of_lt (le_Sup ha) h)

lemma Inf_eq_bot : Inf s = ⊥ ↔ (∀b>⊥, ∃a∈s, a < b) :=
iff.intro
  (assume (h : Inf s = ⊥) b (hb : ⊥ < b), by rwa [←h, Inf_lt_iff] at hb)
  (assume h, bot_unique $ le_of_not_gt $ assume h',
    let ⟨a, ha, h⟩ := h _ h' in
    lt_irrefl a $ lt_of_lt_of_le h (Inf_le ha))

lemma lt_supr_iff {ι : Sort*} {f : ι → α} : a < supr f ↔ (∃i, a < f i) :=
iff.trans lt_Sup_iff $ iff.intro
  (assume ⟨a', ⟨i, rfl⟩, ha⟩, ⟨i, ha⟩)
  (assume ⟨i, hi⟩, ⟨f i, ⟨i, rfl⟩, hi⟩)

lemma infi_lt_iff {ι : Sort*} {f : ι → α} : infi f < a ↔ (∃i, f i < a) :=
iff.trans Inf_lt_iff $ iff.intro
  (assume ⟨a', ⟨i, rfl⟩, ha⟩, ⟨i, ha⟩)
  (assume ⟨i, hi⟩, ⟨f i, ⟨i, rfl⟩, hi⟩)

end complete_linear_order

/- supr & infi -/

section
variables [complete_lattice α] {s t : ι → α} {a b : α}

-- TODO: this declaration gives error when starting smt state
--@[ematch]
theorem le_supr (s : ι → α) (i : ι) : s i ≤ supr s :=
le_Sup ⟨i, rfl⟩

@[ematch] theorem le_supr' (s : ι → α) (i : ι) : (: s i ≤ supr s :) :=
le_Sup ⟨i, rfl⟩

/- TODO: this version would be more powerful, but, alas, the pattern matcher
   doesn't accept it.
@[ematch] theorem le_supr' (s : ι → α) (i : ι) : (: s i :) ≤ (: supr s :) :=
le_Sup ⟨i, rfl⟩
-/

theorem le_supr_of_le (i : ι) (h : a ≤ s i) : a ≤ supr s :=
le_trans h (le_supr _ i)

theorem supr_le (h : ∀i, s i ≤ a) : supr s ≤ a :=
Sup_le $ assume b ⟨i, eq⟩, eq ▸ h i

theorem supr_le_supr (h : ∀i, s i ≤ t i) : supr s ≤ supr t :=
supr_le $ assume i, le_supr_of_le i (h i)

theorem supr_le_supr2 {t : ι₂ → α} (h : ∀i, ∃j, s i ≤ t j) : supr s ≤ supr t :=
supr_le $ assume j, exists.elim (h j) le_supr_of_le

theorem supr_le_supr_const (h : ι → ι₂) : (⨆ i:ι, a) ≤ (⨆ j:ι₂, a) :=
supr_le $ le_supr _ ∘ h

@[simp] theorem supr_le_iff : supr s ≤ a ↔ (∀i, s i ≤ a) :=
⟨assume : supr s ≤ a, assume i, le_trans (le_supr _ _) this, supr_le⟩

-- TODO: finish doesn't do well here.
@[congr] theorem supr_congr_Prop {α : Type u} [has_Sup α] {p q : Prop} {f₁ : p → α} {f₂ : q → α}
  (pq : p ↔ q) (f : ∀x, f₁ (pq.mpr x) = f₂ x) : supr f₁ = supr f₂ :=
begin
  unfold supr,
  apply congr_arg,
  ext,
  simp,
  split,
  exact λ⟨h, W⟩, ⟨pq.1 h, eq.trans (f (pq.1 h)).symm W⟩,
  exact λ⟨h, W⟩, ⟨pq.2 h, eq.trans (f h) W⟩
end

theorem infi_le (s : ι → α) (i : ι) : infi s ≤ s i :=
Inf_le ⟨i, rfl⟩

@[ematch] theorem infi_le' (s : ι → α) (i : ι) : (: infi s ≤ s i :) :=
Inf_le ⟨i, rfl⟩

/- I wanted to see if this would help for infi_comm; it doesn't.
@[ematch] theorem infi_le₂' (s : ι → ι₂ → α) (i : ι) (j : ι₂): (: ⨅ i j, s i j :) ≤ (: s i j :) :=
begin
  transitivity,
  apply (infi_le (λ i, ⨅ j, s i j) i),
  apply infi_le
end
-/

theorem infi_le_of_le (i : ι) (h : s i ≤ a) : infi s ≤ a :=
le_trans (infi_le _ i) h

theorem le_infi (h : ∀i, a ≤ s i) : a ≤ infi s :=
le_Inf $ assume b ⟨i, eq⟩, eq ▸ h i

theorem infi_le_infi (h : ∀i, s i ≤ t i) : infi s ≤ infi t :=
le_infi $ assume i, infi_le_of_le i (h i)

theorem infi_le_infi2 {t : ι₂ → α} (h : ∀j, ∃i, s i ≤ t j) : infi s ≤ infi t :=
le_infi $ assume j, exists.elim (h j) infi_le_of_le

theorem infi_le_infi_const (h : ι₂ → ι) : (⨅ i:ι, a) ≤ (⨅ j:ι₂, a) :=
le_infi $ infi_le _ ∘ h

@[simp] theorem le_infi_iff : a ≤ infi s ↔ (∀i, a ≤ s i) :=
⟨assume : a ≤ infi s, assume i, le_trans this (infi_le _ _), le_infi⟩

@[congr] theorem infi_congr_Prop {α : Type u} [has_Inf α] {p q : Prop} {f₁ : p → α} {f₂ : q → α}
  (pq : p ↔ q) (f : ∀x, f₁ (pq.mpr x) = f₂ x) : infi f₁ = infi f₂ :=
begin
  unfold infi,
  apply congr_arg,
  ext,
  simp,
  split,
  exact λ⟨h, W⟩, ⟨pq.1 h, eq.trans (f (pq.1 h)).symm W⟩,
  exact λ⟨h, W⟩, ⟨pq.2 h, eq.trans (f h) W⟩
end

@[simp] theorem infi_const {a : α} : ∀[nonempty ι], (⨅ b:ι, a) = a
| ⟨i⟩ := le_antisymm (Inf_le ⟨i, rfl⟩) (by finish)

@[simp] theorem supr_const {a : α} : ∀[nonempty ι], (⨆ b:ι, a) = a
| ⟨i⟩ := le_antisymm (by finish) (le_Sup ⟨i, rfl⟩)

@[simp] lemma infi_top : (⨅i:ι, ⊤ : α) = ⊤ :=
top_unique $ le_infi $ assume i, le_refl _

@[simp] lemma supr_bot : (⨆i:ι, ⊥ : α) = ⊥ :=
bot_unique $ supr_le $ assume i, le_refl _

@[simp] lemma infi_eq_top : infi s = ⊤ ↔ (∀i, s i = ⊤) :=
iff.intro
  (assume eq i, top_unique $ eq ▸ infi_le _ _)
  (assume h, top_unique $ le_infi $ assume i, top_le_iff.2 $ h i)

@[simp] lemma supr_eq_bot : supr s = ⊥ ↔ (∀i, s i = ⊥) :=
iff.intro
  (assume eq i, bot_unique $ eq ▸ le_supr _ _)
  (assume h, bot_unique $ supr_le $ assume i, le_bot_iff.2 $ h i)

@[simp] lemma infi_pos {p : Prop} {f : p → α} (hp : p) : (⨅ h : p, f h) = f hp :=
le_antisymm (infi_le _ _) (le_infi $ assume h, le_refl _)

@[simp] lemma infi_neg {p : Prop} {f : p → α} (hp : ¬ p) : (⨅ h : p, f h) = ⊤ :=
le_antisymm le_top $ le_infi $ assume h, (hp h).elim

@[simp] lemma supr_pos {p : Prop} {f : p → α} (hp : p) : (⨆ h : p, f h) = f hp :=
le_antisymm (supr_le $ assume h, le_refl _) (le_supr _ _)

@[simp] lemma supr_neg {p : Prop} {f : p → α} (hp : ¬ p) : (⨆ h : p, f h) = ⊥ :=
le_antisymm (supr_le $ assume h, (hp h).elim) bot_le

lemma supr_eq_dif {p : Prop} [decidable p] (a : p → α) :
  (⨆h:p, a h) = (if h : p then a h else ⊥) :=
by by_cases p; simp [h]

lemma supr_eq_if {p : Prop} [decidable p] (a : α) :
  (⨆h:p, a) = (if p then a else ⊥) :=
by rw [supr_eq_dif, dif_eq_if]

lemma infi_eq_dif {p : Prop} [decidable p] (a : p → α) :
  (⨅h:p, a h) = (if h : p then a h else ⊤) :=
by by_cases p; simp [h]

lemma infi_eq_if {p : Prop} [decidable p] (a : α) :
  (⨅h:p, a) = (if p then a else ⊤) :=
by rw [infi_eq_dif, dif_eq_if]

-- TODO: should this be @[simp]?
theorem infi_comm {f : ι → ι₂ → α} : (⨅i, ⨅j, f i j) = (⨅j, ⨅i, f i j) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le_of_le j $ infi_le _ i)
  (le_infi $ assume j, le_infi $ assume i, infi_le_of_le i $ infi_le _ j)

/- TODO: this is strange. In the proof below, we get exactly the desired
   among the equalities, but close does not get it.
begin
  apply @le_antisymm,
    simp, intros,
    begin [smt]
      ematch, ematch, ematch, trace_state, have := le_refl (f i_1 i),
      trace_state, close
    end
end
-/

-- TODO: should this be @[simp]?
theorem supr_comm {f : ι → ι₂ → α} : (⨆i, ⨆j, f i j) = (⨆j, ⨆i, f i j) :=
le_antisymm
  (supr_le $ assume i, supr_le $ assume j, le_supr_of_le j $ le_supr _ i)
  (supr_le $ assume j, supr_le $ assume i, le_supr_of_le i $ le_supr _ j)

@[simp] theorem infi_infi_eq_left {b : β} {f : Πx:β, x = b → α} : (⨅x, ⨅h:x = b, f x h) = f b rfl :=
le_antisymm
  (infi_le_of_le b $ infi_le _ rfl)
  (le_infi $ assume b', le_infi $ assume eq, match b', eq with ._, rfl := le_refl _ end)

@[simp] theorem infi_infi_eq_right {b : β} {f : Πx:β, b = x → α} : (⨅x, ⨅h:b = x, f x h) = f b rfl :=
le_antisymm
  (infi_le_of_le b $ infi_le _ rfl)
  (le_infi $ assume b', le_infi $ assume eq, match b', eq with ._, rfl := le_refl _ end)

@[simp] theorem supr_supr_eq_left {b : β} {f : Πx:β, x = b → α} : (⨆x, ⨆h : x = b, f x h) = f b rfl :=
le_antisymm
  (supr_le $ assume b', supr_le $ assume eq, match b', eq with ._, rfl := le_refl _ end)
  (le_supr_of_le b $ le_supr _ rfl)

@[simp] theorem supr_supr_eq_right {b : β} {f : Πx:β, b = x → α} : (⨆x, ⨆h : b = x, f x h) = f b rfl :=
le_antisymm
  (supr_le $ assume b', supr_le $ assume eq, match b', eq with ._, rfl := le_refl _ end)
  (le_supr_of_le b $ le_supr _ rfl)

attribute [ematch] le_refl

theorem infi_inf_eq {f g : ι → α} : (⨅ x, f x ⊓ g x) = (⨅ x, f x) ⊓ (⨅ x, g x) :=
le_antisymm
  (le_inf
    (le_infi $ assume i, infi_le_of_le i inf_le_left)
    (le_infi $ assume i, infi_le_of_le i inf_le_right))
  (le_infi $ assume i, le_inf
    (inf_le_left_of_le $ infi_le _ _)
    (inf_le_right_of_le $ infi_le _ _))

/- TODO: here is another example where more flexible pattern matching
   might help.

begin
  apply @le_antisymm,
  safe, pose h := f a ⊓ g a, begin [smt] ematch, ematch  end
end
-/

lemma infi_inf {f : ι → α} {a : α} (i : ι) : (⨅x, f x) ⊓ a = (⨅ x, f x ⊓ a) :=
le_antisymm
  (le_infi $ assume i, le_inf (inf_le_left_of_le $ infi_le _ _) inf_le_right)
  (le_inf (infi_le_infi $ assume i, inf_le_left) (infi_le_of_le i inf_le_right))

lemma inf_infi {f : ι → α} {a : α} (i : ι) : a ⊓ (⨅x, f x) = (⨅ x, a ⊓ f x) :=
by rw [inf_comm, infi_inf i]; simp [inf_comm]

lemma binfi_inf {ι : Sort*} {p : ι → Prop}
  {f : Πi, p i → α} {a : α} {i : ι} (hi : p i) :
  (⨅i (h : p i), f i h) ⊓ a = (⨅ i (h : p i), f i h ⊓ a) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume hi,
    le_inf (inf_le_left_of_le $ infi_le_of_le i $ infi_le _ _) inf_le_right)
  (le_inf (infi_le_infi $ assume i, infi_le_infi $ assume hi, inf_le_left)
     (infi_le_of_le i $ infi_le_of_le hi $ inf_le_right))

theorem supr_sup_eq {f g : β → α} : (⨆ x, f x ⊔ g x) = (⨆ x, f x) ⊔ (⨆ x, g x) :=
le_antisymm
  (supr_le $ assume i, sup_le
    (le_sup_left_of_le $ le_supr _ _)
    (le_sup_right_of_le $ le_supr _ _))
  (sup_le
    (supr_le $ assume i, le_supr_of_le i le_sup_left)
    (supr_le $ assume i, le_supr_of_le i le_sup_right))

/- supr and infi under Prop -/

@[simp] theorem infi_false {s : false → α} : infi s = ⊤ :=
le_antisymm le_top (le_infi $ assume i, false.elim i)

@[simp] theorem supr_false {s : false → α} : supr s = ⊥ :=
le_antisymm (supr_le $ assume i, false.elim i) bot_le

@[simp] theorem infi_true {s : true → α} : infi s = s trivial :=
le_antisymm (infi_le _ _) (le_infi $ assume ⟨⟩, le_refl _)

@[simp] theorem supr_true {s : true → α} : supr s = s trivial :=
le_antisymm (supr_le $ assume ⟨⟩, le_refl _) (le_supr _ _)

@[simp] theorem infi_exists {p : ι → Prop} {f : Exists p → α} : (⨅ x, f x) = (⨅ i, ⨅ h:p i, f ⟨i, h⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

@[simp] theorem supr_exists {p : ι → Prop} {f : Exists p → α} : (⨆ x, f x) = (⨆ i, ⨆ h:p i, f ⟨i, h⟩) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λh:p i, f ⟨i, h⟩) _)
  (supr_le $ assume i, supr_le $ assume : p i, le_supr _ _)

theorem infi_and {p q : Prop} {s : p ∧ q → α} : infi s = (⨅ h₁ h₂, s ⟨h₁, h₂⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

theorem supr_and {p q : Prop} {s : p ∧ q → α} : supr s = (⨆ h₁ h₂, s ⟨h₁, h₂⟩) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λj, s ⟨i, j⟩) _)
  (supr_le $ assume i, supr_le $ assume j, le_supr _ _)

theorem infi_or {p q : Prop} {s : p ∨ q → α} :
  infi s = (⨅ h : p, s (or.inl h)) ⊓ (⨅ h : q, s (or.inr h)) :=
le_antisymm
  (le_inf
    (infi_le_infi2 $ assume j, ⟨_, le_refl _⟩)
    (infi_le_infi2 $ assume j, ⟨_, le_refl _⟩))
  (le_infi $ assume i, match i with
  | or.inl i := inf_le_left_of_le $ infi_le _ _
  | or.inr j := inf_le_right_of_le $ infi_le _ _
  end)

theorem supr_or {p q : Prop} {s : p ∨ q → α} :
  (⨆ x, s x) = (⨆ i, s (or.inl i)) ⊔ (⨆ j, s (or.inr j)) :=
le_antisymm
  (supr_le $ assume s, match s with
  | or.inl i := le_sup_left_of_le $ le_supr _ i
  | or.inr j := le_sup_right_of_le $ le_supr _ j
  end)
  (sup_le
    (supr_le_supr2 $ assume i, ⟨or.inl i, le_refl _⟩)
    (supr_le_supr2 $ assume j, ⟨or.inr j, le_refl _⟩))

theorem Inf_eq_infi {s : set α} : Inf s = (⨅a ∈ s, a) :=
le_antisymm
  (le_infi $ assume b, le_infi $ assume h, Inf_le h)
  (le_Inf $ assume b h, infi_le_of_le b $ infi_le _ h)

theorem Sup_eq_supr {s : set α} : Sup s = (⨆a ∈ s, a) :=
le_antisymm
  (Sup_le $ assume b h, le_supr_of_le b $ le_supr _ h)
  (supr_le $ assume b, supr_le $ assume h, le_Sup h)

lemma Sup_range {α : Type u} [has_Sup α] {f : ι → α} : Sup (range f) = supr f := rfl

lemma Inf_range {α : Type u} [has_Inf α] {f : ι → α} : Inf (range f) = infi f := rfl

lemma supr_range {g : β → α} {f : ι → β} : (⨆b∈range f, g b) = (⨆i, g (f i)) :=
le_antisymm
  (supr_le $ assume b, supr_le $ assume ⟨i, (h : f i = b)⟩, h ▸ le_supr _ i)
  (supr_le $ assume i, le_supr_of_le (f i) $ le_supr (λp, g (f i)) (mem_range_self _))

lemma infi_range {g : β → α} {f : ι → β} : (⨅b∈range f, g b) = (⨅i, g (f i)) :=
le_antisymm
  (le_infi $ assume i, infi_le_of_le (f i) $ infi_le (λp, g (f i)) (mem_range_self _))
  (le_infi $ assume b, le_infi $ assume ⟨i, (h : f i = b)⟩, h ▸ infi_le _ i)

theorem Inf_image {s : set β} {f : β → α} : Inf (f '' s) = (⨅ a ∈ s, f a) :=
calc Inf (set.image f s) = (⨅a, ⨅h : ∃b, b ∈ s ∧ f b = a, a) : Inf_eq_infi
                     ... = (⨅a, ⨅b, ⨅h : f b = a ∧ b ∈ s, a) : by simp [and_comm]
                     ... = (⨅a, ⨅b, ⨅h : a = f b, ⨅h : b ∈ s, a) : by simp [infi_and, eq_comm]
                     ... = (⨅b, ⨅a, ⨅h : a = f b, ⨅h : b ∈ s, a) : by rw [infi_comm]
                     ... = (⨅a∈s, f a) : congr_arg infi $ by funext x; rw [infi_infi_eq_left]

theorem Sup_image {s : set β} {f : β → α} : Sup (f '' s) = (⨆ a ∈ s, f a) :=
calc Sup (set.image f s) = (⨆a, ⨆h : ∃b, b ∈ s ∧ f b = a, a) : Sup_eq_supr
                     ... = (⨆a, ⨆b, ⨆h : f b = a ∧ b ∈ s, a) : by simp [and_comm]
                     ... = (⨆a, ⨆b, ⨆h : a = f b, ⨆h : b ∈ s, a) : by simp [supr_and, eq_comm]
                     ... = (⨆b, ⨆a, ⨆h : a = f b, ⨆h : b ∈ s, a) : by rw [supr_comm]
                     ... = (⨆a∈s, f a) : congr_arg supr $ by funext x; rw [supr_supr_eq_left]

/- supr and infi under set constructions -/

/- should work using the simplifier! -/
@[simp] theorem infi_emptyset {f : β → α} : (⨅ x ∈ (∅ : set β), f x) = ⊤ :=
le_antisymm le_top (le_infi $ assume x, le_infi false.elim)

@[simp] theorem supr_emptyset {f : β → α} : (⨆ x ∈ (∅ : set β), f x) = ⊥ :=
le_antisymm (supr_le $ assume x, supr_le false.elim) bot_le

@[simp] theorem infi_univ {f : β → α} : (⨅ x ∈ (univ : set β), f x) = (⨅ x, f x) :=
show (⨅ (x : β) (H : true), f x) = ⨅ (x : β), f x,
  from congr_arg infi $ funext $ assume x, infi_const

@[simp] theorem supr_univ {f : β → α} : (⨆ x ∈ (univ : set β), f x) = (⨆ x, f x) :=
show (⨆ (x : β) (H : true), f x) = ⨆ (x : β), f x,
  from congr_arg supr $ funext $ assume x, supr_const

@[simp] theorem infi_union {f : β → α} {s t : set β} : (⨅ x ∈ s ∪ t, f x) = (⨅x∈s, f x) ⊓ (⨅x∈t, f x) :=
calc (⨅ x ∈ s ∪ t, f x) = (⨅ x, (⨅h : x∈s, f x) ⊓ (⨅h : x∈t, f x)) : congr_arg infi $ funext $ assume x, infi_or
                    ... = (⨅x∈s, f x) ⊓ (⨅x∈t, f x) : infi_inf_eq

theorem infi_le_infi_of_subset {f : β → α} {s t : set β} (h : s ⊆ t) :
  (⨅ x ∈ t, f x) ≤ (⨅ x ∈ s, f x) :=
by rw [(union_eq_self_of_subset_left h).symm, infi_union]; exact inf_le_left

@[simp] theorem supr_union {f : β → α} {s t : set β} : (⨆ x ∈ s ∪ t, f x) = (⨆x∈s, f x) ⊔ (⨆x∈t, f x) :=
calc (⨆ x ∈ s ∪ t, f x) = (⨆ x, (⨆h : x∈s, f x) ⊔ (⨆h : x∈t, f x)) : congr_arg supr $ funext $ assume x, supr_or
                    ... = (⨆x∈s, f x) ⊔ (⨆x∈t, f x) : supr_sup_eq

theorem supr_le_supr_of_subset {f : β → α} {s t : set β} (h : s ⊆ t) :
  (⨆ x ∈ s, f x) ≤ (⨆ x ∈ t, f x) :=
by rw [(union_eq_self_of_subset_left h).symm, supr_union]; exact le_sup_left

@[simp] theorem insert_of_has_insert (x : α) (a : set α) : has_insert.insert x a = insert x a := rfl

@[simp] theorem infi_insert {f : β → α} {s : set β} {b : β} : (⨅ x ∈ insert b s, f x) = f b ⊓ (⨅x∈s, f x) :=
eq.trans infi_union $ congr_arg (λx:α, x ⊓ (⨅x∈s, f x)) infi_infi_eq_left

@[simp] theorem supr_insert {f : β → α} {s : set β} {b : β} : (⨆ x ∈ insert b s, f x) = f b ⊔ (⨆x∈s, f x) :=
eq.trans supr_union $ congr_arg (λx:α, x ⊔ (⨆x∈s, f x)) supr_supr_eq_left

@[simp] theorem infi_singleton {f : β → α} {b : β} : (⨅ x ∈ (singleton b : set β), f x) = f b :=
show (⨅ x ∈ insert b (∅ : set β), f x) = f b,
  by simp

@[simp] theorem supr_singleton {f : β → α} {b : β} : (⨆ x ∈ (singleton b : set β), f x) = f b :=
show (⨆ x ∈ insert b (∅ : set β), f x) = f b,
  by simp

lemma infi_image {γ} {f : β → γ} {g : γ → α} {t : set β} :
  (⨅ c ∈ f '' t, g c) = (⨅ b ∈ t, g (f b)) :=
le_antisymm
  (le_infi $ assume b, le_infi $ assume hbt,
    infi_le_of_le (f b) $ infi_le (λ_, g (f b)) (mem_image_of_mem f hbt))
  (le_infi $ assume c, le_infi $ assume ⟨b, hbt, eq⟩,
    eq ▸ infi_le_of_le b $ infi_le (λ_, g (f b)) hbt)

lemma supr_image {γ} {f : β → γ} {g : γ → α} {t : set β} :
  (⨆ c ∈ f '' t, g c) = (⨆ b ∈ t, g (f b)) :=
le_antisymm
  (supr_le $ assume c, supr_le $ assume ⟨b, hbt, eq⟩,
    eq ▸ le_supr_of_le b $ le_supr (λ_, g (f b)) hbt)
  (supr_le $ assume b, supr_le $ assume hbt,
    le_supr_of_le (f b) $ le_supr (λ_, g (f b)) (mem_image_of_mem f hbt))

/- supr and infi under Type -/

@[simp] theorem infi_empty {s : empty → α} : infi s = ⊤ :=
le_antisymm le_top (le_infi $ assume i, empty.rec_on _ i)

@[simp] theorem supr_empty {s : empty → α} : supr s = ⊥ :=
le_antisymm (supr_le $ assume i, empty.rec_on _ i) bot_le

@[simp] theorem infi_unit {f : unit → α} : (⨅ x, f x) = f () :=
le_antisymm (infi_le _ _) (le_infi $ assume ⟨⟩, le_refl _)

@[simp] theorem supr_unit {f : unit → α} : (⨆ x, f x) = f () :=
le_antisymm (supr_le $ assume ⟨⟩, le_refl _) (le_supr _ _)

lemma supr_bool_eq {f : bool → α} : (⨆b:bool, f b) = f tt ⊔ f ff :=
le_antisymm
  (supr_le $ assume b, match b with tt := le_sup_left | ff := le_sup_right end)
  (sup_le (le_supr _ _) (le_supr _ _))

lemma infi_bool_eq {f : bool → α} : (⨅b:bool, f b) = f tt ⊓ f ff :=
le_antisymm
  (le_inf (infi_le _ _) (infi_le _ _))
  (le_infi $ assume b, match b with tt := inf_le_left | ff := inf_le_right end)

theorem infi_subtype {p : ι → Prop} {f : subtype p → α} : (⨅ x, f x) = (⨅ i (h:p i), f ⟨i, h⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

theorem supr_subtype {p : ι → Prop} {f : subtype p → α} : (⨆ x, f x) = (⨆ i (h:p i), f ⟨i, h⟩) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λh:p i, f ⟨i, h⟩) _)
  (supr_le $ assume i, supr_le $ assume : p i, le_supr _ _)

theorem infi_sigma {p : β → Type w} {f : sigma p → α} : (⨅ x, f x) = (⨅ i (h:p i), f ⟨i, h⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

theorem supr_sigma {p : β → Type w} {f : sigma p → α} : (⨆ x, f x) = (⨆ i (h:p i), f ⟨i, h⟩) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λh:p i, f ⟨i, h⟩) _)
  (supr_le $ assume i, supr_le $ assume : p i, le_supr _ _)

theorem infi_prod {γ : Type w} {f : β × γ → α} : (⨅ x, f x) = (⨅ i j, f (i, j)) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

theorem supr_prod {γ : Type w} {f : β × γ → α} : (⨆ x, f x) = (⨆ i j, f (i, j)) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λj, f ⟨i, j⟩) _)
  (supr_le $ assume i, supr_le $ assume j, le_supr _ _)

theorem infi_sum {γ : Type w} {f : β ⊕ γ → α} :
  (⨅ x, f x) = (⨅ i, f (sum.inl i)) ⊓ (⨅ j, f (sum.inr j)) :=
le_antisymm
  (le_inf
    (infi_le_infi2 $ assume i, ⟨_, le_refl _⟩)
    (infi_le_infi2 $ assume j, ⟨_, le_refl _⟩))
  (le_infi $ assume s, match s with
  | sum.inl i := inf_le_left_of_le $ infi_le _ _
  | sum.inr j := inf_le_right_of_le $ infi_le _ _
  end)

theorem supr_sum {γ : Type w} {f : β ⊕ γ → α} :
  (⨆ x, f x) = (⨆ i, f (sum.inl i)) ⊔ (⨆ j, f (sum.inr j)) :=
le_antisymm
  (supr_le $ assume s, match s with
  | sum.inl i := le_sup_left_of_le $ le_supr _ i
  | sum.inr j := le_sup_right_of_le $ le_supr _ j
  end)
  (sup_le
    (supr_le_supr2 $ assume i, ⟨sum.inl i, le_refl _⟩)
    (supr_le_supr2 $ assume j, ⟨sum.inr j, le_refl _⟩))

end

section complete_linear_order
variables [complete_linear_order α]

lemma supr_eq_top (f : ι → α) : supr f = ⊤ ↔ (∀b<⊤, ∃i, b < f i) :=
by rw [← Sup_range, Sup_eq_top];
from forall_congr (assume b, forall_congr (assume hb, set.exists_range_iff))

lemma infi_eq_bot (f : ι → α) : infi f = ⊥ ↔ (∀b>⊥, ∃i, b > f i) :=
by rw [← Inf_range, Inf_eq_bot];
from forall_congr (assume b, forall_congr (assume hb, set.exists_range_iff))

end complete_linear_order

/- Instances -/

instance complete_lattice_Prop : complete_lattice Prop :=
{ Sup    := λs, ∃a∈s, a,
  le_Sup := assume s a h p, ⟨a, h, p⟩,
  Sup_le := assume s a h ⟨b, h', p⟩, h b h' p,
  Inf    := λs, ∀a:Prop, a∈s → a,
  Inf_le := assume s a h p, p a h,
  le_Inf := assume s a h p b hb, h b hb p,
  ..lattice.bounded_lattice_Prop }

lemma Inf_Prop_eq {s : set Prop} : Inf s = (∀p ∈ s, p) := rfl

lemma Sup_Prop_eq {s : set Prop} : Sup s = (∃p ∈ s, p) := rfl

lemma infi_Prop_eq {ι : Sort*} {p : ι → Prop} : (⨅i, p i) = (∀i, p i) :=
le_antisymm (assume h i, h _ ⟨i, rfl⟩ ) (assume h p ⟨i, eq⟩, eq ▸ h i)

lemma supr_Prop_eq {ι : Sort*} {p : ι → Prop} : (⨆i, p i) = (∃i, p i) :=
le_antisymm (assume ⟨q, ⟨i, (eq : p i = q)⟩, hq⟩, ⟨i, eq.symm ▸ hq⟩) (assume ⟨i, hi⟩, ⟨p i, ⟨i, rfl⟩, hi⟩)

instance pi.complete_lattice {α : Type u} {β : α → Type v} [∀ i, complete_lattice (β i)] :
  complete_lattice (Π i, β i) :=
by { pi_instance;
     { intros, intro,
       apply_field, intros,
       simp at H, rcases H with ⟨ x, H₀, H₁ ⟩,
       subst b, apply a_1 _ H₀ i, } }

lemma Inf_apply
  {α : Type u} {β : α → Type v} [∀ i, complete_lattice (β i)] {s : set (Πa, β a)} {a : α} :
  (Inf s) a = (⨅f∈s, (f : Πa, β a) a) :=
by rw [← Inf_image]; refl

lemma infi_apply {α : Type u} {β : α → Type v} {ι : Sort*} [∀ i, complete_lattice (β i)]
  {f : ι → Πa, β a} {a : α} : (⨅i, f i) a = (⨅i, f i a) :=
by erw [← Inf_range, Inf_apply, infi_range]

lemma Sup_apply
  {α : Type u} {β : α → Type v} [∀ i, complete_lattice (β i)] {s : set (Πa, β a)} {a : α} :
  (Sup s) a = (⨆f∈s, (f : Πa, β a) a) :=
by rw [← Sup_image]; refl

lemma supr_apply {α : Type u} {β : α → Type v} {ι : Sort*} [∀ i, complete_lattice (β i)]
  {f : ι → Πa, β a} {a : α} : (⨆i, f i) a = (⨆i, f i a) :=
by erw [← Sup_range, Sup_apply, supr_range]

section complete_lattice
variables [preorder α] [complete_lattice β]

theorem monotone_Sup_of_monotone {s : set (α → β)} (m_s : ∀f∈s, monotone f) : monotone (Sup s) :=
assume x y h, Sup_le $ assume x' ⟨f, f_in, fx_eq⟩, le_Sup_of_le ⟨f, f_in, rfl⟩ $ fx_eq ▸ m_s _ f_in h

theorem monotone_Inf_of_monotone {s : set (α → β)} (m_s : ∀f∈s, monotone f) : monotone (Inf s) :=
assume x y h, le_Inf $ assume x' ⟨f, f_in, fx_eq⟩, Inf_le_of_le ⟨f, f_in, rfl⟩ $ fx_eq ▸ m_s _ f_in h

end complete_lattice

section ord_continuous
open lattice
variables [complete_lattice α] [complete_lattice β]

/-- A function `f` between complete lattices is order-continuous
  if it preserves all suprema. -/
def ord_continuous (f : α → β) := ∀s : set α, f (Sup s) = (⨆i∈s, f i)

lemma ord_continuous_sup {f : α → β} {a₁ a₂ : α} (hf : ord_continuous f) : f (a₁ ⊔ a₂) = f a₁ ⊔ f a₂ :=
have h : f (Sup {a₁, a₂}) = (⨆i∈({a₁, a₂} : set α), f i), from hf _,
have h₁ : {a₁, a₂} = (insert a₂ {a₁} : set α), from rfl,
begin
  rw [h₁, Sup_insert, Sup_singleton, sup_comm] at h,
  rw [h, supr_insert, supr_singleton, sup_comm]
end

lemma ord_continuous_mono {f : α → β} (hf : ord_continuous f) : monotone f :=
assume a₁ a₂ h,
calc f a₁ ≤ f a₁ ⊔ f a₂ : le_sup_left
  ... = f (a₁ ⊔ a₂) : (ord_continuous_sup hf).symm
  ... = _ : by rw [sup_of_le_right h]

end ord_continuous
end lattice

namespace order_dual
open lattice
variable (α : Type*)

instance [has_Inf α] : has_Sup (order_dual α) := ⟨(Inf : set α → α)⟩
instance [has_Sup α] : has_Inf (order_dual α) := ⟨(Sup : set α → α)⟩

instance [complete_lattice α] : complete_lattice (order_dual α) :=
{ le_Sup := @complete_lattice.Inf_le α _,
  Sup_le := @complete_lattice.le_Inf α _,
  Inf_le := @complete_lattice.le_Sup α _,
  le_Inf := @complete_lattice.Sup_le α _,
  .. order_dual.lattice.bounded_lattice α, ..order_dual.lattice.has_Sup α, ..order_dual.lattice.has_Inf α }

instance [complete_linear_order α] : complete_linear_order (order_dual α) :=
{ .. order_dual.lattice.complete_lattice α, .. order_dual.decidable_linear_order α }

end order_dual

namespace prod
open lattice
variables (α : Type*) (β : Type*)

instance [has_Inf α] [has_Inf β] : has_Inf (α × β) :=
⟨λs, (Inf (prod.fst '' s), Inf (prod.snd '' s))⟩

instance [has_Sup α] [has_Sup β] : has_Sup (α × β) :=
⟨λs, (Sup (prod.fst '' s), Sup (prod.snd '' s))⟩

instance [complete_lattice α] [complete_lattice β] : complete_lattice (α × β) :=
{ le_Sup := assume s p hab, ⟨le_Sup $ mem_image_of_mem _ hab, le_Sup $ mem_image_of_mem _ hab⟩,
  Sup_le := assume s p h,
    ⟨ Sup_le $ ball_image_of_ball $ assume p hp, (h p hp).1,
      Sup_le $ ball_image_of_ball $ assume p hp, (h p hp).2⟩,
  Inf_le := assume s p hab, ⟨Inf_le $ mem_image_of_mem _ hab, Inf_le $ mem_image_of_mem _ hab⟩,
  le_Inf := assume s p h,
    ⟨ le_Inf $ ball_image_of_ball $ assume p hp, (h p hp).1,
      le_Inf $ ball_image_of_ball $ assume p hp, (h p hp).2⟩,
  .. prod.lattice.bounded_lattice α β,
  .. prod.lattice.has_Sup α β,
  .. prod.lattice.has_Inf α β }

end prod


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import data.set.finite
import algebra.big_operators.basic

/-!
# Preimage of a `finset` under an injective map.

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
-/

open set function

open_locale big_operators

universes u v w x
variables {α : Type u} {β : Type v} {ι : Sort w} {γ : Type x}

namespace finset

section preimage

/-- Preimage of `s : finset β` under a map `f` injective of `f ⁻¹' s` as a `finset`.  -/
noncomputable def preimage (s : finset β) (f : α → β)
  (hf : set.inj_on f (f ⁻¹' ↑s)) : finset α :=
(s.finite_to_set.preimage hf).to_finset

@[simp] lemma mem_preimage {f : α → β} {s : finset β} {hf : set.inj_on f (f ⁻¹' ↑s)} {x : α} :
  x ∈ preimage s f hf ↔ f x ∈ s :=
set.finite.mem_to_finset _

@[simp, norm_cast] lemma coe_preimage {f : α → β} (s : finset β)
  (hf : set.inj_on f (f ⁻¹' ↑s)) : (↑(preimage s f hf) : set α) = f ⁻¹' ↑s :=
set.finite.coe_to_finset _

@[simp] lemma preimage_empty {f : α → β} : preimage ∅ f (by simp [inj_on]) = ∅ :=
finset.coe_injective (by simp)

@[simp] lemma preimage_univ {f : α → β} [fintype α] [fintype β] (hf) :
  preimage univ f hf = univ :=
finset.coe_injective (by simp)

@[simp] lemma preimage_inter [decidable_eq α] [decidable_eq β] {f : α → β} {s t : finset β}
  (hs : set.inj_on f (f ⁻¹' ↑s)) (ht : set.inj_on f (f ⁻¹' ↑t)) :
  preimage (s ∩ t) f (λ x₁ hx₁ x₂ hx₂, hs (mem_of_mem_inter_left hx₁) (mem_of_mem_inter_left hx₂))
    = preimage s f hs ∩ preimage t f ht :=
finset.coe_injective (by simp)

@[simp] lemma preimage_union [decidable_eq α] [decidable_eq β] {f : α → β} {s t : finset β} (hst) :
  preimage (s ∪ t) f hst
    = preimage s f (λ x₁ hx₁ x₂ hx₂, hst (mem_union_left _ hx₁) (mem_union_left _ hx₂))
    ∪ preimage t f (λ x₁ hx₁ x₂ hx₂, hst (mem_union_right _ hx₁) (mem_union_right _ hx₂)) :=
finset.coe_injective (by simp)

@[simp] lemma preimage_compl [decidable_eq α] [decidable_eq β] [fintype α] [fintype β]
  {f : α → β} (s : finset β) (hf : function.injective f) :
  preimage sᶜ f (hf.inj_on _) = (preimage s f (hf.inj_on _))ᶜ :=
finset.coe_injective (by simp)

lemma monotone_preimage {f : α → β} (h : injective f) :
  monotone (λ s, preimage s f (h.inj_on _)) :=
λ s t hst x hx, mem_preimage.2 (hst $ mem_preimage.1 hx)

lemma image_subset_iff_subset_preimage [decidable_eq β] {f : α → β} {s : finset α} {t : finset β}
  (hf : set.inj_on f (f ⁻¹' ↑t)) :
  s.image f ⊆ t ↔ s ⊆ t.preimage f hf :=
image_subset_iff.trans $ by simp only [subset_iff, mem_preimage]

lemma map_subset_iff_subset_preimage {f : α ↪ β} {s : finset α} {t : finset β} :
  s.map f ⊆ t ↔ s ⊆ t.preimage f (f.injective.inj_on _) :=
by classical; rw [map_eq_image, image_subset_iff_subset_preimage]

lemma image_preimage [decidable_eq β] (f : α → β) (s : finset β) [Π x, decidable (x ∈ set.range f)]
  (hf : set.inj_on f (f ⁻¹' ↑s)) :
  image f (preimage s f hf) = s.filter (λ x, x ∈ set.range f) :=
finset.coe_inj.1 $ by simp only [coe_image, coe_preimage, coe_filter,
  set.image_preimage_eq_inter_range, set.sep_mem_eq]

lemma image_preimage_of_bij [decidable_eq β] (f : α → β) (s : finset β)
  (hf : set.bij_on f (f ⁻¹' ↑s) ↑s) :
  image f (preimage s f hf.inj_on) = s :=
finset.coe_inj.1 $ by simpa using hf.image_eq

lemma preimage_subset {f : α ↪ β} {s : finset β} {t : finset α} (hs : s ⊆ t.map f) :
  s.preimage f (f.injective.inj_on _) ⊆ t :=
λ x hx, (mem_map' f).1 (hs (mem_preimage.1 hx))

lemma subset_map_iff {f : α ↪ β} {s : finset β} {t : finset α} :
  s ⊆ t.map f ↔ ∃ u ⊆ t, s = u.map f :=
begin
  classical,
  refine ⟨λ h, ⟨_, preimage_subset h, _⟩, _⟩,
  { rw [map_eq_image, image_preimage, filter_true_of_mem (λ x hx, _)],
    exact coe_map_subset_range _ _ (h hx) },
  { rintro ⟨u, hut, rfl⟩,
    exact map_subset_map.2 hut }
end

lemma sigma_preimage_mk {β : α → Type*} [decidable_eq α] (s : finset (Σ a, β a)) (t : finset α) :
  t.sigma (λ a, s.preimage (sigma.mk a) $ sigma_mk_injective.inj_on _) = s.filter (λ a, a.1 ∈ t) :=
by { ext x, simp [and_comm] }

lemma sigma_preimage_mk_of_subset {β : α → Type*} [decidable_eq α] (s : finset (Σ a, β a))
  {t : finset α} (ht : s.image sigma.fst ⊆ t) :
  t.sigma (λ a, s.preimage (sigma.mk a) $ sigma_mk_injective.inj_on _) = s :=
by rw [sigma_preimage_mk, filter_true_of_mem $ image_subset_iff.1 ht]

lemma sigma_image_fst_preimage_mk {β : α → Type*} [decidable_eq α] (s : finset (Σ a, β a)) :
  (s.image sigma.fst).sigma (λ a, s.preimage (sigma.mk a) $ sigma_mk_injective.inj_on _) = s :=
s.sigma_preimage_mk_of_subset (subset.refl _)

end preimage

@[to_additive]
lemma prod_preimage' [comm_monoid β] (f : α → γ) [decidable_pred $ λ x, x ∈ set.range f]
  (s : finset γ) (hf : set.inj_on f (f ⁻¹' ↑s)) (g : γ → β) :
  ∏ x in s.preimage f hf, g (f x) = ∏ x in s.filter (λ x, x ∈ set.range f), g x :=
by haveI := classical.dec_eq γ;
calc ∏ x in preimage s f hf, g (f x) = ∏ x in image f (preimage s f hf), g x :
  eq.symm $ prod_image $ by simpa only [mem_preimage, inj_on] using hf
  ... = ∏ x in s.filter (λ x, x ∈ set.range f), g x : by rw [image_preimage]

@[to_additive]

@[to_additive]
lemma prod_preimage_of_bij [comm_monoid β] (f : α → γ) (s : finset γ)
  (hf : set.bij_on f (f ⁻¹' ↑s) ↑s) (g : γ → β) :
  ∏ x in s.preimage f hf.inj_on, g (f x) = ∏ x in s, g x :=
prod_preimage _ _ hf.inj_on g $ λ x hxs hxf, (hxf $ hf.subset_range hxs).elim

end finset


import algebra.ring
import data.real.basic
import algebra.order.ring
import tactic.linarith

theorem division_by_2 (a : ℕ) : (exists b : ℕ, a=2*b) ∨ (∃ b : ℕ, a=2*b+1) :=
begin
  induction a with d hd,
  left,
  use 0,
  ring,
  cases hd with hEven hOdd,
  cases hEven with b,
  right,
  use b,
  exact congr_arg nat.succ hEven_h,
  left,
  cases hOdd with b,
  use (b+1),
  rw nat.succ_eq_add_one,
  rw hOdd_h,
  ring,
end