/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Robert Y. Lewis, Gabriel Ebner
-/
import data.bool.basic
import meta.rb_map
import tactic.lint.basic

/-!
# Linters about type classes

This file defines several linters checking the correct usage of type classes
and the appropriate definition of instances:

 * `instance_priority` ensures that blanket instances have low priority.
 * `has_nonempty_instances` checks that every type has a `nonempty` instance, an `inhabited`
   instance, or a `unique` instance.
 * `impossible_instance` checks that there are no instances which can never apply.
 * `incorrect_type_class_argument` checks that only type classes are used in
   instance-implicit arguments.
 * `dangerous_instance` checks for instances that generate subproblems with metavariables.
 * `fails_quickly` checks that type class resolution finishes quickly.
 * `class_structure` checks that every `class` is a structure, i.e. `@[class] def` is forbidden.
 * `has_coe_variable` checks that there is no instance of type `has_coe α t`.
 * `inhabited_nonempty` checks whether `[inhabited α]` arguments could be generalized
   to `[nonempty α]`.
 * `decidable_classical` checks propositions for `[decidable_... p]` hypotheses that are not used
   in the statement, and could thus be removed by using `classical` in the proof.
 * `linter.has_coe_to_fun` checks whether necessary `has_coe_to_fun` instances are declared.
 * `linter.check_reducibility` checks whether non-instances with a class as type are reducible.
-/

open tactic

/-- Pretty prints a list of arguments of a declaration. Assumes `l` is a list of argument positions
and binders (or any other element that can be pretty printed).
`l` can be obtained e.g. by applying `list.indexes_values` to a list obtained by
`get_pi_binders`. -/
meta def print_arguments {α} [has_to_tactic_format α] (l : list (ℕ × α)) : tactic string := do
  fs ← l.mmap (λ ⟨n, b⟩, (λ s, to_fmt "argument " ++ to_fmt (n+1) ++ ": " ++ s) <$> pp b),
  return $ fs.to_string_aux tt

/-- checks whether an instance that always applies has priority ≥ 1000. -/
private meta def instance_priority (d : declaration) : tactic (option string) := do
  let nm := d.to_name,
  b ← is_instance nm,
  /- return `none` if `d` is not an instance -/
  if ¬ b then return none else do
  (is_persistent, prio) ← has_attribute `instance nm,
  /- return `none` if `d` is has low priority -/
  if prio < 1000 then return none else do
  (_, tp) ← open_pis d.type,
  tp ← whnf tp transparency.none,
  let (fn, args) := tp.get_app_fn_args,
  cls ← get_decl fn.const_name,
  let (pi_args, _) := cls.type.pi_binders,
  guard (args.length = pi_args.length),
  /- List all the arguments of the class that block type-class inference from firing
    (if they are metavariables). These are all the arguments except instance-arguments and
    out-params. -/
  let relevant_args := (args.zip pi_args).filter_map $ λ⟨e, ⟨_, info, tp⟩⟩,
    if info = binder_info.inst_implicit ∨ tp.get_app_fn.is_constant_of `out_param
    then none else some e,
  let always_applies := relevant_args.all expr.is_local_constant ∧ relevant_args.nodup,
  if always_applies then return $ some "set priority below 1000" else return none

/--
There are places where typeclass arguments are specified with implicit `{}` brackets instead of
the usual `[]` brackets. This is done when the instances can be inferred because they are implicit
arguments to the type of one of the other arguments. When they can be inferred from these other
arguments,  it is faster to use this method than to use type class inference.

For example, when writing lemmas about `(f : α →+* β)`, it is faster to specify the fact that `α`
and `β` are `semiring`s as `{rα : semiring α} {rβ : semiring β}` rather than the usual
`[semiring α] [semiring β]`.
-/
library_note "implicit instance arguments"

/--
Certain instances always apply during type-class resolution. For example, the instance
`add_comm_group.to_add_group {α} [add_comm_group α] : add_group α` applies to all type-class
resolution problems of the form `add_group _`, and type-class inference will then do an
exhaustive search to find a commutative group. These instances take a long time to fail.
Other instances will only apply if the goal has a certain shape. For example
`int.add_group : add_group ℤ` or
`add_group.prod {α β} [add_group α] [add_group β] : add_group (α × β)`. Usually these instances
will fail quickly, and when they apply, they are almost always the desired instance.
For this reason, we want the instances of the second type (that only apply in specific cases) to
always have higher priority than the instances of the first type (that always apply).
See also #1561.

Therefore, if we create an instance that always applies, we set the priority of these instances to
100 (or something similar, which is below the default value of 1000).
-/
library_note "lower instance priority"

/-- A linter object for checking instance priorities of instances that always apply.
This is in the default linter set. -/
@[linter] meta def linter.instance_priority : linter :=
{ test := instance_priority,
  no_errors_found := "All instance priorities are good.",
  errors_found := "DANGEROUS INSTANCE PRIORITIES.
The following instances always apply, and therefore should have a priority < 1000.
If you don't know what priority to choose, use priority 100.
See note [lower instance priority] for instructions to change the priority.",
  auto_decls := tt }

/-- Reports declarations of types that do not have an nonemptiness instance.
A `nonempty`, `inhabited` or `unique` instance suffices, and we prefer a computable `inhabited`
or `unique` instance if possible. -/
private meta def has_nonempty_instance (d : declaration) : tactic (option string) := do
tt ← pure d.is_trusted | pure none,
ff ← has_attribute' `reducible d.to_name | pure none,
ff ← has_attribute' `class d.to_name | pure none,
(_, ty) ← open_pis d.type,
ty ← whnf ty,
if ty = `(Prop) then pure none else do
`(Sort _) ← whnf ty | pure none,
insts ← attribute.get_instances `instance,
insts_tys ← insts.mmap $ λ i, expr.pi_codomain <$> declaration.type <$> get_decl i,
let nonempty_insts := insts_tys.filter
  (λ i, i.app_fn.const_name ∈ [``nonempty, ``inhabited, `unique]),
let nonempty_tys := nonempty_insts.map (λ i, i.app_arg.get_app_fn.const_name),
if d.to_name ∈ nonempty_tys then
  pure none
else
  pure "nonempty/inhabited/unique instance missing"

/-- A linter for missing `nonempty` instances. -/
@[linter]
meta def linter.has_nonempty_instance : linter :=
{ test := has_nonempty_instance,
  auto_decls := ff,
  no_errors_found := "No types have missing nonempty instances.",
  errors_found := "TYPES ARE MISSING NONEMPTY INSTANCES.
The following types should have an associated instance of the class
`nonempty`, or if computably possible `inhabited` or `unique`:",
  is_fast := ff }

attribute [nolint has_nonempty_instance] pempty

/-- Checks whether an instance can never be applied. -/
private meta def impossible_instance (d : declaration) : tactic (option string) := do
  tt ← is_instance d.to_name | return none,
  (binders, _) ← get_pi_binders_nondep d.type,
  let bad_arguments := binders.filter $ λ nb, nb.2.info ≠ binder_info.inst_implicit,
  _ :: _ ← return bad_arguments | return none,
  (λ s, some $ "Impossible to infer " ++ s) <$> print_arguments bad_arguments

/-- A linter object for `impossible_instance`. -/
@[linter] meta def linter.impossible_instance : linter :=
{ test := impossible_instance,
  auto_decls := tt,
  no_errors_found := "All instances are applicable.",
  errors_found := "IMPOSSIBLE INSTANCES FOUND.
These instances have an argument that cannot be found during type-class resolution, and " ++
"therefore can never succeed. Either mark the arguments with square brackets (if it is a " ++
"class), or don't make it an instance." }

/-- Checks whether an instance can never be applied. -/
private meta def incorrect_type_class_argument (d : declaration) : tactic (option string) := do
  (binders, _) ← get_pi_binders d.type,
  let instance_arguments := binders.indexes_values $
    λ b : binder, b.info = binder_info.inst_implicit,
  /- the head of the type should either unfold to a class, or be a local constant.
  A local constant is allowed, because that could be a class when applied to the
  proper arguments. -/
  bad_arguments ← instance_arguments.mfilter (λ ⟨_, b⟩, do
    (_, head) ← open_pis b.type,
    if head.get_app_fn.is_local_constant then return ff else do
    bnot <$> is_class head),
  _ :: _ ← return bad_arguments | return none,
  (λ s, some $ "These are not classes. " ++ s) <$> print_arguments bad_arguments

/-- A linter object for `incorrect_type_class_argument`. -/
@[linter] meta def linter.incorrect_type_class_argument : linter :=
{ test := incorrect_type_class_argument,
  auto_decls := tt,
  no_errors_found := "All declarations have correct type-class arguments.",
  errors_found := "INCORRECT TYPE-CLASS ARGUMENTS.
Some declarations have non-classes between [square brackets]:" }

/-- Checks whether an instance is dangerous: it creates a new type-class problem with metavariable
arguments. -/
private meta def dangerous_instance (d : declaration) : tactic (option string) := do
  tt ← is_instance d.to_name | return none,
  (local_constants, target) ← open_pis d.type,
  let instance_arguments := local_constants.indexes_values $
    λ e : expr, e.local_binding_info = binder_info.inst_implicit,
  let bad_arguments := local_constants.indexes_values $ λ x,
      !target.has_local_constant x &&
      (x.local_binding_info ≠ binder_info.inst_implicit) &&
      instance_arguments.any (λ nb, nb.2.local_type.has_local_constant x),
  let bad_arguments : list (ℕ × binder) := bad_arguments.map $ λ ⟨n, e⟩, ⟨n, e.to_binder⟩,
  _ :: _ ← return bad_arguments | return none,
  (λ s, some $ "The following arguments become metavariables. " ++ s) <$>
    print_arguments bad_arguments

/-- A linter object for `dangerous_instance`. -/
@[linter] meta def linter.dangerous_instance : linter :=
{ test := dangerous_instance,
  no_errors_found := "No dangerous instances.",
  errors_found := "DANGEROUS INSTANCES FOUND.\nThese instances are recursive, and create a new " ++
"type-class problem which will have metavariables.
Possible solution: remove the instance attribute or make it a local instance instead.

Currently this linter does not check whether the metavariables only occur in arguments marked " ++
"with `out_param`, in which case this linter gives a false positive.",
  auto_decls := tt }

/-- Auxilliary definition for `find_nondep` -/
meta def find_nondep_aux : list expr → expr_set → tactic expr_set
| []      r := return r
| (h::hs) r :=
  do type ← infer_type h,
    find_nondep_aux hs $ r.union type.list_local_consts'

/-- Finds all hypotheses that don't occur in the target or other hypotheses. -/
meta def find_nondep : tactic (list expr) := do
  ctx ← local_context,
  tgt ← target,
  lconsts ← find_nondep_aux ctx tgt.list_local_consts',
  return $ ctx.filter $ λ e, !lconsts.contains e

/--
Tests whether type-class inference search will end quickly on certain unsolvable
type-class problems. This is to detect loops or very slow searches, which are problematic
(recall that normal type-class search often creates unsolvable subproblems, which have to fail
quickly for type-class inference to perform well.
We create these type-class problems by taking an instance, and removing the last hypothesis that
doesn't appear in the goal (or a later hypothesis). Note: this argument is necessarily an
instance-implicit argument if it passes the `linter.incorrect_type_class_argument`.
This tactic succeeds if `mk_instance` succeeds quickly or fails quickly with the error
message that it cannot find an instance. It fails if the tactic takes too long, or if any other
error message is raised (usually a maximum depth in the search).
-/
meta def fails_quickly (max_steps : ℕ) (d : declaration) : tactic (option string) := retrieve $ do
  tt ← is_instance d.to_name | return none,
  let e := d.type,
  g ← mk_meta_var e,
  set_goals [g],
  intros,
  l@(_::_) ← find_nondep | return none, -- if all arguments occur in the goal, this instance is ok
  clear l.ilast,
  reset_instance_cache,
  state ← read,
  let state_msg := "\nState:\n" ++ to_string state,
  tgt ← target >>= instantiate_mvars,
  sum.inr msg ← retrieve_or_report_error $ tactic.try_for max_steps $ mk_instance tgt |
    return none, /- it's ok if type-class inference can find an instance with fewer hypotheses.
    This happens a lot for `has_sizeof` and `has_well_founded`, but can also happen if there is a
    noncomputable instance with fewer assumptions. -/
  return $ if "tactic.mk_instance failed to generate instance for".is_prefix_of msg then none else
    some $ (++ state_msg) $
      if msg = "try_for tactic failed, timeout" then "type-class inference timed out" else msg

/--
A linter object for `fails_quickly`.
We currently set the number of steps in the type-class search pretty high.
Some instances take quite some time to fail, and we seem to run against the caching issue in
https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/odd.20repeated.20type.20class.20search
-/
@[linter] meta def linter.fails_quickly : linter :=
{ test := fails_quickly 30000,
  auto_decls := tt,
  no_errors_found := "No type-class searches timed out.",
  errors_found := "TYPE CLASS SEARCHES TIMED OUT.
The following instances are part of a loop, or an excessively long search.
It is common that the loop occurs in a different class than the one flagged below,
but usually an instance that is part of the loop is also flagged.
To debug:
(1) run `scripts/mk_all.sh` and create a file with `import all` and
`set_option trace.class_instances true`
(2) Recreate the state shown in the error message. You can do this easily by copying the type of
the instance (the output of `#check @my_instance`), turning this into an example and removing the
last argument in square brackets. Prove the example using `by apply_instance`.
For example, if `additive.topological_add_group` raises an error, run
```
example {G : Type*} [topological_space G] [group G] : topological_add_group (additive G) :=
by apply_instance
```
(3) What error do you get?
(3a) If the error is \"tactic.mk_instance failed to generate instance\",
there might be nothing wrong. But it might take unreasonably long for the type-class inference to
fail. Check the trace to see if type-class inference takes any unnecessary long unexpected turns.
If not, feel free to increase the value in the definition of the linter `fails_quickly`.
(3b) If the error is \"maximum class-instance resolution depth has been reached\" there is almost
certainly a loop in the type-class inference. Find which instance causes the type-class inference to
go astray, and fix that instance.",
  is_fast := ff }

/-- Checks that all uses of the `@[class]` attribute apply to structures or inductive types.
  This is future-proofing for lean 4, which no longer supports `@[class] def`. -/
private meta def class_structure (n : name) : tactic (option string) := do
  is_class ← has_attribute' `class n,
  if is_class then do
    env ← get_env,
    pure $ if env.is_inductive n then none else
      "is a non-structure or inductive type marked @[class]"
  else pure none

/-- A linter object for `class_structure`. -/
@[linter] meta def linter.class_structure : linter :=
{ test := λ d, class_structure d.to_name,
  auto_decls := tt,
  no_errors_found := "All classes are structures.",
  errors_found := "USE OF @[class] def IS DISALLOWED:" }

/--
Tests whether there is no instance of type `has_coe α t` where `α` is a variable,
or `has_coe t α` where `α` does not occur in `t`.
See note [use has_coe_t].
-/
private meta def has_coe_variable (d : declaration) : tactic (option string) := do
tt ← is_instance d.to_name | return none,
`(has_coe %%a %%b) ← return d.type.pi_codomain | return none,
if a.is_var then
  return $ some $ "illegal instance, first argument is variable"
else if b.is_var ∧ ¬ b.occurs a then
  return $ some $ "illegal instance, second argument is variable not occurring in first argument"
else
  return none

/-- A linter object for `has_coe_variable`. -/
@[linter] meta def linter.has_coe_variable : linter :=
{ test := has_coe_variable,
  auto_decls := tt,
  no_errors_found := "No invalid `has_coe` instances.",
  errors_found := "INVALID `has_coe` INSTANCES.
Make the following declarations instances of the class `has_coe_t` instead of `has_coe`." }

/-- Checks whether a declaration is prop-valued and takes an `inhabited _` argument that is unused
elsewhere in the type. In this case, that argument can be replaced with `nonempty _`. -/
private meta def inhabited_nonempty (d : declaration) : tactic (option string) :=
do tt ← is_prop d.type | return none,
   (binders, _) ← get_pi_binders_nondep d.type,
   let inhd_binders := binders.filter $ λ pr, pr.2.type.is_app_of `inhabited,
   if inhd_binders.length = 0 then return none
   else (λ s, some $ "The following `inhabited` instances should be `nonempty`. " ++ s) <$>
      print_arguments inhd_binders

/-- A linter object for `inhabited_nonempty`. -/
@[linter] meta def linter.inhabited_nonempty : linter :=
{ test := inhabited_nonempty,
  auto_decls := ff,
  no_errors_found := "No uses of `inhabited` arguments should be replaced with `nonempty`.",
  errors_found := "USES OF `inhabited` SHOULD BE REPLACED WITH `nonempty`." }

/-- Checks whether a declaration is `Prop`-valued and takes a `decidable* _`
hypothesis that is unused elsewhere in the type.
In this case, that hypothesis can be replaced with `classical` in the proof.
Theorems in the `decidable` namespace are exempt from the check. -/
private meta def decidable_classical (d : declaration) : tactic (option string) :=
do tt ← is_prop d.type | return none,
   ff ← pure $ (`decidable).is_prefix_of d.to_name | return none,
   (binders, _) ← get_pi_binders_nondep d.type,
   let deceq_binders := binders.filter $ λ pr, pr.2.type.is_app_of `decidable_eq
     ∨ pr.2.type.is_app_of `decidable_pred ∨ pr.2.type.is_app_of `decidable_rel
     ∨ pr.2.type.is_app_of `decidable,
   if deceq_binders.length = 0 then return none
   else (λ s, some $ "The following `decidable` hypotheses should be replaced with
                      `classical` in the proof. " ++ s) <$>
      print_arguments deceq_binders

/-- A linter object for `decidable_classical`. -/
@[linter] meta def linter.decidable_classical : linter :=
{ test := decidable_classical,
  auto_decls := ff,
  no_errors_found := "No uses of `decidable` arguments should be replaced with `classical`.",
  errors_found := "USES OF `decidable` SHOULD BE REPLACED WITH `classical` IN THE PROOF." }

/- The file `logic/basic.lean` emphasizes the differences between what holds under classical
and non-classical logic. It makes little sense to make all these lemmas classical, so we add them
to the list of lemmas which are not checked by the linter `decidable_classical`. -/
attribute [nolint decidable_classical] dec_em dec_em' not.decidable_imp_symm

/-- Checks whether a declaration is `Prop`-valued and takes a `fintype _`
hypothesis that is unused elsewhere in the type.
In this case, that hypothesis can be replaced with `casesI nonempty_fintype _` in the proof. -/
meta def linter.fintype_finite_fun (d : declaration) : tactic (option string) :=
do tt ← is_prop d.type | return none,
   (binders, _) ← get_pi_binders_nondep d.type,
   let fintype_binders := binders.filter $ λ pr, pr.2.type.is_app_of `fintype,
   if fintype_binders.length = 0 then return none
   else (λ s, some $ "The following `fintype` hypotheses should be replaced with
                      `casesI nonempty_fintype _` in the proof. " ++ s) <$>
      print_arguments fintype_binders

/-- A linter object for `fintype` vs `finite`. -/
@[linter] meta def linter.fintype_finite : linter :=
{ test := linter.fintype_finite_fun,
  auto_decls := ff,
  no_errors_found :=
    "No uses of `fintype` arguments should be replaced with `casesI nonempty_fintype _`.",
  errors_found :=
    "USES OF `fintype` SHOULD BE REPLACED WITH `casesI nonempty_fintype _` IN THE PROOF." }

private meta def has_coe_to_fun_linter (d : declaration) : tactic (option string) :=
retrieve $ do
tt ← return d.is_trusted | pure none,
mk_meta_var d.type >>= set_goals ∘ pure,
args ← unfreezing intros,
expr.sort _ ← target | pure none,
let ty : expr := (expr.const d.to_name d.univ_levels).mk_app args,
some coe_fn_inst ←
  try_core $ to_expr ``(_root_.has_coe_to_fun %%ty _) >>= mk_instance | pure none,
set_bool_option `pp.all true,
some trans_inst@(expr.app (expr.app _ trans_inst_1) trans_inst_2) ←
  try_core $ to_expr ``(@_root_.coe_fn_trans %%ty _ _ _ _) | pure none,
tt ← succeeds $ unify trans_inst coe_fn_inst transparency.reducible | pure none,
set_bool_option `pp.all true,
trans_inst_1 ← pp trans_inst_1,
trans_inst_2 ← pp trans_inst_2,
pure $ format.to_string $
  "`has_coe_to_fun` instance is definitionally equal to a transitive instance composed of: " ++
  trans_inst_1.group.indent 2 ++
  format.line ++ "and" ++
  trans_inst_2.group.indent 2

/-- Linter that checks whether `has_coe_to_fun` instances comply with Note [function coercion]. -/
@[linter] meta def linter.has_coe_to_fun : linter :=
{ test := has_coe_to_fun_linter,
  auto_decls := tt,
  no_errors_found := "has_coe_to_fun is used correctly",
  errors_found := "INVALID/MISSING `has_coe_to_fun` instances.
You should add a `has_coe_to_fun` instance for the following types.
See Note [function coercion]." }

/--
Checks whether an instance contains a semireducible non-instance with a class as
type in its value. We add some restrictions to get not too many false positives:
* We only consider classes with an `add` or `mul` field, since those classes are most likely to
  occur as a field to another class, and be an extension of another class.
* We only consider instances of type-valued classes and non-instances that are definitions.
* We currently ignore declarations `foo` that have a `foo._main` declaration. We could look inside,
or at the generated equation lemmas, but it's unlikely that there are many problematic instances
defined using the equation compiler.
-/
meta def check_reducible_non_instances (d : declaration) : tactic (option string) := do
  tt ← is_instance d.to_name | return none,
  ff ← is_prop d.type | return none,
  env ← get_env,
  -- We only check if the class of the instance contains an `add` or a `mul` field.
  let cls := d.type.pi_codomain.get_app_fn.const_name,
  some constrs ← return $ env.structure_fields cls | return none,
  tt ← return $ constrs.mem `add || constrs.mem `mul | return none,
  l ← d.value.list_constant.mfilter $ λ nm, do
  { d ← env.get nm,
    ff ← is_instance nm | return ff,
    tt ← is_class d.type | return ff,
    tt ← return d.is_definition | return ff,
    -- We only check if the class of the non-instance contains an `add` or a `mul` field.
    let cls := d.type.pi_codomain.get_app_fn.const_name,
    some constrs ← return $ env.structure_fields cls | return ff,
    tt ← return $ constrs.mem `add || constrs.mem `mul | return ff,
    ff ← has_attribute' `reducible nm | return ff,
    return tt },
  if l.empty then return none else
  -- we currently ignore declarations that have a `foo._main` declaration.
  if l.to_list = [d.to_name ++ `_main] then return none else
    return $ some $ "This instance contains the declarations " ++ to_string l.to_list ++
      ", which are semireducible non-instances."

/-- A linter that checks whether an instance contains a semireducible non-instance. -/
@[linter]
meta def linter.check_reducibility : linter :=
{ test := check_reducible_non_instances,
  auto_decls := ff,
  no_errors_found :=
    "All non-instances are reducible.",
  errors_found := "THE FOLLOWING INSTANCES MIGHT NOT REDUCE.
These instances contain one or more declarations that are not instances and are also not marked
`@[reducible]`. This means that type-class inference cannot unfold these declarations, " ++
"which might mean that type-class inference cannot infer that two instances are definitionally " ++
"equal. This can cause unexpected errors when this class occurs " ++
"as an *argument* to a type-class problem. See note [reducible non-instances].",
  is_fast := tt }


import data.multiset data.equiv.basic data.nat.basic group_theory.perm

open equiv.perm equiv list

variables {α : Type*} {β : Type*} [decidable_eq α]

def thing : list α → list (perm α)
| []       := [1]
| (a :: l) := thing l ++ l.bind (λ b, (thing l).map (λ f, swap a b * f))

@[simp] lemma thing_nil : thing ([] : list α) = [1] := rfl

lemma length_thing : ∀ l : list α, length (thing l) = l.length.fact
| []       := rfl
| (a :: l) := by rw [length_cons, nat.fact_succ];
  simp [thing, length_bind, length_thing, function.comp, nat.succ_mul]

lemma mem_thing : ∀ (l : list α) (f : perm α) (hl : l.nodup) (h : ∀ x, f x ≠ x → x ∈ l), f ∈ thing l
| []     f hl h := list.mem_singleton.2 $ equiv.ext _ _$ λ x, by simp [imp_false, *] at *
| (a::l) f hl h :=
if hfa : f a = a
then
  mem_append_left _ $ mem_thing _ _ (list.nodup_of_nodup_cons hl)
    (λ x hx, mem_of_ne_of_mem (λ h, by rw h at hx; exact hx hfa) (h x hx))
else
have hfa' : f (f a) ≠ f a, from mt (λ h, f.bijective.1 h) hfa,
have ∀ (x : α), (swap a (f a) * f) x ≠ x → x ∈ l,
  from λ x hx, have hxa : x ≠ a, from λ h, by simpa [h, mul_apply] using hx,
    have hfxa : f x ≠ f a, from mt (λ h, f.bijective.1 h) hxa,
    list.mem_of_ne_of_mem hxa
      (h x (λ h, by simp [h, mul_apply, swap_apply_def] at hx; split_ifs at hx; cc)),
suffices f ∈ thing l ∨ ∃ (b : α), b ∈ l ∧ ∃ g : perm α, g ∈ thing l ∧ swap a b * g = f,
  by simpa [thing],
(@or_iff_not_imp_left _ _ (classical.prop_decidable _)).2
  (λ hfl, ⟨f a,
    if hffa : f (f a) = a then mem_of_ne_of_mem hfa (h _ (mt (λ h, f.bijective.1 h) hfa))
      else this _ $ by simp [mul_apply, swap_apply_def]; split_ifs; cc,
    ⟨swap a (f a) * f, mem_thing _ _ (list.nodup_of_nodup_cons hl) this,
      by rw [← mul_assoc, mul_def (swap a (f a)) (swap a (f a)), swap_swap, ← one_def, one_mul]⟩⟩)

lemma mem_thing' : ∀ (l : list α) (f : perm α), f ∈ thing l → ∀ x, f x ≠ x → x ∈ l
| []     f h := have f = 1 := by simpa [thing] using h, by rw this; simp
| (a::l) f h :=
(mem_append.1 h).elim
  (λ h x hx, mem_cons_of_mem _ (mem_thing' l f h x hx))
  (λ h x hx,
    let ⟨y, hy, hy'⟩ := mem_bind.1 h in
    let ⟨g, hg₁, hg₂⟩ := mem_map.1 hy' in
    if hxa : x = a then by simp [hxa]
    else if hxy : x = y then mem_cons_of_mem _ $ by rwa hxy
    else mem_cons_of_mem _ $
    mem_thing' l g hg₁ _ $
      by rw [eq_inv_mul_iff_mul_eq.2 hg₂, mul_apply, swap_inv, swap_apply_def];
        split_ifs; cc)

lemma nodup_thing : ∀ (l : list α) (hl : l.nodup), (thing l).nodup
| []     hl := by simp [thing]
| (a::l) hl :=
have hl' : l.nodup, from nodup_of_nodup_cons hl,
have hln' : (thing l).nodup, from nodup_thing _ hl',
have hmeml : ∀ {f : perm α}, f ∈ thing l → f a = a,
  from λ f hf, not_not.1 (mt (mem_thing' l f hf a) (nodup_cons.1 hl).1),
by rw [thing, list.nodup_append, list.nodup_bind, pairwise_iff_nth_le]; exact
⟨hln', ⟨λ _ _, nodup_map (λ _ _, (mul_left_inj _).1) hln',
  λ i j hj hij x hx₁ hx₂,
    let ⟨f, hf⟩ := mem_map.1 hx₁ in
    let ⟨g, hg⟩ := mem_map.1 hx₂ in
    have hix : x a = nth_le l i (lt_trans hij hj),
      by rw [← hf.2, mul_apply, hmeml hf.1, swap_apply_left],
    have hiy : x a = nth_le l j hj,
      by rw [← hg.2, mul_apply, hmeml hg.1, swap_apply_left],
    absurd (hf.2.trans (hg.2.symm)) $
      λ h, ne_of_lt hij $ nodup_iff_nth_le_inj.1 hl' i j (lt_trans hij hj) hj $
        by rw [← hix, hiy]⟩,
  λ f hf₁ hf₂,
    let ⟨x, hx, hx'⟩ := mem_bind.1 hf₂ in
    let ⟨g, hg⟩ := mem_map.1 hx' in
    have hgxa : g⁻¹ x = a, from f.bijective.1 $
      by rw [hmeml hf₁, ← hg.2]; simp,
    have hxa : x ≠ a, from λ h, (list.nodup_cons.1 hl).1 (h ▸ hx),
    (list.nodup_cons.1 hl).1 $
      hgxa ▸ mem_thing' _ _ hg.1 _ (by rwa [apply_inv_self, hgxa])⟩

def perm_fintype_aux [decidable_eq (perm α)] {s : multiset α} :
  (∀ x, x ∈ s) → s.nodup → fintype (perm α) :=
quotient.rec_on_subsingleton s (λ l hl hln, ⟨⟨thing l, nodup_thing _ hln⟩,
  (λ x, mem_thing _ _ hln (λ _ _, (hl _)))⟩)

instance perm.fintype [fintype α] : fintype (perm α) := perm_fintype_aux finset.mem_univ finset.univ.2

lemma card_perm [fintype α] : fintype.card (perm α) = (fintype.card α).fact :=
quotient.induction_on (@finset.univ α _).1 begin end

#exit

lemma thing_cons (m : multiset α) (a : α) :
  thing (a :: m) = thing m + m.bind (λ b, (thing m).map (λ f, swap a b * f)) :=
by simp [thing]

lemma mem_perm (m : multiset α) (f : perm α) : (∀ x, f x ≠ x → x ∈ m) → f ∈ thing m :=
multiset.induction_on m
  (λ h, mem_singleton.2 $ equiv.ext _ _ $ λ x, not_not.1 $ by simpa [-not_not, not_mem_zero] using h x)
  $ λ a s ih h, begin
    simp [thing_cons],

  end

lemma card_perm (m : multiset α) : (thing m).card = nat.fact m.card :=
multiset.induction_on m rfl (λ a s ih, by rw [card_cons, nat.fact_succ];
  simp [thing_cons, card_add, ih, card_bind, mul_comm, nat.mul_succ])

def perm.cons (e : α ≃ β) (m : multiset α) (a : α) (b : β) (f : α ≃ β) : α ≃ β :=
(swap a (e.symm b)).trans f

def list_to_function : Π (l₁ : list α) (l₂ : list β), l₁.length = l₂.length → Π a ∈ l₁, β
| []      l₂      h₁ a h₂ := absurd h₂ (list.not_mem_nil _)
| (b::l₁) []      h₁ a h₂ := absurd h₁ (nat.succ_ne_zero _)
| (b::l₁) (c::l₂) h₁ a h₂ := if h : a = b then c
  else list_to_function l₁ l₂ (nat.succ_inj h₁) a (list.mem_of_ne_of_mem h h₂)

open list nat

def list_to_perm : Π (l₁ : list α) (l₂ : list β), l₁.length = l₂.length →
  {a // a ∈ l₁} ≃ {b // b ∈ l₂}
| []      []      h := ⟨λ a, (not_mem_nil _ a.2).elim, λ b, (not_mem_nil _ b.2).elim,
  λ a, (not_mem_nil _ a.2).elim, λ b, (not_mem_nil _ b.2).elim⟩
| []      (b::l₂) h := (succ_ne_zero _ h.symm).elim
| (a::l₁) []      h := (succ_ne_zero _ h).elim
| (a::l₁) (b::l₂) h :=
let f := list_to_perm l₁ l₂ (succ_inj h) in
{ to_fun := λ x, if h : x.1 = a then ⟨b, list.mem_cons_self _ _⟩
            else ⟨(f ⟨x, mem_of_ne_of_mem h x.2⟩).1, mem_cons_of_mem _ begin end⟩  }

def multiset.perm (m : multiset α) (t : multiset β) : multiset (α ≃ β) :=
multiset.rec_on m (e :: 0)
  (λ a m ih, m.bind (λ b, ih.map (λ f, begin end)))
  (λ x y s t, heq_of_eq begin
    simp [multiset.map_bind, bind_bind, swap_comm],
    rw [bind_map_comm],

  end)


import deduction.deduction_monadic data.set.basic
open deduction_basic

namespace MPPC_defn

    inductive MPPC_Form : Type
    | top : MPPC_Form
    | var : ℕ → MPPC_Form
    | and : MPPC_Form → MPPC_Form → MPPC_Form
    | impl : MPPC_Form → MPPC_Form → MPPC_Form
    | diamond : MPPC_Form → MPPC_Form

    @[reducible] def MPPC_Hyp : Type := set (MPPC_Form)

    instance : has_union MPPC_Hyp := infer_instance
    instance : has_mem MPPC_Form MPPC_Hyp := infer_instance
    instance : has_insert MPPC_Form MPPC_Hyp := infer_instance
    instance : has_emptyc MPPC_Hyp := infer_instance

    inductive isModal : MPPC_Hyp → Prop
    | ModalEmpty : isModal ∅
    | ModalInsert : ∀ (Φ : MPPC_Hyp) (φ : MPPC_Form),
        isModal Φ → isModal (insert (MPPC_Form.diamond φ) Φ)

    inductive MPPC_derives : MPPC_Hyp → MPPC_Form → Prop
    | hyp {Φ : MPPC_Hyp} {φ : MPPC_Form}
        : (φ ∈ Φ) →  MPPC_derives Φ φ
    | truth {Φ}
        : MPPC_derives Φ MPPC_Form.top
    | and_intro {Φ} {φ ψ : MPPC_Form}
        : MPPC_derives Φ φ → MPPC_derives Φ ψ → MPPC_derives Φ (MPPC_Form.and φ ψ)
    | and_eliml {Φ} {φ ψ : MPPC_Form}
        : MPPC_derives Φ (MPPC_Form.and φ ψ) → MPPC_derives Φ φ
    | and_elimr {Φ} {φ ψ : MPPC_Form}
        : MPPC_derives Φ (MPPC_Form.and φ ψ) → MPPC_derives Φ ψ
    | impl_intro {Φ : MPPC_Hyp} (φ : MPPC_Form) {ψ : MPPC_Form}
        : MPPC_derives (insert φ Φ) ψ → MPPC_derives Φ (MPPC_Form.impl φ ψ)
    | impl_elim {Φ : MPPC_Hyp} (φ : MPPC_Form) {ψ : MPPC_Form}
        : MPPC_derives Φ (MPPC_Form.impl φ ψ) → MPPC_derives Φ φ → MPPC_derives Φ ψ
    | weak {Φ Ψ : MPPC_Hyp} {φ : MPPC_Form}
        : MPPC_derives Φ φ → MPPC_derives (Φ ∪ Ψ) φ
    | dmap {Φ : MPPC_Hyp}{φ ψ : MPPC_Form}
        : MPPC_derives (insert φ Φ) ψ → MPPC_derives (insert (MPPC_Form.diamond φ) Φ) (MPPC_Form.diamond ψ)
    | dpure {Φ : MPPC_Hyp} {φ : MPPC_Form}
        : MPPC_derives Φ φ → MPPC_derives Φ (MPPC_Form.diamond φ)
    | djoin {Φ : MPPC_Hyp} {φ : MPPC_Form}
        : MPPC_derives Φ (MPPC_Form.diamond(MPPC_Form.diamond φ)) → MPPC_derives Φ (MPPC_Form.diamond φ)
    open MPPC_derives

notation (name:= MPPC.diamond) `◇`:81 φ := MPPC_Form.diamond φ

end MPPC_defn

namespace MPPC_has_derives

    open MPPC_defn
    open MPPC_defn.MPPC_derives
    open deduction_basic
    open deduction_cart
    open deduction_monadic
    open MPPC_defn.MPPC_Form

    instance MPPC_hasHyp : has_Hyp MPPC_Form :=
      { Hyp := MPPC_Hyp }

    instance MPPC_singleton : has_singleton MPPC_Form MPPC_Hyp :=
      deduction_basic.singleHyp
    @[simp]
    lemma same_singles : ∀ φ : MPPC_Form,
        MPPC_has_derives.MPPC_singleton.singleton φ = set.has_singleton.singleton φ :=
    begin
      assume φ,
      dsimp[MPPC_has_derives.MPPC_singleton,deduction_basic.singleHyp],
      rw set.is_lawful_singleton.insert_emptyc_eq,
    end

    lemma single_union {Φ : MPPC_Hyp} {φ : MPPC_Form}
        : insert φ Φ = {φ} ∪ Φ := by simp

    instance MPPC_Der : has_struct_derives MPPC_Form :=
    {
      derives := MPPC_derives,
      derive_Trans :=
        begin
          assume Φ ψ θ hφψ hψθ,
          have helper : MPPC_derives Φ (MPPC_Form.impl ψ θ),
            apply impl_intro,
            rw single_union,
            apply weak,
            exact hψθ,
          apply impl_elim ψ,
          exact helper,
          exact hφψ,
        end,
      inInsert := set.mem_insert,
      hyp := @hyp,
      weak1 :=
        begin
          assume Φ φ ψ h,
          rw single_union,
          rw set.union_comm,
          apply weak,
          exact h,
        end,
    }

    instance MPPC_top : deduction_cart.has_ltop MPPC_Form :=
    {
      top := MPPC_Form.top,
      truth := @truth,
    }
    instance MPPC_and : deduction_cart.has_and MPPC_Form :=
    {
      and := MPPC_Form.and,
      and_intro := @and_intro,
      and_eliml := @and_eliml,
      and_elimr := @and_elimr,
    }
    instance MPPC_impl : deduction_cart.has_impl MPPC_Form :=
    {
      impl := MPPC_Form.impl,
      impl_intro := @impl_intro,
      impl_elim := @impl_elim,
    }
    instance MPPC_diamond : deduction_monadic.has_diamond MPPC_Form :=
    {
      diamond := MPPC_Form.diamond,
      dmap := @dmap,
      dpure := @dpure,
      djoin := @djoin,
    }

end MPPC_has_derives


/-
Copyright (c) 2018 Sean Leather. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sean Leather, Mario Carneiro
-/
import data.list.alist
import data.finset.basic
import data.part
/-!
# Finite maps over `multiset`
-/

universes u v w
open list
variables {α : Type u} {β : α → Type v}

/-! ### multisets of sigma types-/

namespace multiset

/-- Multiset of keys of an association multiset. -/
def keys (s : multiset (sigma β)) : multiset α :=
s.map sigma.fst

@[simp] theorem coe_keys {l : list (sigma β)} :
  keys (l : multiset (sigma β)) = (l.keys : multiset α) :=
rfl

/-- `nodupkeys s` means that `s` has no duplicate keys. -/
def nodupkeys (s : multiset (sigma β)) : Prop :=
quot.lift_on s list.nodupkeys (λ s t p, propext $ perm_nodupkeys p)

@[simp] theorem coe_nodupkeys {l : list (sigma β)} : @nodupkeys α β l ↔ l.nodupkeys := iff.rfl

end multiset

/-! ### finmap -/

/-- `finmap β` is the type of finite maps over a multiset. It is effectively
  a quotient of `alist β` by permutation of the underlying list. -/
structure finmap (β : α → Type v) : Type (max u v) :=
(entries : multiset (sigma β))
(nodupkeys : entries.nodupkeys)

/-- The quotient map from `alist` to `finmap`. -/
def alist.to_finmap (s : alist β) : finmap β := ⟨s.entries, s.nodupkeys⟩

local notation `⟦`:max a `⟧`:0 := alist.to_finmap a

theorem alist.to_finmap_eq {s₁ s₂ : alist β} :
  ⟦s₁⟧ = ⟦s₂⟧ ↔ s₁.entries ~ s₂.entries :=
by cases s₁; cases s₂; simp [alist.to_finmap]

@[simp] theorem alist.to_finmap_entries (s : alist β) : ⟦s⟧.entries = s.entries := rfl

/-- Given `l : list (sigma β)`, create a term of type `finmap β` by removing
entries with duplicate keys. -/
def list.to_finmap [decidable_eq α] (s : list (sigma β)) : finmap β := s.to_alist.to_finmap

namespace finmap
open alist

/-! ### lifting from alist -/

/-- Lift a permutation-respecting function on `alist` to `finmap`. -/
@[elab_as_eliminator] def lift_on
  {γ} (s : finmap β) (f : alist β → γ)
  (H : ∀ a b : alist β, a.entries ~ b.entries → f a = f b) : γ :=
begin
  refine (quotient.lift_on s.1 (λ l, (⟨_, λ nd, f ⟨l, nd⟩⟩ : part γ))
    (λ l₁ l₂ p, part.ext' (perm_nodupkeys p) _) : part γ).get _,
  { exact λ h₁ h₂, H _ _ (by exact p) },
  { have := s.nodupkeys, rcases s.entries with ⟨l⟩, exact id }
end

@[simp] theorem lift_on_to_finmap {γ} (s : alist β) (f : alist β → γ) (H) :
  lift_on ⟦s⟧ f H = f s := by cases s; refl

/-- Lift a permutation-respecting function on 2 `alist`s to 2 `finmap`s. -/
@[elab_as_eliminator] def lift_on₂
  {γ} (s₁ s₂ : finmap β) (f : alist β → alist β → γ)
  (H : ∀ a₁ b₁ a₂ b₂ : alist β, a₁.entries ~ a₂.entries → b₁.entries ~ b₂.entries →
    f a₁ b₁ = f a₂ b₂) : γ :=
lift_on s₁
  (λ l₁, lift_on s₂ (f l₁) (λ b₁ b₂ p, H _ _ _ _ (perm.refl _) p))
  (λ a₁ a₂ p, have H' : f a₁ = f a₂ := funext (λ _, H _ _ _ _ p (perm.refl _)), by simp only [H'])

@[simp] theorem lift_on₂_to_finmap {γ} (s₁ s₂ : alist β) (f : alist β → alist β → γ) (H) :
  lift_on₂ ⟦s₁⟧ ⟦s₂⟧ f H = f s₁ s₂ :=
by cases s₁; cases s₂; refl

/-! ### induction -/

@[elab_as_eliminator] theorem induction_on
  {C : finmap β → Prop} (s : finmap β) (H : ∀ (a : alist β), C ⟦a⟧) : C s :=
by rcases s with ⟨⟨a⟩, h⟩; exact H ⟨a, h⟩

@[elab_as_eliminator] theorem induction_on₂ {C : finmap β → finmap β → Prop}
  (s₁ s₂ : finmap β) (H : ∀ (a₁ a₂ : alist β), C ⟦a₁⟧ ⟦a₂⟧) : C s₁ s₂ :=
induction_on s₁ $ λ l₁, induction_on s₂ $ λ l₂, H l₁ l₂

@[elab_as_eliminator] theorem induction_on₃ {C : finmap β →  finmap β → finmap β → Prop}
  (s₁ s₂ s₃ : finmap β) (H : ∀ (a₁ a₂ a₃ : alist β), C ⟦a₁⟧ ⟦a₂⟧ ⟦a₃⟧) : C s₁ s₂ s₃ :=
induction_on₂ s₁ s₂ $ λ l₁ l₂, induction_on s₃ $ λ l₃, H l₁ l₂ l₃

/-! ### extensionality -/

@[ext] theorem ext : ∀ {s t : finmap β}, s.entries = t.entries → s = t
| ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ H := by congr'

@[simp] theorem ext_iff {s t : finmap β} : s.entries = t.entries ↔ s = t :=
⟨ext, congr_arg _⟩

/-! ### mem -/

/-- The predicate `a ∈ s` means that `s` has a value associated to the key `a`. -/
instance : has_mem α (finmap β) := ⟨λ a s, a ∈ s.entries.keys⟩

theorem mem_def {a : α} {s : finmap β} :
  a ∈ s ↔ a ∈ s.entries.keys := iff.rfl

@[simp] theorem mem_to_finmap {a : α} {s : alist β} :
  a ∈ ⟦s⟧ ↔ a ∈ s := iff.rfl

/-! ### keys -/

/-- The set of keys of a finite map. -/
def keys (s : finmap β) : finset α :=
⟨s.entries.keys, induction_on s keys_nodup⟩

@[simp] theorem keys_val (s : alist β) : (keys ⟦s⟧).val = s.keys := rfl

@[simp] theorem keys_ext {s₁ s₂ : alist β} :
  keys ⟦s₁⟧ = keys ⟦s₂⟧ ↔ s₁.keys ~ s₂.keys :=
by simp [keys, alist.keys]

theorem mem_keys {a : α} {s : finmap β} : a ∈ s.keys ↔ a ∈ s :=
induction_on s $ λ s, alist.mem_keys

/-! ### empty -/

/-- The empty map. -/
instance : has_emptyc (finmap β) := ⟨⟨0, nodupkeys_nil⟩⟩

instance : inhabited (finmap β) := ⟨∅⟩

@[simp] theorem empty_to_finmap : (⟦∅⟧ : finmap β) = ∅ := rfl

@[simp] theorem to_finmap_nil [decidable_eq α] : ([].to_finmap : finmap β) = ∅ := rfl

theorem not_mem_empty {a : α} : a ∉ (∅ : finmap β) :=
multiset.not_mem_zero a

@[simp] theorem keys_empty : (∅ : finmap β).keys = ∅ := rfl

/-! ### singleton -/

/-- The singleton map. -/
def singleton (a : α) (b : β a) : finmap β := ⟦alist.singleton a b⟧

@[simp] theorem keys_singleton (a : α) (b : β a) :
  (singleton a b).keys = {a} := rfl

@[simp] lemma mem_singleton (x y : α) (b : β y) : x ∈ singleton y b ↔ x = y :=
by simp only [singleton]; erw [mem_cons_eq, mem_nil_iff, or_false]

section

variables [decidable_eq α]

instance has_decidable_eq [∀ a, decidable_eq (β a)] : decidable_eq (finmap β)
| s₁ s₂ := decidable_of_iff _ ext_iff

/-! ### lookup -/

/-- Look up the value associated to a key in a map. -/
def lookup (a : α) (s : finmap β) : option (β a) :=
lift_on s (lookup a) (λ s t, perm_lookup)

@[simp] theorem lookup_to_finmap (a : α) (s : alist β) :
  lookup a ⟦s⟧ = s.lookup a := rfl

@[simp] theorem lookup_list_to_finmap (a : α) (s : list (sigma β)) :
  lookup a s.to_finmap = s.lookup a :=
by rw [list.to_finmap, lookup_to_finmap, lookup_to_alist]

@[simp] theorem lookup_empty (a) : lookup a (∅ : finmap β) = none :=
rfl

theorem lookup_is_some {a : α} {s : finmap β} :
  (s.lookup a).is_some ↔ a ∈ s :=
induction_on s $ λ s, alist.lookup_is_some

theorem lookup_eq_none {a} {s : finmap β} : lookup a s = none ↔ a ∉ s :=
induction_on s $ λ s, alist.lookup_eq_none

@[simp] lemma lookup_singleton_eq {a : α} {b : β a} : (singleton a b).lookup a = some b :=
by rw [singleton, lookup_to_finmap, alist.singleton, alist.lookup, lookup_cons_eq]

instance (a : α) (s : finmap β) : decidable (a ∈ s) :=
decidable_of_iff _ lookup_is_some

lemma mem_iff {a : α} {s : finmap β} : a ∈ s ↔ ∃ b, s.lookup a = some b :=
induction_on s $ λ s,
iff.trans list.mem_keys $ exists_congr $ λ b,
(mem_lookup_iff s.nodupkeys).symm

lemma mem_of_lookup_eq_some {a : α} {b : β a} {s : finmap β} (h : s.lookup a = some b) : a ∈ s :=
mem_iff.mpr ⟨_, h⟩

theorem ext_lookup {s₁ s₂ : finmap β} : (∀ x, s₁.lookup x = s₂.lookup x) → s₁ = s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂ h,
begin
  simp only [alist.lookup, lookup_to_finmap] at h,
  rw [alist.to_finmap_eq],
  apply lookup_ext s₁.nodupkeys s₂.nodupkeys,
  intros x y,
  rw h,
end

/-! ### replace -/

/-- Replace a key with a given value in a finite map.
  If the key is not present it does nothing. -/
def replace (a : α) (b : β a) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦replace a b t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_replace p

@[simp] theorem replace_to_finmap (a : α) (b : β a) (s : alist β) :
  replace a b ⟦s⟧ = ⟦s.replace a b⟧ := by simp [replace]

@[simp] theorem keys_replace (a : α) (b : β a) (s : finmap β) :
  (replace a b s).keys = s.keys :=
induction_on s $ λ s, by simp

@[simp] theorem mem_replace {a a' : α} {b : β a} {s : finmap β} :
  a' ∈ replace a b s ↔ a' ∈ s :=
induction_on s $ λ s, by simp

end

/-! ### foldl -/

/-- Fold a commutative function over the key-value pairs in the map -/
def foldl {δ : Type w} (f : δ → Π a, β a → δ)
  (H : ∀ d a₁ b₁ a₂ b₂, f (f d a₁ b₁) a₂ b₂ = f (f d a₂ b₂) a₁ b₁)
  (d : δ) (m : finmap β) : δ :=
m.entries.foldl (λ d s, f d s.1 s.2) (λ d s t, H _ _ _ _ _) d

/-- `any f s` returns `tt` iff there exists a value `v` in `s` such that `f v = tt`. -/
def any (f : Π x, β x → bool) (s : finmap β) : bool :=
s.foldl (λ x y z, x ∨ f y z) (by { intros,  simp [or.right_comm] }) ff

/-- `all f s` returns `tt` iff `f v = tt` for all values `v` in `s`. -/
def all (f : Π x, β x → bool) (s : finmap β) : bool :=
s.foldl (λ x y z, x ∧ f y z) (by { intros, simp [and.right_comm] }) ff

/-! ### erase -/

section

variables [decidable_eq α]

/-- Erase a key from the map. If the key is not present it does nothing. -/
def erase (a : α) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦erase a t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_erase p

@[simp] theorem erase_to_finmap (a : α) (s : alist β) :
  erase a ⟦s⟧ = ⟦s.erase a⟧ := by simp [erase]

@[simp]

@[simp] theorem keys_erase (a : α) (s : finmap β) :
  (erase a s).keys = s.keys.erase a :=
induction_on s $ λ s, by simp

@[simp] theorem mem_erase {a a' : α} {s : finmap β} : a' ∈ erase a s ↔ a' ≠ a ∧ a' ∈ s :=
induction_on s $ λ s, by simp

theorem not_mem_erase_self {a : α} {s : finmap β} : ¬ a ∈ erase a s :=
by rw [mem_erase, not_and_distrib, not_not]; left; refl

@[simp] theorem lookup_erase (a) (s : finmap β) : lookup a (erase a s) = none :=
induction_on s $ lookup_erase a

@[simp] theorem lookup_erase_ne {a a'} {s : finmap β} (h : a ≠ a') :
  lookup a (erase a' s) = lookup a s :=
induction_on s $ λ s, lookup_erase_ne h

theorem erase_erase {a a' : α} {s : finmap β} : erase a (erase a' s) = erase a' (erase a s) :=
induction_on s $ λ s, ext (by simp only [erase_erase, erase_to_finmap])

/-! ### sdiff -/

/-- `sdiff s s'` consists of all key-value pairs from `s` and `s'` where the keys are in `s` or
`s'` but not both. -/
def sdiff (s s' : finmap β) : finmap β :=
s'.foldl (λ s x _, s.erase x) (λ a₀ a₁ _ a₂ _, erase_erase) s

instance : has_sdiff (finmap β) := ⟨sdiff⟩

/-! ### insert -/

/-- Insert a key-value pair into a finite map, replacing any existing pair with
  the same key. -/
def insert (a : α) (b : β a) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦insert a b t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_insert p

@[simp] theorem insert_to_finmap (a : α) (b : β a) (s : alist β) :
  insert a b ⟦s⟧ = ⟦s.insert a b⟧ := by simp [insert]

theorem insert_entries_of_neg {a : α} {b : β a} {s : finmap β} : a ∉ s →
  (insert a b s).entries = ⟨a, b⟩ ::ₘ s.entries :=
induction_on s $ λ s h,
by simp [insert_entries_of_neg (mt mem_to_finmap.1 h)]

@[simp] theorem mem_insert {a a' : α} {b' : β a'} {s : finmap β} :
  a ∈ insert a' b' s ↔ a = a' ∨ a ∈ s :=
induction_on s mem_insert

@[simp] theorem lookup_insert {a} {b : β a} (s : finmap β) :
  lookup a (insert a b s) = some b :=
induction_on s $ λ s,
by simp only [insert_to_finmap, lookup_to_finmap, lookup_insert]

@[simp] theorem lookup_insert_of_ne {a a'} {b : β a} (s : finmap β) (h : a' ≠ a) :
  lookup a' (insert a b s) = lookup a' s :=
induction_on s $ λ s,
by simp only [insert_to_finmap, lookup_to_finmap, lookup_insert_ne h]

@[simp] theorem insert_insert {a} {b b' : β a} (s : finmap β) :
  (s.insert a b).insert a b' = s.insert a b' :=
induction_on s $ λ s,
by simp only [insert_to_finmap, insert_insert]

theorem insert_insert_of_ne {a a'} {b : β a} {b' : β a'} (s : finmap β) (h : a ≠ a') :
  (s.insert a b).insert a' b' = (s.insert a' b').insert a b :=
induction_on s $ λ s,
by simp only [insert_to_finmap, alist.to_finmap_eq, insert_insert_of_ne _ h]

theorem to_finmap_cons (a : α) (b : β a) (xs : list (sigma β)) :
  list.to_finmap (⟨a,b⟩ :: xs) = insert a b xs.to_finmap := rfl

theorem mem_list_to_finmap (a : α) (xs : list (sigma β)) :
  a ∈ xs.to_finmap ↔ (∃ b : β a, sigma.mk a b ∈ xs) :=
by { induction xs with x xs; [skip, cases x];
     simp only [to_finmap_cons, *, not_mem_empty, exists_or_distrib, not_mem_nil, to_finmap_nil,
                exists_false, mem_cons_iff, mem_insert, exists_and_distrib_left];
     apply or_congr _ iff.rfl,
     conv { to_lhs, rw ← and_true (a = x_fst) },
     apply and_congr_right, rintro ⟨⟩, simp only [exists_eq, iff_self, heq_iff_eq] }

@[simp] theorem insert_singleton_eq {a : α} {b b' : β a} :
  insert a b (singleton a b') = singleton a b :=
by simp only [singleton, finmap.insert_to_finmap, alist.insert_singleton_eq]

/-! ### extract -/

/-- Erase a key from the map, and return the corresponding value, if found. -/
def extract (a : α) (s : finmap β) : option (β a) × finmap β :=
lift_on s (λ t, prod.map id to_finmap (extract a t)) $
λ s₁ s₂ p, by simp [perm_lookup p, to_finmap_eq, perm_erase p]

@[simp] theorem extract_eq_lookup_erase (a : α) (s : finmap β) :
  extract a s = (lookup a s, erase a s) :=
induction_on s $ λ s, by simp [extract]

/-! ### union -/

/-- `s₁ ∪ s₂` is the key-based union of two finite maps. It is left-biased: if
there exists an `a ∈ s₁`, `lookup a (s₁ ∪ s₂) = lookup a s₁`. -/
def union (s₁ s₂ : finmap β) : finmap β :=
lift_on₂ s₁ s₂ (λ s₁ s₂, ⟦s₁ ∪ s₂⟧) $
λ s₁ s₂ s₃ s₄ p₁₃ p₂₄, to_finmap_eq.mpr $ perm_union p₁₃ p₂₄

instance : has_union (finmap β) := ⟨union⟩

@[simp] theorem mem_union {a} {s₁ s₂ : finmap β} :
  a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
induction_on₂ s₁ s₂ $ λ _ _, mem_union

@[simp] theorem union_to_finmap (s₁ s₂ : alist β) : ⟦s₁⟧ ∪ ⟦s₂⟧ = ⟦s₁ ∪ s₂⟧ :=
by simp [(∪), union]

theorem keys_union {s₁ s₂ : finmap β} : (s₁ ∪ s₂).keys = s₁.keys ∪ s₂.keys :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, finset.ext $ by simp [keys]

@[simp] theorem lookup_union_left {a} {s₁ s₂ : finmap β} :
  a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₁ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, lookup_union_left

@[simp] theorem lookup_union_right {a} {s₁ s₂ : finmap β} :
  a ∉ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, lookup_union_right

theorem lookup_union_left_of_not_in {a} {s₁ s₂ : finmap β} (h : a ∉ s₂) :
  lookup a (s₁ ∪ s₂) = lookup a s₁ :=
begin
  by_cases h' : a ∈ s₁,
  { rw lookup_union_left h' },
  { rw [lookup_union_right h', lookup_eq_none.mpr h, lookup_eq_none.mpr h'] }
end

@[simp] theorem mem_lookup_union {a} {b : β a} {s₁ s₂ : finmap β} :
  b ∈ lookup a (s₁ ∪ s₂) ↔ b ∈ lookup a s₁ ∨ a ∉ s₁ ∧ b ∈ lookup a s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, mem_lookup_union

theorem mem_lookup_union_middle {a} {b : β a} {s₁ s₂ s₃ : finmap β} :
  b ∈ lookup a (s₁ ∪ s₃) → a ∉ s₂ → b ∈ lookup a (s₁ ∪ s₂ ∪ s₃) :=
induction_on₃ s₁ s₂ s₃ $ λ s₁ s₂ s₃, mem_lookup_union_middle

theorem insert_union {a} {b : β a} {s₁ s₂ : finmap β} :
  insert a b (s₁ ∪ s₂) = insert a b s₁ ∪ s₂ :=
induction_on₂ s₁ s₂ $ λ a₁ a₂, by simp [insert_union]

theorem union_assoc {s₁ s₂ s₃ : finmap β} : (s₁ ∪ s₂) ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) :=
induction_on₃ s₁ s₂ s₃ $ λ s₁ s₂ s₃,
by simp only [alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

@[simp] theorem empty_union {s₁ : finmap β} : ∅ ∪ s₁ = s₁ :=
induction_on s₁ $ λ s₁, by rw ← empty_to_finmap;
  simp [- empty_to_finmap, alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

@[simp] theorem union_empty {s₁ : finmap β} : s₁ ∪ ∅ = s₁ :=
induction_on s₁ $ λ s₁, by rw ← empty_to_finmap;
  simp [- empty_to_finmap, alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

theorem erase_union_singleton (a : α) (b : β a) (s : finmap β) (h : s.lookup a = some b) :
  s.erase a ∪ singleton a b = s :=
ext_lookup
(λ x, by { by_cases h' : x = a,
      { subst a, rw [lookup_union_right not_mem_erase_self, lookup_singleton_eq, h], },
      { have : x ∉ singleton a b, { rwa mem_singleton },
        rw [lookup_union_left_of_not_in this, lookup_erase_ne h'] } } )

end

/-! ### disjoint -/

/-- `disjoint s₁ s₂` holds if `s₁` and `s₂` have no keys in common. -/
def disjoint (s₁ s₂ : finmap β) : Prop :=
∀ x ∈ s₁, ¬ x ∈ s₂

lemma disjoint_empty (x : finmap β) : disjoint ∅ x .

@[symm]
lemma disjoint.symm (x y : finmap β) (h : disjoint x y) : disjoint y x :=
λ p hy hx, h p hx hy

lemma disjoint.symm_iff (x y : finmap β) : disjoint x y ↔ disjoint y x :=
⟨disjoint.symm x y, disjoint.symm y x⟩

section

variables [decidable_eq α]

instance : decidable_rel (@disjoint α β) :=
λ x y, by dsimp only [disjoint]; apply_instance

lemma disjoint_union_left (x y z : finmap β) : disjoint (x ∪ y) z ↔ disjoint x z ∧ disjoint y z :=
by simp [disjoint, finmap.mem_union, or_imp_distrib, forall_and_distrib]

lemma disjoint_union_right (x y z : finmap β) : disjoint x (y ∪ z) ↔ disjoint x y ∧ disjoint x z :=
by rw [disjoint.symm_iff, disjoint_union_left, disjoint.symm_iff _ x, disjoint.symm_iff _ x]

theorem union_comm_of_disjoint {s₁ s₂ : finmap β} : disjoint s₁ s₂ → s₁ ∪ s₂ = s₂ ∪ s₁ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂,
by { intros h, simp only [alist.to_finmap_eq, union_to_finmap, alist.union_comm_of_disjoint h] }

theorem union_cancel {s₁ s₂ s₃ : finmap β} (h : disjoint s₁ s₃) (h' : disjoint s₂ s₃) :
  s₁ ∪ s₃ = s₂ ∪ s₃ ↔ s₁ = s₂ :=
⟨λ h'', begin
          apply ext_lookup, intro x,
          have : (s₁ ∪ s₃).lookup x = (s₂ ∪ s₃).lookup x, from h'' ▸ rfl,
          by_cases hs₁ : x ∈ s₁,
          { rwa [lookup_union_left hs₁, lookup_union_left_of_not_in (h _ hs₁)] at this, },
          { by_cases hs₂ : x ∈ s₂,
            { rwa [lookup_union_left_of_not_in (h' _ hs₂), lookup_union_left hs₂] at this, },
            { rw [lookup_eq_none.mpr hs₁, lookup_eq_none.mpr hs₂] } }
        end,
 λ h, h ▸ rfl⟩

end

end finmap


-- 3. higher order logic

import moromoro
import logic.basic

namespace hol

inductive type : Type
| base : type
| prop : type
| arrow : type → type → type
open type

variable ν : type → Type

inductive term : type → Type
| var : Π {t}, ν t → term t
| lam : Π {t₁ t₂}, (ν t₁ → term t₂) → term (arrow t₁ t₂)
| app : Π {t₁ t₂}, term (arrow t₁ t₂) → term t₁ → term t₂
| eq : Π {t}, term t → term t → term prop
open term

def Term (t : type) : Type 1 :=
Π ν, term ν t

def judgment : list type → type → Type :=
λ Γ t, list.foldr (λ t α, ν t → α) (term ν t) Γ

def Judgment (Γ : list type) (t : type) : Type 1 :=
Π ν, judgment ν Γ t

----

universe u
variables {α β : Type u}

inductive mem : α → list α → Type u
| here : Π {x l}, mem x (x :: l)
| there : Π {x l y}, mem x l → mem x (y :: l)
open mem

local infix ` ∈' `:50 := mem

variables {Γ Γ₁ Γ₂ : list type} {t t₁ t₂ t₃ : type}

def subst' : Π {t : type}, term (term ν) t → term ν t
| _ (var m) := m
| _ (lam f) := lam (λ x, subst' (f (var x)))
| _ (app m₁ m₂) := app (subst' m₁) (subst' m₂)
| _ (eq m₁ m₂) := eq (subst' m₁) (subst' m₂)

namespace judgment
  def weak : Judgment Γ t₂ → Judgment (t₁ :: Γ) t₂ :=
  λ m ν x, m ν

  def var' : Π {Γ}, judgment ν (t :: Γ) t
  | [] := λ x, var x
  | (t :: Γ) := λ x y, var' x

  def var : Π {Γ}, t ∈' Γ → Judgment Γ t
  | _ here := λ ν, var' ν
  | _ (there h) := weak (var h)

  def lam' : Π {Γ}, judgment ν (t₁ :: Γ) t₂ → judgment ν Γ (arrow t₁ t₂)
  | [] m := lam (λ x, m x)
  | (t :: Γ) f := λ x, lam' (λ y, f y x)

  def lam : Judgment (t₁ :: Γ) t₂ → Judgment Γ (arrow t₁ t₂) :=
  λ m ν, lam' ν (m ν)

  def app' : Π {Γ}, judgment ν Γ (arrow t₁ t₂) → judgment ν Γ t₁ → judgment ν Γ t₂
  | [] m₁ m₂ := app m₁ m₂
  | (t :: Γ) f m := λ x, app' (f x) (m x)

  def app : Judgment Γ (arrow t₁ t₂) → Judgment Γ t₁ → Judgment Γ t₂ :=
  λ m₁ m₂ ν, app' ν (m₁ ν) (m₂ ν)

  def eq' : Π {Γ : list type}, judgment ν Γ t → judgment ν Γ t → judgment ν Γ prop
  | [] m₁ m₂ := eq m₁ m₂
  | (t :: Γ) m₁ m₂ := λ x, eq' (m₁ x) (m₂ x)

  def eq : Judgment Γ t → Judgment Γ t → Judgment Γ prop :=
  λ m₁ m₂ ν, eq' ν (m₁ ν) (m₂ ν)

  def subst'' : Π {Γ}, judgment (term ν) (t₁ :: Γ) t₂ → judgment ν Γ t₁ → judgment ν Γ t₂
  | [] m₁ m₂ := subst' ν (m₁ m₂)
  | (t :: Γ) f m := λ x, subst'' (λ x', f x' (term.var x)) (m x)

  def subst : Judgment (t₁ :: Γ) t₂ → Judgment Γ t₁ → Judgment Γ t₂ :=
  λ m₁ m₂ ν, subst'' ν (m₁ _) (m₂ ν)
end judgment
open judgment

----

def type.foldr : list type → type → type :=
λ Γ t, list.foldr arrow t Γ

def judgment.to_term' : Π {Γ : list type}, judgment ν Γ t → term ν (type.foldr Γ t)
| [] m := m
| (t :: Γ) f := lam (λ x, judgment.to_term' (f x))

def judgment.to_term : Judgment Γ t → Term (type.foldr Γ t) :=
λ m ν, judgment.to_term' ν (m ν)

def term.to_judgment' : Π {Γ : list type}, term (term ν) (type.foldr Γ t) → judgment ν Γ t
| [] m := subst' ν m
| (t :: Γ) m :=
  match m with
  | (var x) := λ x, term.to_judgment' (app m (var (var x)))
  | (lam f) := λ x, term.to_judgment' (f (var x))
  | (app m₁ m₂) := λ x, term.to_judgment' (app m (var (var x)))
  end

def term.to_judgment : Term (type.foldr Γ t) → Judgment Γ t :=
λ m ν, term.to_judgment' ν (m _)

----

def domain : type → Type
| base := term ν base
| prop := term ν prop
| (arrow t₁ t₂) := domain t₁ → domain t₂

def Domain (t : type) : Type 1 :=
Π ν, domain ν t

def reify_reflect : Π (t : type), (domain ν t → term ν t) × (term ν t → domain ν t)
| base := ⟨ id, id ⟩
| prop := ⟨ id, id ⟩
| (arrow t₁ t₂) :=
   let r₁ := reify_reflect t₁ in
   let r₂ := reify_reflect t₂ in
   let reify (f : domain ν t₁ → domain ν t₂) := lam (λ x, r₂.1 (f (r₁.2 (var x)))) in
   let reflect (f : term ν (arrow t₁ t₂)) := λ x, r₂.2 (app f (r₁.1 x)) in
   ⟨reify, reflect⟩

def reify' : domain ν t → term ν t :=
λ x, (reify_reflect ν t).1 x

def reify : Domain t → Term t :=
λ x ν, reify' ν (x ν)

def eval' : Π {t : type}, term (domain ν) t → domain ν t
| _ (var x) := x
| _ (lam f) := λ x, eval' (f x)
| _ (app m₁ m₂) := (eval' m₁) (eval' m₂)
| _ (eq m₁ m₂) := eq (reify' ν (eval' m₁)) (reify' ν (eval' m₂))

def eval : Term t → Domain t :=
λ m ν, eval' ν (m _)

def normalize : Term t → Term t :=
reify ∘ eval

instance term_setoid : setoid (Term t) :=
⟨inv_image eq normalize,
 inv_image.equivalence eq normalize eq_equivalence⟩

instance judgment_setoid [h : setoid (Term (type.foldr Γ t))] : setoid (Judgment Γ t) :=
⟨inv_image h.r judgment.to_term,
 inv_image.equivalence h.r judgment.to_term h.iseqv⟩

meta def canonicity : tactic unit :=
`[ try { unfold has_equiv.equiv setoid.r inv_image }, try { reflexivity } ]

----

namespace term
  def top : Term prop :=
  λ ν, eq (lam (λ x : ν prop, var x)) (lam (λ x, var x))

  def and : Term (arrow prop (arrow prop prop)) :=
  λ ν, lam (λ p₁, lam (λ p₂, eq (lam (λ f : ν (arrow _ (arrow _ prop)), app (app (var f) (top ν)) (top ν))) (lam (λ f, app (app (var f) (var p₁)) (var p₂)))))

  def Forall : Term (arrow (arrow t prop) prop) :=
  λ ν, lam (λ f, eq (var f) (lam (λ x, (top ν))))

  def bot : Term prop :=
  λ ν, app (Forall ν) (lam (λ p, var p))

  def implies : Term (arrow prop (arrow prop prop)) :=
  λ ν, lam (λ p₁, lam (λ p₂, eq (app (app (and ν) (var p₁)) (var p₂)) (var p₁)))

  def not : Term (arrow prop prop) :=
  λ ν, lam (λ p, app (app (implies ν) (var p)) (bot ν))

  def iff : Term (arrow prop (arrow prop prop)) :=
  λ ν, lam (λ p₁, lam (λ p₂, app (app (and ν) (app (app (implies ν) (var p₁)) (var p₂))) (app (app (implies ν) (var p₂)) (var p₁))))

  def or : Term (arrow prop (arrow prop prop)) :=
  λ ν, lam (λ p₁, lam (λ p₂, app (Forall ν) (lam (λ r, app (app (implies ν) (app (app (and ν) (app (app (implies ν) (var p₁)) (var r))) (app (app (implies ν) (var p₂)) (var r)))) (var r)))))

  def Exists : Term (arrow (arrow t prop) prop) :=
  λ ν, lam (λ f, app (Forall ν) (lam (λ r, app (app (implies ν) (app (Forall ν) (lam (λ x, app (app (implies ν) (app (var f) (var x))) (var r))))) (var r))))
end term
open term

#reduce @id (Judgment [] prop) $ app (app and top) (app (app or bot) top)

----

inductive Theorem : Π {Γ}, list (Judgment Γ prop) → Judgment Γ prop → Prop
| hyp : Π {Γ Φ} {φ : Judgment Γ prop}, φ ∈ Φ → Theorem Φ φ
| refl : Π {Γ Φ t} {m₁ m₂ : Judgment Γ t}, m₁ ≈ m₂ → Theorem Φ (eq m₁ m₂)
| subst : Π {Γ Φ t} (m : Judgment (t :: Γ) prop) (m₂ m₁ : Judgment Γ t), Theorem Φ (eq m₁ m₂) → Theorem Φ (subst m m₁) → Theorem Φ (subst m m₂)
| prop_ext : Π {Γ Φ} {φ₁ φ₂ : Judgment Γ prop}, Theorem (φ₁ :: Φ) φ₂ → Theorem (φ₂ :: Φ) φ₁ → Theorem Φ (eq φ₁ φ₂)
| fun_ext : Π {Γ Φ t₁ t₂} (m₁ m₂ : Judgment (t₁ :: Γ) t₂), Theorem (list.map weak Φ) (eq m₁ m₂) → Theorem Φ (eq (lam m₁) (lam m₂))

-- Let's prove!

example : @Theorem [prop] [var here] (eq (weak top) (var here)) :=
begin
  apply Theorem.prop_ext,
  { apply Theorem.hyp,
    simp },
  { apply Theorem.refl,
    canonicity }
end

example {φ₁ φ₂} {Φ : list (Judgment [] prop)} : Theorem Φ (app (app and φ₁) φ₂) → Theorem Φ φ₁ :=
begin
  intro p,
  apply Theorem.subst
    (var here)
    φ₁
    (λ ν, app (lam (λ f, app (app (var f) (φ₁ ν)) (φ₂ ν))) (lam (λ p₁, lam (λ p₂, var p₁)))),
  { apply Theorem.refl,
    canonicity, },
  { apply Theorem.subst
      (@id (Judgment [arrow _ prop] prop) $ λ ν f, app (var f) (lam (λ p₁, lam (λ p₂, var p₁))))
      (λ ν, lam (λ f, app (app (var f) (φ₁ ν)) (φ₂ ν)))
      (@id (Judgment [] (arrow _ prop)) $ λ ν, lam (λ f, app (app (var f) (top ν)) (top ν))),
    { apply Theorem.subst
        (var here)
        (eq
          (@id (Judgment [] (arrow _ prop)) $ λ ν, lam (λ f, app (app (var f) (top ν)) (top ν)))
          (λ ν, lam (λ f, app (app (var f) (φ₁ ν)) (φ₂ ν))))
        (λ ν, app (app (lam (λ p₁, lam (λ p₂, eq (lam (λ f : ν (arrow _ (arrow _ prop)), app (app (var f) (top ν)) (top ν))) (lam (λ f, app (app (var f) (var p₁)) (var p₂)))))) (φ₁ ν)) (φ₂ ν)),
      { apply Theorem.refl,
        canonicity },
      { from p } },
    { apply Theorem.subst
        (var here)
        (@id (Judgment [] _) $ λ ν, app (lam (λ f, app (app (var f) (top ν)) (top ν))) (lam (λ p₁, lam (λ p₂, var p₁))))
        top,
      { apply Theorem.refl,
        canonicity },
      { apply Theorem.refl,
        canonicity } } }
end

end hol


import galois.tactic
       .init .tail .inter .map_accum_lemmas .nth
       .take_drop_lemmas .preds .fin_nth .mem

universe u

def second {X A B : Type} (f : A -> B) : X × A -> X × B
| (x, y) := (x, f y)

lemma second_simpl {X A B : Type} (f : A -> B)
  (x : X) (y : A)
  : second f (x, y) = (x, f y)
  := rfl

namespace list

-- This runs a function over a list returning the intermediate results and a
-- a final result.
def map_accuml {α  σ β : Type} (f : σ → α → β × σ) : σ → list α → (list β × σ)
| c [] := ([], c)
| c (y::yr) :=
  let z := f c y in
  let r := map_accuml z.2 yr in
  (z.1 :: r.1, r.2)

def first_index_of_core {α : Type} (p : α → bool) : ℕ → list α → option (ℕ × α)
| c [] := option.none
| c (h::r) :=
  if p h = tt then
    option.some (c,h)
  else
    first_index_of_core (c+1) r

-- This searches a list for an element that satisfies a predicate.
--
-- If it finds an element, it returns the index and element.  Otherwise, it
-- returns none.
def first_index_of {α : Type} (p : α → bool) (l : list α) : option (ℕ × α) :=
  first_index_of_core p 0 l

def find_option {A} [decidable_eq A] (item: A) (l : list A) : option ℕ :=
let index := list.index_of item l in
if index = l.length then none else some index

lemma find_option_mem_len {A} [decidable_eq A] {x : A} {xs : list A}
  (H : x ∈ xs)
  : ∃ n, xs.find_option x = some n ∧ n < xs.length
:= begin
rw ← list.index_of_lt_length at H,
destruct (find_option x xs),
{ intros Hnone, exfalso,
  unfold find_option at Hnone, dsimp at Hnone,
  rw if_neg at Hnone, injection Hnone,
  apply ne_of_lt, assumption },
{ intros n Hn, constructor, split, assumption,
  unfold find_option at Hn, dsimp at Hn,
  have H : index_of x xs ≠ length xs,
  apply ne_of_lt, assumption,
  rw (if_neg H) at Hn, injection Hn with Hn',
  rw ← Hn', assumption
}
end

lemma find_option_mem {A} [decidable_eq A] {x : A} {xs : list A}
  (H : x ∈ xs)
  : ∃ n, xs.find_option x = some n
:= begin
apply_in H find_option_mem_len,
induction H with n H, induction H with H H',
constructor, assumption,
end

lemma find_index_append {A} {P : A → Prop} [decidable_pred P]
  (xs ys : list A)
  (n : ℕ)
  (Hn : n ≠ xs.length)
  (H : xs.find_index P = n)
  : (xs ++ ys).find_index P = n
:= begin
revert n,
induction xs; intros,
{ dsimp [list.index_of, list.find_index] at H, subst n,
  exfalso, apply Hn, reflexivity, },
{ dsimp [list.index_of, list.find_index] at H,
  rename a x,
  apply (if HPx : P x then _ else _),
  { rw (if_pos HPx) at H, subst n,
    dsimp [list.index_of, list.find_index],
    rw (if_pos HPx), },
  { rw (if_neg HPx) at H,
    dsimp, dsimp [list.index_of, list.find_index],
    rw (if_neg HPx),
    cases n, injection H,
    rename a n, injection H with H', clear H,
    f_equal, apply ih_1, intros contra, apply Hn,
    dsimp [list.length], dsimp [has_add.add, nat.add],
    f_equal, assumption, assumption
  }
}
end

lemma index_of_append {A} [decidable_eq A] (x : A) (xs ys : list A)
  (n : ℕ)
  (Hn : n ≠ xs.length)
  (H : list.index_of x xs = n)
  : list.index_of x (xs ++ ys) = n
:= begin
apply list.find_index_append; assumption
end

lemma not_not_iff {a : Prop} [decidable a] : ¬¬a ↔ a :=
iff.intro by_contradiction not_not_intro

lemma find_option_append {A} [decidable_eq A] (x : A) (xs ys : list A)
  (n : ℕ)
  (Hn : xs.find_option x = some n)
  : (xs ++ ys).find_option x = some n
:= begin
unfold find_option at Hn, dsimp at Hn,
apply (if H : list.index_of x xs = list.length xs then _ else _),
{ rw (if_pos H) at Hn, contradiction, },
{ rw (if_neg H) at Hn,
  injection Hn with Hn', clear Hn,
  dsimp, dsimp [find_option],
  rw list.index_of_append, tactic.rotate 2, assumption,
  tactic.swap, intros contra, apply H, subst n, assumption,
  rw list.index_of_eq_length at H, subst Hn',
  rw [not_not_iff] at H,
  rw ← list.index_of_lt_length at H,
  have H1 : list.index_of x xs ≠ list.length (xs ++ ys),
  apply ne_of_lt, rw list.length_append,
  apply lt_of_lt_of_le, assumption,
  rw add_comm,
  apply le_add_of_nonneg_left, apply nat.zero_le,
  simp [H1],
 }
end

lemma nth_cons_drop {A : Type} : forall h t n (i :A),
n ≠ 0 ->
list.nth (h :: t) (n) = some i ->
list.nth t (n - 1) = some i :=
begin
intros,
cases n,
{ contradiction },
{
  dsimp at *,
  simp at *,
  assumption,
}
end

lemma pair_induction_same_length {X Y}
  (P : list X → list Y → Sort u)
  (P0 : P [] [])
  (PS : ∀ x y xs ys, P xs ys → P (x :: xs) (y :: ys))
  (xs : list X) (ys : list Y) (H : xs.length = ys.length)
  : P xs ys
:= begin
revert xs, induction ys; intros; dsimp at H,
{ apply_in H list.eq_nil_of_length_eq_zero, subst xs,
  assumption, },
{ cases xs; dsimp at H, contradiction,
  apply PS, apply ih_1,
  apply nat.add_right_cancel, assumption,
}
end

lemma map_compose {A B C : Type}
  (f : A -> B) (g : B -> C) (xs : list A)
  : map (g ∘ f) xs = map g (map f xs)
:=
begin
induction xs,
{ reflexivity },
{ simp [map] }
end

lemma reverse_core_app {A : Type} (xs ys zs : list A)
  : list.reverse_core xs (ys ++ zs)
  = list.reverse_core xs ys ++ zs
:= begin
revert ys zs,
induction xs; intros,
{ simp [list.reverse_core] },
{ simp [list.reverse_core],
  rw <- list.cons_append,
  rw ih_1 }
end

lemma cons_reverse {A : Type} (x : A) (xs : list A)
  : list.reverse (x :: xs) = list.reverse xs ++ [x]
:=
begin
unfold list.reverse,
simp [list.reverse_core],
induction xs,
{ reflexivity },
{ simp [list.reverse_core],
  rw <- (reverse_core_app a_1 [a] [x]),
  dsimp, reflexivity
 }
end

lemma cons_reverse_app {A : Type} (x : A) (xs : list A)
: (list.reverse ∘ list.cons x) xs =
   ((λ xs, xs ++ [x]) ∘ list.reverse) xs
:=
begin
induction xs,
{ reflexivity },
{ simp [function.comp], }
end

lemma zip_same_length {X Y}
  (xs ys : list X) (xs' ys' : list Y) (H : xs.length = xs'.length)
  : zip (xs ++ ys) (xs' ++ ys')
  = zip xs xs' ++ zip ys ys'
:= begin
revert H xs' xs,
apply list.pair_induction_same_length,
reflexivity, intros, dsimp [list.zip, list.zip_with],
f_equal, assumption
end

lemma zip_map_r {X Y Z} (xs : list X) (ys : list Y)
  (f : Y → Z)
  : zip xs (map f ys) =
  list.map (second f) (list.zip xs ys)
:= begin
revert ys, induction xs; intros,
{ reflexivity },
{ cases ys,
  { reflexivity },
  { dsimp [list.zip, list.zip_with], f_equal,
    specialize (ih_1 a_3),
    unfold list.zip at ih_1,
    rw ih_1,
  }
 }
end

lemma map_fst_second {X A B : Type}
  (xs : list (X × A)) (f : A -> B)
  : map (prod.fst ∘ second f) xs
  = map prod.fst xs
:= begin
induction xs,
{ reflexivity },
{ simp only [list.map],
  cases a with i1 i2,
  simp only [second],
  rw ih_1, reflexivity
}
end

lemma map_not_nil {A B} (xs) (f : A -> B)
  (H : xs ≠ []) : list.map f xs ≠ [] :=
begin
cases xs,
{ contradiction },
{ simp [list.map], }
end

lemma map_nil {A B : Type} (f : A -> B)
  (xs : list A)
  (H : xs = [])
  : list.map f xs = []
  :=
begin
rw H, reflexivity
end

lemma repeat_length {A} (x : A) (n : ℕ)
  : (list.repeat x n).length = n
:= begin
induction n; simp [list.repeat, list.length],
end

end list

universe variable v

namespace list

variables {α : Type u} {β : Type v}

/- null theorems -/

-- Return true if list is empty
--
-- null x is equivalent to x = nil, but always decidable even if equality
-- of list elements is undecidable
def null : list α → Prop := λx, x = nil

instance null_decidable : ∀ xs : list α, decidable (null xs)
| nil := is_true (begin unfold null end)
| (x :: xs) := is_false (begin unfold null, contradiction end)

/- foldl theorem -/

-- Recursor to prove properties about a list and a left-fold over that list
protected
lemma foldl_rec_gen (P : list β → α → Prop)
                    (f : α → β → α)
                    (h : ∀(l : list β) (t : α) (e : β), P l t →  P (l ++ [e]) (f t e))
: ∀(r : list β) (s : α), P r s → ∀ (l : list β), P (r ++ l) (foldl f s l)
| r s p l :=
begin
  revert r s p,
  induction l,
  case list.nil { intros r s p, simp, exact p, },
  case list.cons e l ind {
    intros r s p,
    simp [foldl],
    have g := ind (r ++ [e]) (f s e) (h r s e p),
    simp at g,
    exact g,
  }
end

-- Recursor to prove properties about a list and a left-fold over that list
protected
theorem foldl_rec (P : list β → α → Prop)
                  (f : α → β → α)
                  (ind_step : ∀(l : list β) (t : α) (e : β), P l t →  P (l ++ [e]) (f t e))
                  (s : α)
                  (base_case : P nil s)
                  (l : list β)
: P l (foldl f s l) :=
  list.foldl_rec_gen P f ind_step nil s base_case l

def drop_last {a : Type} (l : list a) := list.remove_nth l (list.length l - 1)

end list


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import topology.bornology.basic

/-!
# Locally bounded maps

This file defines locally bounded maps between bornologies.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `locally_bounded_map`: Locally bounded maps. Maps which preserve boundedness.

## Typeclasses

* `locally_bounded_map_class`
-/

open bornology filter function set

variables {F α β γ δ : Type*}

/-- The type of bounded maps from `α` to `β`, the maps which send a bounded set to a bounded set. -/
structure locally_bounded_map (α β : Type*) [bornology α] [bornology β] :=
(to_fun : α → β)
(comap_cobounded_le' : (cobounded β).comap to_fun ≤ cobounded α)

/-- `locally_bounded_map_class F α β` states that `F` is a type of bounded maps.

You should extend this class when you extend `locally_bounded_map`. -/
class locally_bounded_map_class (F : Type*) (α β : out_param $ Type*) [bornology α]
  [bornology β]
  extends fun_like F α (λ _, β) :=
(comap_cobounded_le (f : F) : (cobounded β).comap f ≤ cobounded α)

export locally_bounded_map_class (comap_cobounded_le)

lemma is_bounded.image [bornology α] [bornology β] [locally_bounded_map_class F α β] {f : F}
  {s : set α} (hs : is_bounded s) : is_bounded (f '' s) :=
comap_cobounded_le_iff.1 (comap_cobounded_le f) hs

instance [bornology α] [bornology β] [locally_bounded_map_class F α β] :
  has_coe_t F (locally_bounded_map α β) :=
⟨λ f, ⟨f, comap_cobounded_le f⟩⟩

namespace locally_bounded_map
variables [bornology α] [bornology β] [bornology γ]
  [bornology δ]

instance : locally_bounded_map_class (locally_bounded_map α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { cases f, cases g, congr' },
  comap_cobounded_le := λ f, f.comap_cobounded_le' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (locally_bounded_map α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : locally_bounded_map α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : locally_bounded_map α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `locally_bounded_map` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : locally_bounded_map α β) (f' : α → β) (h : f' = f) :
  locally_bounded_map α β :=
⟨f', h.symm ▸ f.comap_cobounded_le'⟩

/-- Construct a `locally_bounded_map` from the fact that the function maps bounded sets to bounded
sets. -/
def of_map_bounded (f : α → β) (h) : locally_bounded_map α β := ⟨f, comap_cobounded_le_iff.2 h⟩

@[simp] lemma coe_of_map_bounded (f : α → β) {h} : ⇑(of_map_bounded f h) = f := rfl
@[simp] lemma of_map_bounded_apply (f : α → β) {h} (a : α) : of_map_bounded f h a = f a := rfl

variables (α)

/-- `id` as a `locally_bounded_map`. -/
protected def id : locally_bounded_map α α := ⟨id, comap_id.le⟩

instance : inhabited (locally_bounded_map α α) := ⟨locally_bounded_map.id α⟩

@[simp] lemma coe_id : ⇑(locally_bounded_map.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : locally_bounded_map.id α a = a := rfl

/-- Composition of `locally_bounded_map`s as a `locally_bounded_map`. -/
def comp (f : locally_bounded_map β γ) (g : locally_bounded_map α β) : locally_bounded_map α γ :=
{ to_fun := f ∘ g,
  comap_cobounded_le' :=
    comap_comap.ge.trans $ (comap_mono f.comap_cobounded_le').trans g.comap_cobounded_le' }

@[simp] lemma coe_comp (f : locally_bounded_map β γ) (g : locally_bounded_map α β) :
  ⇑(f.comp g) = f ∘ g := rfl
@[simp] lemma comp_apply (f : locally_bounded_map β γ) (g : locally_bounded_map α β) (a : α) :
  f.comp g a = f (g a) := rfl
@[simp] lemma comp_assoc (f : locally_bounded_map γ δ) (g : locally_bounded_map β γ)
  (h : locally_bounded_map α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : locally_bounded_map α β) :
  f.comp (locally_bounded_map.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : locally_bounded_map α β) :
  (locally_bounded_map.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : locally_bounded_map β γ} {f : locally_bounded_map α β}
  (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : locally_bounded_map β γ} {f₁ f₂ : locally_bounded_map α β}
  (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end locally_bounded_map