import LeanCodePrompts.FirstTacticData
import LeanCodePrompts.ParseJson
import LeanCodePrompts.Translate
import Lean

open Lean Meta Elab Tactic Parser

initialize cacheTacticJson : IO.Ref (HashMap String Json) ← IO.mkRef (HashMap.empty)

def getTacticString : TacticM String := do
  let s ← saveState
  let target ← getMainTarget
  let lctx ←  getLCtx
  let decls := lctx.decls.toList.tail!
  let mut statement := ""
  for decl in decls do
    match decl with
    | some <| LocalDecl.ldecl _ _ n t .. =>
      statement := statement ++ s!"({n.eraseMacroScopes} : {← t.view}) "
      pure ()
    | some <| LocalDecl.cdecl _ _ n t bi _ => do
      let core := s!"{n.eraseMacroScopes} : {← t.view}"
      let typeString :=s!"{← t.view}"
      let argString := match bi with
      | BinderInfo.implicit => "{"++ core ++ "}"
      | BinderInfo.strictImplicit => "{{ "++ core ++ "}}"
      | BinderInfo.instImplicit =>
        if (`inst).isPrefixOf n then s!"[{typeString}]"
          else s!"[{core}]"
      | BinderInfo.default => s!"({core})"
      statement := statement ++ argString ++ " "
      pure ()
    | none => pure ()
  statement := statement ++ ": " ++ (←  target.view)
  s.restore
  return statement.replace "✝" ""

elab "name_inacessibles" : tactic => do
  withMainContext do
  let lctx ←  getLCtx
  let decls := lctx.decls
  let mut statement := "rename_i"
  for decl in decls do
    match decl with
    | some <| LocalDecl.ldecl _ _ n .. =>
      if n != n.eraseMacroScopes then
        statement := statement ++ s!" {n.eraseMacroScopes}"
      pure ()
    | some <| LocalDecl.cdecl _ _ n .. => do
      if n != n.eraseMacroScopes then
        statement := statement ++ s!" {n.eraseMacroScopes}"
      pure ()
    | none => pure ()
  unless statement == "rename_i" do
    let tac? := runParserCategory (← getEnv) `tactic statement
      match tac? with
      | Except.ok tac => do
        evalTactic tac
      | Except.error e => do
        throwError e

elab "show_goal" : tactic =>
  withMainContext do
    let view ← getTacticString
    logInfo view
    return ()

def silly {α  : Type}(n m : Nat)[DecidableEq α] : n + m = n + m := by
    show_goal
    let a  := n
    let _ : a = a := rfl
    show_goal
    rfl

def silly' : (n m : Nat)  →  n + m = n + m := by
    intros
    show_goal
    rfl
    done

example : (n m : Nat)  →  n + m = n + m := by
    intros
    name_inacessibles
    rfl
    done

structure TacticStateProxy where
  binders: Array <| Name ×  BinderInfo
  letData : Array <| Name × Expr × Expr
  target : Expr

def getTacticStateProxy : TacticM <| Option TacticStateProxy :=
  withoutModifyingState do
  try
    let target ← getMainTarget
    let lctx ←  getLCtx
    let decls := lctx.decls
    let mut binders := #[]
    let mut letData := #[]
    let mut fvars : Array Expr := #[]
    for decl in decls do
      match decl with
      | some <| LocalDecl.ldecl _ _ n t b .. =>
        let t ← mkForallFVars fvars t
        let b ← mkLambdaFVars fvars b
        letData := letData.push (n, t, b)
        pure ()
      | some <| LocalDecl.cdecl _ fVarId n _ bi _ => do
        binders := binders.push  (n, bi)
        fvars := fvars.push <| mkFVar fVarId
        pure ()
      | none => pure ()
    let target ← mkForallFVars fvars target
    return some {binders := binders, letData := letData, target := target}
  catch _ => return none

#check List.allM

def equalStates (s₁ s₂ : TacticStateProxy) : TacticM Bool :=
   withMainContext do
    return s₁.binders == s₂.binders
            && s₁.letData.size == s₂.letData.size &&
            (← isDefEq s₁.target s₂.target) &&
            (← (List.range s₁.letData.size).allM (fun i =>
              let (n₁, t₁, b₁) := s₁.letData.get! i
              let (n₂, t₂, b₂) := s₂.letData.get! i
              return n₁ == n₂ && (← isDefEq t₁ t₂) && (← isDefEq b₁ b₂)))

def firstEffectiveTactic (tacStrings: List String)(warnOnly: Bool := Bool.true) : TacticM Unit :=
  withMainContext do
  let env ← getEnv
  let goal ← getTacticString
  logInfo m!"goal: {goal}"
  logInfo m!"trying tactics: {tacStrings}"
  let s ← saveState
  let s₁? ← getTacticStateProxy
  for tacString in tacStrings do
    -- logInfo m!"Trying tactic {tacString}"
    try
      let tac? := runParserCategory env `tactic tacString
      match tac? with
      | Except.ok tac => do
          Term.withoutErrToSorry do
            evalTactic tac
          let gs ← getUnsolvedGoals
          if gs.isEmpty then
              logInfo m!"tactic `{tacString}` was effective"
              return
          else
            let check : Bool ←
            try
              let s₂? ← getTacticStateProxy
              match s₁?, s₂? with
              | some s₁, some s₂ => equalStates s₁ s₂
              | _,_ => pure Bool.true
            catch _ =>
              -- logWarning
                -- m!"Failed to check state after {tacString}; error : {e.toMessageData}"
              pure Bool.true
            if check then
              s.restore
            else
              let checkForSorries : Bool ←
                try
                  let target ← getMainTarget
                  pure target.hasSyntheticSorry
                catch _ => pure Bool.false
              -- logInfo m!"sorries? {checkForSorries}"
              if checkForSorries then
                s.restore
              else
                logInfo m!"tactic `{tacString}` was effective"
                return
      | Except.error _ =>
        pure ()
    catch _ =>
      s.restore
  unless warnOnly do
    throwError m!"No effective tactic found for {goal} in {tacStrings}"
  logWarning "No tactic in the list was effective"

elab "first_effective_tactic" : tactic =>
  withMainContext do
    firstEffectiveTactic ["unparsable", "exact blah", "intros", "rfl"]

-- proved by reflexivity
def silly'' (n m : Nat)  : n + m = n + m := by
    intros -- legal but no effect
    first_effective_tactic

def silly''' : (n m : Nat)  →  n + m = n + m := by
    first_effective_tactic
    rfl

def silly'''' : (n m : Nat)  →  n + m = n + m := by
    repeat (first_effective_tactic)

def getTacticPrompts(s: String)(numSim : Nat)
   : TermElabM (Array String) := do
      let jsData := Json.mkObj [
        ("filename", "data/lean4-thms.json"),
        ("field", "core-prompt"),
        ("core-prompt", s),
        ("n", numSim),
        ("model_name", "all-mpnet-base-v2")
      ]
      let simJsonOut ←
        IO.Process.output {cmd:= "curl", args:=
          #["-X", "POST", "-H", "Content-type: application/json", "-d", jsData.pretty, s!"{← leanAideIP}/nearest_prompts"]}
      if simJsonOut.exitCode > 0 then
        throwError m!"Failed to get prompts from server: {simJsonOut.stderr}"
      else
        let json ← readJson simJsonOut.stdout
        match json.getArr? with
        | Except.ok arr =>
          let mut prompts := #[]
          for j in arr do
            match j.getObjVal? "tactic-prompt" with
            | Except.ok s =>
              match s.getStr? with
              | Except.ok s =>
                prompts := prompts.push s
              | Except.error e =>
                throwError m!"Failed to parse json {j}; error: {e}"
            | Except.error e =>
              throwError m!"Failed to parse json {j}; error: {e}"
          return prompts
        | Except.error e =>
            throwError m!"Failed to parse json: {e}"

def fourSquaresPrompt := ": ∀ p : Nat, Prime p → (p % 4 = 1) → ∃ a b : Nat, a ^ 2 + b ^ 2 = p"

-- #eval getTacticPrompts fourSquaresPrompt 20

def makeTacticPrompt (n: Nat)  : TacticM String := do
  let core ← getTacticString
  let prompts ← getTacticPrompts core n
  let prompt := prompts.foldr (fun  p acc =>
s!"{p}

{acc}"
          ) s!"
theorem {core} := by "
  return prompt

def tacticList : TacticM <| List String := do
  let core ← getTacticString
  let prompts ← getTacticPrompts core 5
  let promptPairs := prompts.map (fun p =>
    let arr := p.splitOn ":= by"
    (arr.get! 0++ ":= by", arr.get! 1))
  let prompt := GPT.makePrompt core promptPairs
  -- let prompt ← makeTacticPrompt 20
  let cache ← cacheTacticJson.get
  let fullJson ←
    match cache.find? prompt.pretty with
    | some json => pure json
    | none =>
      let res ← gptQuery prompt 5 ⟨8, 1⟩ #[";", "sorry", "\n"]
      cacheTacticJson.set <| cache.insert prompt.pretty res
      pure res
  let outJson :=
        (fullJson.getObjVal? "choices").toOption.getD (Json.arr #[])
  let arr ← GPT.jsonToExprStrArray outJson
  let arr := arr.map (fun s =>
      if s.endsWith "<" then s.dropRight 1 |>.trim else s.trim)
  return arr.toList.eraseDups

elab "aide?" : tactic =>
  withMainContext do
    let tacStrings ← tacticList
    let tacStrings := tacStrings.filter (fun s => s != "sorry" && s != "admit")
    let tac ← `(tactic|name_inacessibles)
    evalTactic tac
    firstEffectiveTactic tacStrings Bool.true

elab "aide!" : tactic =>
  withMainContext do
    let tacStrings ← tacticList
    let tac ← `(tactic|name_inacessibles)
    evalTactic tac
    let tacStrings := tacStrings.filter (fun s => s != "sorry" && s != "admit")
    firstEffectiveTactic tacStrings Bool.false

macro "aide" : tactic =>
  `(tactic| aide? ; save)

elab "show_tactic_prompt" : tactic =>
  withMainContext do
    let view ← makeTacticPrompt 20
    logInfo view
    return ()

elab "lookahead" tac:tactic : tactic =>
  withMainContext do
    let s ← saveState
    try
      evalTactic tac
      s.restore
    catch e =>
      s.restore
      let msg := e.toMessageData
      throwError s!"{← msg.toString}"

def lookaheadTactics (ss: List String) : List String :=
    ss.map (fun s => s!"{s} ; done") ++
    ss.map (fun s => s!"({s} <;> (lookahead aide!)) ; done") ++
    ss.map (fun s => s!"{s} <;> (lookahead aide!)") ++
    ss

example : 1 = 1 := by
  lookahead rfl
  lookahead rfl
  rfl

elab "aide_aux" : tactic =>
  withMainContext do
    let tacStrings ← tacticList
    let tacStrings := tacStrings.filter (fun s => s != "sorry" && s != "admit")
    let tac ← `(tactic|name_inacessibles)
    evalTactic tac
    let tacStrings := lookaheadTactics tacStrings
    firstEffectiveTactic tacStrings Bool.false

macro "aide_lookahead" : tactic => `(checkpoint aide_aux)


/-!
# Monad Transformers

In the previous sections you learned about some handy monads [Option](monads.lean.md),
[IO](monads.lean.md), [Reader](readers.lean.md), [State](states.lean.md) and
[Except](except.lean.md), and you now know how to make your function use one of these, but what you
do not yet know is how to make your function use multiple monads at once.

For example, suppose you need a function that wants to access some Reader context and optionally throw
an exception?  This would require composition of two monads `ReaderM` and `Except` and this is what
monad transformers are for.

A monad transformer is fundamentally a wrapper type. It is generally parameterized by another
monadic type. You can then run actions from the inner monad, while adding your own customized
behavior for combining actions in this new monad. The common transformers add `T` to the end of an
existing monad name. You will find `OptionT`, `ExceptT`, `ReaderT`, `StateT` but there is no transformer
for `IO`.  So generally if you need `IO` it becomes the innermost wrapped monad.

In the following example we use `ReaderT` to provide some read only context to a function
and this `ReaderT` transformer will wrap an `Except` monad.  If all goes well the
`requiredArgument` returns the value of a required argument and `optionalSwitch`
returns true if the optional argument is present.

-/
abbrev Arguments := List String

def indexOf? [BEq α] (xs : List α) (s : α) (start := 0): Option Nat :=
  match xs with
  | [] => none
  | a :: tail => if a == s then some start else indexOf? tail s (start+1)

def requiredArgument (name : String) : ReaderT Arguments (Except String) String := do
  let args ← read
  let value := match indexOf? args name with
    | some i => if i + 1 < args.length then args[i+1]! else ""
    | none => ""
  if value == "" then throw s!"Command line argument {name} missing"
  return value

def optionalSwitch (name : String) : ReaderT Arguments (Except String) Bool := do
  let args ← read
  return match (indexOf? args name) with
  | some _ => true
  | none => false

#eval requiredArgument "--input" |>.run ["--input", "foo"]
-- Except.ok "foo"

#eval requiredArgument "--input" |>.run ["foo", "bar"]
-- Except.error "Command line argument --input missing"

#eval optionalSwitch "--help" |>.run ["--help"]
-- Except.ok true

#eval optionalSwitch "--help" |>.run []
-- Except.ok false

/-!
Notice that `throw` was available from the inner `Except` monad. The cool thing is you can switch
this around and get the exact same result using `ExceptT` as the outer monad transformer and
`ReaderM` as the wrapped monad. Try changing requiredArgument to `ExceptT String (ReaderM Arguments) Bool`.

Note: the `|>.` notation is described in [Readers](readers.lean.md#the-reader-solution).

## Adding more layers

Here's the best part about monad transformers. Since the result of a monad transformer is itself a
monad, you can wrap it inside another transformer! Suppose you need to pass in some read only context
like the command line arguments, update some read-write state (like program Config) and optionally
throw an exception, then you could write this:

-/
structure Config where
  help : Bool := false
  verbose : Bool := false
  input : String := ""
  deriving Repr

abbrev CliConfigM := StateT Config (ReaderT Arguments (Except String))

def parseArguments : CliConfigM Bool := do
  let mut config ← get
  if (← optionalSwitch "--help") then
    throw "Usage: example [--help] [--verbose] [--input <input file>]"
  config := { config with
    verbose := (← optionalSwitch "--verbose"),
    input := (← requiredArgument "--input") }
  set config
  return true

def main (args : List String) : IO Unit := do
  let config : Config := { input := "default"}
  match parseArguments |>.run config |>.run args with
  | Except.ok (_, c) => do
    IO.println s!"Processing input '{c.input}' with verbose={c.verbose}"
  | Except.error s => IO.println s

#eval main ["--help"]
-- Usage: example [--help] [--verbose] [--input <input file>]

#eval main ["--input", "foo"]
-- Processing input file 'foo' with verbose=false

#eval main ["--verbose", "--input", "bar"]
-- Processing input 'bar' with verbose=true

/-!
In this example `parseArguments` is actually three stacked monads, `StateM`, `ReaderM`, `Except`. Notice
the convention of abbreviating long monadic types with an alias like `CliConfigM`.

## Monad Lifting

Lean makes it easy to compose functions that use different monads using a concept of automatic monad
lifting.  You already used lifting in the above code, because you were able to compose
`optionalSwitch` which has type `ReaderT Arguments (Except String) Bool` and call it from
`parseArguments` which has a bigger type `StateT Config (ReaderT Arguments (Except String))`.
This "just worked" because Lean did some magic with monad lifting.

To give you a simpler example of this, suppose you have the following function:
-/
def divide (x : Float ) (y : Float): ExceptT String Id Float :=
  if y == 0 then
    throw "can't divide by zero"
  else
    pure (x / y)

#eval divide 6 3 -- Except.ok 2.000000
#eval divide 1 0 -- Except.error "can't divide by zero"
/-!

Notice here we used the `ExceptT` transformer, but we composed it with the `Id` identity monad.
This is then the same as writing `Except String Float` since the identity monad does nothing.

Now suppose you want to count the number of times divide is called and store the result in some
global state:
-/

def divideCounter (x : Float) (y : Float) : StateT Nat (ExceptT String Id) Float := do
  modify fun s => s + 1
  divide x y

#eval divideCounter 6 3 |>.run 0    -- Except.ok (2.000000, 1)
#eval divideCounter 1 0 |>.run 0    -- Except.error "can't divide by zero"

/-!

The `modify` function is a helper which makes it easier to use `modifyGet` from the `StateM` monad.
But something interesting is happening here, `divideCounter` is returning the value of
`divide`, but the types don't match, yet it works?  This is monad lifting in action.

You can see this more clearly with the following test:

-/
def liftTest (x : Except String Float) :
  StateT Nat (Except String) Float := x

#eval liftTest (divide 5 1) |>.run 3 -- Except.ok (5.000000, 3)

/-!

Notice that `liftTest` returned `x` without doing anything to it, yet that matched the return type
`StateT Nat (Except String) Float`.  Monad lifting is provided by monad transformers.  if you
`#print liftTest` you will see that Lean is implementing this using a call to a function named
`monadLift` from the `MonadLift` type class:

```lean,ignore
class MonadLift (m : Type u → Type v) (n : Type u → Type w) where
  monadLift : {α : Type u} → m α → n α
```

So `monadLift` is a function for lifting a computation from an inner `Monad m α ` to an outer `Monad n α`.
You could replace `x` in `liftTest` with `monadLift x` if you want to be explicit about it.

The StateT monad transformer defines an instance of `MonadLift` like this:

```lean
@[inline] protected def lift {α : Type u} (t : m α) : StateT σ m α :=
  fun s => do let a ← t; pure (a, s)

instance : MonadLift m (StateT σ m) := ⟨StateT.lift⟩
```
This means that any monad `m` can be wrapped in a `StateT` monad by using the function
`fun s => do let a ← t; pure (a, s)` that takes state `s`, runs the inner monad action `t`, and
returns the result and the new state in a pair `(a, s)` without making any changes to `s`.

Because `MonadLift` is a type class, Lean can automatically find the required `monadLift`
instances in order to make your code compile and in this way it was able to find the `StateT.lift`
function and use it to wrap the result of `divide` so that the correct type is returned from
`divideCounter`.

If you have an instance `MonadLift m n` that means there is a way to turn a computation that happens
inside of `m` into one that happens inside of `n` and (this is the key part) usually *without* the
instance itself creating any additional data that feeds into the computation. This means you can in
principle declare lifting instances from any monad to any other monad, it does not, however, mean
that you should do this in all cases.  You can get a very nice report on how all this was done by
adding the line `set_option trace.Meta.synthInstance true in` before `divideCounter` and moving you
cursor to the end of the first line after `do`.

This was a lot of detail, but it is very important to understand how monad lifting works because it
is used heavily in Lean programs.

## Transitive lifting

There is also a transitive version of `MonadLift` called `MonadLiftT` which can lift multiple
monad layers at once.  In the following example we added another monad layer with
`ReaderT String ...` and notice that `x` is also automatically lifted to match.

-/
def liftTest2 (x : Except String Float) :
  ReaderT String (StateT Nat (Except String)) Float := x

#eval liftTest2 (divide 5 1) |>.run "" |>.run 3
-- Except.ok (5.000000, 3)

/-!

The ReaderT monadLift is even simpler than the one for StateT:

```lean,ignore
instance  : MonadLift m (ReaderT ρ m) where
  monadLift x := fun _ => x
```

This lift operation creates a function that defines the required `ReaderT` input
argument, but the inner monad doesn't know or care about `ReaderT` so the
monadLift function throws it away with the `_` then calls the inner monad action `x`.
This is a perfectly legal implementation of the `ReaderM` monad.

## Add your own Custom MonadLift

This does not compile:
-/
def main2 : IO Unit := do
  try
    let ret ← divideCounter 5 2 |>.run 0
    IO.println (toString ret)
  catch e =>
    IO.println e

/-!
saying:
```
typeclass instance problem is stuck, it is often due to metavariables
  ToString ?m.4786
```

The reason is `divideCounter` returns the big `StateT Nat (ExceptT String Id) Float` and that type
cannot be automatically lifted into the `main` return type of `IO Unit` unless you give it some
help.

The following custom `MonadLift` solves this problem:

-/
def liftIO (t : ExceptT String Id α) : IO α := do
  match t with
  | .ok r => EStateM.Result.ok r
  | .error s => EStateM.Result.error s

instance : MonadLift (ExceptT String Id) IO where
  monadLift := liftIO

def main3 : IO Unit := do
  try
    let ret ← divideCounter 5 2 |>.run 0
    IO.println (toString ret)
  catch e =>
    IO.println e

#eval main3 -- (2.500000, 1)
/-!

It turns out that the `IO` monad you see in your `main` function is based on the `EStateM.Result` type
which is similar to the `Except` type but it has an additional return value. The `liftIO` function
converts any `Except String α` into `IO α` by simply mapping the ok case of the `Except` to the
`Result.ok` and the error case to the `Result.error`.

## Lifting ExceptT

In the previous [Except](except.lean.md) section you saw functions that `throw` Except
values. When you get all the way back up to your `main` function which has type `IO Unit` you have
the same problem you had above, because `Except String Float` doesn't match even if you use a
`try/catch`.

-/

def main4 : IO Unit := do
  try
    let ret ← divide 5 0
    IO.println (toString ret)  -- lifting happens here.
  catch e =>
    IO.println s!"Unhandled exception: {e}"

#eval main4 -- Unhandled exception: can't divide by zero

/-!

Without the `liftIO` the `(toString ret)` expression would not compile with a similar error:

```
typeclass instance problem is stuck, it is often due to metavariables
  ToString ?m.6007
```

So the general lesson is that if you see an error like this when using monads, check for
a missing `MonadLift`.

## Summary

Now that you know how to combine your monads together, you're almost done with understanding the key
concepts of monads! You could probably go out now and start writing some pretty nice code! But to
truly master monads, you should know how to make your own, and there's one final concept that you
should understand for that. This is the idea of type "laws". Each of the structures you've learned
so far has a series of laws associated with it. And for your instances of these classes to make
sense, they should follow the laws! Check out [Monad Laws](laws.lean.md).
-/


/-
Copyright (c) 2023 Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller
-/
import Lean
import Mathlib.Tactic.Relation.Rfl
import Std.Logic

/-!
# The `congr!` tactic

This is a more powerful version of the `congr` tactic that knows about more congruence lemmas and
can apply to more situations. It is similar to the `congr'` tactic from Mathlib 3.

The `congr!` tactic is used by the `convert` and `convert_to` tactics.

See the syntax docstring for more details.
-/

open Lean Meta Elab Tactic

initialize registerTraceClass `congr!
initialize registerTraceClass `congr!.synthesize

/-- The configuration for the `congr!` tactic. -/
structure Congr!.Config where
  /-- The transparency level to use when applying a congruence theorem.
  By default this is `.reducible`, which prevents unfolding of most definitions. -/
  transparency : TransparencyMode := TransparencyMode.reducible
  /-- The transparency level to use when doing transformations before applying congruence lemmas.
  This includes trying to prove the goal by `rfl` and using the `assumption` tactic.
  By default this is `.reducible`, which prevents unfolding of most definitions. -/
  preTransparency : TransparencyMode := TransparencyMode.reducible
  /-- For passes that synthesize a congruence lemma using one side of the equality,
  we run the pass both for the left-hand side and the right-hand side. If `preferLHS` is `true`
  then we start with the left-hand side.

  This can be used to control which side's definitions are expanded when applying the
  congruence lemma (if `preferLHS = true` then the RHS can be expanded). -/
  preferLHS : Bool := true
  /-- Allow both sides to be a partial applications.
  When false, given an equality `f a b = g x y z` this means we never consider
  proving `f a = g x y`.

  In this case, we might still consider `f = g x` if a pass generates a congruence lemma using the
  left-hand side. Use `sameFun := true` to ensure both sides are applications
  of the same function (making it be similar to the `congr` tactic). -/
  partialApp : Bool := true
  /-- Whether to require that both sides of an equality are applications of defeq functions.
  That is, if true, `f a = g x` is only considered if `f` and `g` are defeq (making it be similar
  to the `congr` tactic). -/
  sameFun : Bool := false
  /-- The maximum number of arguments to consider when doing congruence of function applications.
  For example, with `f a b c = g w x y z`, setting `maxArgs := some 2` means it will only consider
  either `f a b = g w x y` and `c = z` or `f a = g w x`, `b = y`, and `c = z`. Setting
  `maxArgs := none` (the default) means no limit.

  When the functions are dependent, `maxArgs` can prevent congruence from working at all.
  In `Fintype.card α = Fintype.card β`, one needs to have `maxArgs` at `2` or higher since
  there is a `Fintype` instance argument that depends on the first.

  When there aren't such dependency issues, setting `maxArgs := some 1` causes `congr!` to
  do congruence on a single argument at a time. This can be used in conjunction with the
  iteration limit to control exactly how many arguments are to be processed by congruence. -/
  maxArgs : Option Nat := none
  /-- Whether or not `congr!` should generate equalities between types even if the types
  do not look plausibly equal. We have a heuristic in the main congruence generator that types
  `α` and `β` are *plausibly equal* according to the following algorithm:

  - If the types are both propositions, they are plausibly equal (iffs are plausible).
  - If the types are from different universes, they are not plausibly equal.
  - Suppose in whnf we have `α = f a₁ ... aₘ` and `β = g b₁ ... bₘ`. If `f` is not definitionally
    equal to `g` or `m ≠ n`, then `α` and `β` are not plausibly equal.
  - If there is some `i` such that `aᵢ` and `bᵢ` are not plausibly equal, then `α` and `β` are
    not plausibly equal.
  - Otherwise, `α` and `β` are plausibly equal.

  The purpose of this is to prevent considering equalities like `ℕ = ℤ` while allowing equalities
  such as `Fin n = Fin m` or `Subtype p = Subtype q` (so long as these are subtypes of the
  same type).

  The way this is implemented is that the congruence generator, when it is comparing arguments
  in an equality of function applications, marks a function parameter to "fixed" if the provided
  arguments are types that are not plausibly equal. The effect of this is that congruence succeeds
  if those arguments are defeq at `transparency` transparency. -/
  typeEqs : Bool := false
  /-- As a last pass, perform eta expansion of both sides of an equality. For example,
  this transforms a bare `HAdd.hAdd` into `fun x y => x + y`. -/
  etaExpand : Bool := false
  /-- Whether to use the congruence generator that is used by `simp` and `congr`. This generator
  is more strict, and it does not respect all configuration settings. It does respect
  `preferLHS`, `partialApp` and `maxArgs` and transparency settings. It acts as if `sameFun := true`
  and it ignores `typeEqs`. -/
  useCongrSimp : Bool := false

/-- A configuration option that makes `congr!` do the sorts of aggressive unfoldings that `congr`
does while also similarly preventing `congr!` from considering partial applications or congruences
between different functions being applied. -/
def Congr!.Config.unfoldSameFun : Congr!.Config where
  partialApp := false
  sameFun := true
  transparency := .default
  preTransparency := .default

/-- Whether the given number of arguments is allowed to be considered. -/
def Congr!.Config.numArgsOk (config : Config) (numArgs : Nat) : Bool :=
  numArgs ≤ config.maxArgs.getD numArgs

/-- According to the configuration, how many of the arguments in `numArgs` should be considered. -/
def Congr!.Config.maxArgsFor (config : Config) (numArgs : Nat) : Nat :=
  min numArgs (config.maxArgs.getD numArgs)

/--
Try to convert an `Iff` into an `Eq` by applying `iff_of_eq`.
If successful, returns the new goal, and otherwise returns the original `MVarId`.

This may be regarded as being a special case of `Lean.MVarId.liftReflToEq`, specifically for `Iff`.
-/
def Lean.MVarId.iffOfEq (mvarId : MVarId) : MetaM MVarId := do
  let res ← observing? do
    let [mvarId] ← mvarId.apply (mkConst ``iff_of_eq []) | failure
    return mvarId
  return res.getD mvarId

/--
Try to convert an `Eq` into an `Iff` by applying `propext`.
If successful, then returns then new goal, otherwise returns the original `MVarId`.
-/
def Lean.MVarId.propext (mvarId : MVarId) : MetaM MVarId := do
  let res ← observing? do
    -- Avoid applying `propext` if the target is not an equality of `Prop`s.
    -- We don't want a unification specializing `Sort _` to `Prop`.
    let tgt ← withReducible mvarId.getType'
    let some (ty, _, _) := tgt.eq? | failure
    guard ty.isProp
    let [mvarId] ← mvarId.apply (mkConst ``propext []) | failure
    return mvarId
  return res.getD mvarId

/--
Try to close the goal with using `proof_irrel_heq`. Returns whether or not it succeeds.

We need to be somewhat careful not to assign metavariables while doing this, otherwise we might
specialize `Sort _` to `Prop`.
-/
def Lean.MVarId.proofIrrelHeq (mvarId : MVarId) : MetaM Bool :=
  mvarId.withContext do
    let res ← observing? do
      mvarId.checkNotAssigned `proofIrrelHeq
      let tgt ← withReducible mvarId.getType'
      let some (_, lhs, _, rhs) := tgt.heq? | failure
      -- Note: `mkAppM` uses `withNewMCtxDepth`, which we depend on to avoid unification.
      let pf ← mkAppM ``proof_irrel_heq #[lhs, rhs]
      mvarId.assign pf
      return true
    return res.getD false

/--
Try to close the goal using `Subsingleton.elim`. Returns whether or not it succeeds.

We are careful to apply `Subsingleton.elim` in a way that does not assign any metavariables.
This is to prevent the `Subsingleton Prop` instance from being used as justification to specialize
`Sort _` to `Prop`.
-/
def Lean.MVarId.subsingletonElim (mvarId : MVarId) : MetaM Bool :=
  mvarId.withContext do
    let res ← observing? do
      mvarId.checkNotAssigned `subsingletonElim
      let tgt ← withReducible mvarId.getType'
      let some (_, lhs, rhs) := tgt.eq? | failure
      -- Note: `mkAppM` uses `withNewMCtxDepth`, which we depend on to avoid unification.
      let pf ← mkAppM ``Subsingleton.elim #[lhs, rhs]
      mvarId.assign pf
      return true
    return res.getD false

/--
Asserts the given congruence theorem as fresh hypothesis, and then applies it.
Return the `fvarId` for the new hypothesis and the new subgoals.

We apply it with transparency settings specified by `Congr!.Config.transparency`.
-/
private def applyCongrThm?
    (config : Congr!.Config) (mvarId : MVarId) (congrThmType congrThmProof : Expr) :
    MetaM (List MVarId) := do
  trace[congr!] "trying to apply congr lemma {congrThmType}"
  try
    let mvarId ← mvarId.assert (← mkFreshUserName `h_congr_thm) congrThmType congrThmProof
    let (fvarId, mvarId) ← mvarId.intro1P
    let mvarIds ← withTransparency config.transparency <|
      mvarId.apply (mkFVar fvarId) { synthAssignedInstances := false }
    mvarIds.mapM fun mvarId => mvarId.tryClear fvarId
  catch e =>
    withTraceNode `congr! (fun _ => pure m!"failed to apply congr lemma") do
      trace[congr!] "{e.toMessageData}"
    throw e

/--
Create a congruence lemma to prove that `HEq (f a₁ ... aₙ) (f' a₁' ... aₙ')`.
Each argument produces a `HEq aᵢ aᵢ'` hypothesis, but we also supply these hypotheses the
hypotheses that the preceding equalities have been proved (unlike in `mkHCongrWithArity`).
The first two arguments of the resulting theorem are for `f` and `f'`, followed by a proof
of `f = f'`.

When including hypotheses about previous hypotheses, we make use of dependency information
and only include relevant equalities.

The argument `fty` denotes the type of `f`. Returns `(congrThmType, congrThmProof)`.

For the purpose of generating nicer lemmas that have a better chance at something like
`to_additive` rewriting, this function supports generating lemmas where certain parameters
are meant to be fixed.

* If `fixedFun` is `false` (the default) then the lemma starts with three arguments for `f`, `f'`,
and `h : f = f'`. Otherwise, if `fixedFun` is `true` then the lemma starts with just `f`.

* If the `fixedParams` argument has `true` for a particular argument index, then this is a hint
that the congruence lemma may use the same parameter for both sides of the equality. There is
no guarantee -- it respects it if the types are equal for that parameter (i.e., if the parameter
does not depend on non-fixed parameters).
-/
partial def Congr!.mkHCongrThm (fType : Expr) (info : FunInfo)
    (fixedFun : Bool := false) (fixedParams : Array Bool := #[]) :
    MetaM (Expr × Expr) := do
  trace[congr!.synthesize] "ftype: {fType}"
  trace[congr!.synthesize] "deps: {info.paramInfo.map (fun p => p.backDeps)}"
  trace[congr!.synthesize] "fixedFun={fixedFun}, fixedParams={fixedParams}"
  doubleTelescope fType info.getArity fixedParams fun xs ys fixedParams => do
    trace[congr!.synthesize] "xs = {xs}"
    trace[congr!.synthesize] "ys = {ys}"
    trace[congr!.synthesize] "computed fixedParams={fixedParams}"
    let lctx := (← getLCtx) -- checkpoint of local context that only has parameters
    withLocalDeclD `f fType fun ef => withLocalDeclD `f' fType fun pef' => do
    let ef' := if fixedFun then ef else pef'
    withLocalDeclD `e (← mkEq ef ef') fun ee => do
    withNewEqs xs ys fixedParams fun eqs => do
      let fParams := if fixedFun then #[ef] else #[ef, ef', ee]
      let mut hs := fParams     -- parameters to the basic congruence lemma
      let mut hs' := fParams    -- parameters to the richer congruence lemma
      let mut vals' := fParams  -- how to calculate the basic parameters from the richer ones
      for i in [0 : info.getArity] do
        hs := hs.push xs[i]!
        hs' := hs'.push xs[i]!
        vals' := vals'.push xs[i]!
        if let some (eq, eq', val) := eqs[i]! then
          -- Not a fixed argument
          hs := hs.push ys[i]! |>.push eq
          hs' := hs'.push ys[i]! |>.push eq'
          vals' := vals'.push ys[i]! |>.push val
      -- Generate the theorem with respect to the simpler hypotheses
      let congrType ← mkForallFVars hs (← mkHEq (mkAppN ef xs) (mkAppN ef' ys))
      trace[congr!.synthesize] "simple congrType: {congrType}"
      let some proof ← withLCtx lctx (← getLocalInstances) <| trySolve congrType
        | throwError "Internal error when constructing congruence lemma proof"
      -- At this point, `mkLambdaFVars hs' (mkAppN proof vals')` is the richer proof.
      -- We try to precompute some of the arguments using `trySolve`.
      let mut hs'' := #[] -- eq' parameters that are actually used beyond those in `fParams`
      let mut pfVars := #[] -- eq' parameters that can be solved for already
      let mut pfVals := #[] -- the values to use for these parameters
      for i in [0 : info.getArity] do
        hs'' := hs''.push xs[i]!
        if let some (_, eq', _) := eqs[i]! then
          -- Not a fixed argument
          hs'' := hs''.push ys[i]!
          let pf? ← withLCtx lctx (← getLocalInstances) <| trySolve (← inferType eq')
          if let some pf := pf? then
            pfVars := pfVars.push eq'
            pfVals := pfVals.push pf
          else
            hs'' := hs''.push eq'
      -- Take `proof`, abstract the pfVars and provide the solved-for proofs (as an
      -- optimization for proof term size) then abstract the remaining variables.
      -- The `usedOnly` probably has no affect.
      -- Note that since we are doing `proof.beta vals'` there is technically some quadratic
      -- complexity, but it shouldn't be too bad since they're some applications of just variables.
      let proof' ← mkLambdaFVars fParams (← mkLambdaFVars (usedOnly := true) hs''
                    (mkAppN (← mkLambdaFVars pfVars (proof.beta vals')) pfVals))
      return (← inferType proof', proof')
where
  /-- Similar to doing `forallBoundedTelescope` twice, but makes use of the `fixed` array, which
  is used as a hint for whether both variables should be the same. This is only a hint though,
  since we only respect it if the binding domains are equal.
  We affix `'` to the second list of variables, and all the variables are introduced
  with default binder info. Calls `k` with the xs, ys, and a revised `fixed` array -/
  doubleTelescope {α} (fty : Expr) (numVars : Nat) (fixed : Array Bool)
      (k : Array Expr → Array Expr → Array Bool → MetaM α) : MetaM α := do
    let rec loop (i : Nat)
        (ftyx ftyy : Expr) (xs ys : Array Expr) (fixed' : Array Bool) : MetaM α := do
      if i < numVars then
        let ftyx ← whnf ftyx
        let ftyy ← whnf ftyy
        unless ftyx.isForall do
          throwError "doubleTelescope: function doesn't have enough parameters"
        withLocalDeclD ftyx.bindingName! ftyx.bindingDomain! fun fvarx => do
          let ftyx' := ftyx.bindingBody!.instantiate1 fvarx
          if fixed.getD i false && ftyx.bindingDomain! == ftyy.bindingDomain! then
            -- Fixed: use the same variable for both
            let ftyy' := ftyy.bindingBody!.instantiate1 fvarx
            loop (i + 1) ftyx' ftyy' (xs.push fvarx) (ys.push fvarx) (fixed'.push true)
          else
            -- Not fixed: use different variables
            let yname := ftyy.bindingName!.appendAfter "'"
            withLocalDeclD yname ftyy.bindingDomain! fun fvary => do
              let ftyy' := ftyy.bindingBody!.instantiate1 fvary
              loop (i + 1) ftyx' ftyy' (xs.push fvarx) (ys.push fvary) (fixed'.push false)
      else
        k xs ys fixed'
    loop 0 fty fty #[] #[] #[]
  /-- Introduce variables for equalities between the arrays of variables. Uses `fixedParams`
  to control whether to introduce an equality for each pair. The array of triples passed to `k`
  consists of (1) the simple congr lemma HEq arg, (2) the richer HEq arg, and (3) how to
  compute 1 in terms of 2. -/
  withNewEqs {α} (xs ys : Array Expr) (fixedParams : Array Bool)
      (k : Array (Option (Expr × Expr × Expr)) → MetaM α) : MetaM α :=
    let rec loop (i : Nat) (eqs : Array (Option (Expr × Expr × Expr))) := do
      if i < xs.size then
        let x := xs[i]!
        let y := ys[i]!
        if fixedParams[i]! then
          loop (i+1) (eqs.push none)
        else
          let deps := info.paramInfo[i]!.backDeps.filterMap (fun j => eqs[j]!)
          let eq' ← mkForallFVars (deps.map fun (eq, _, _) => eq) (← mkEqHEq x y)
          withLocalDeclD ((`e).appendIndexAfter (i+1)) (← mkEqHEq x y) fun h =>
          withLocalDeclD ((`e').appendIndexAfter (i+1)) eq' fun h' =>
            let v := mkAppN h' (deps.map fun (_, _, val) => val)
            loop (i+1) (eqs.push (h, h', v))
      else
        k eqs
    loop 0 #[]
  /-- Given a type that is a bunch of equalities implying a goal (for example, a basic
  congruence lemma), prove it if possible. Basic congruence lemmas should be provable by this.
  There are some extra tricks for handling arguments to richer congruence lemmas. -/
  trySolveCore (mvarId : MVarId) : MetaM Unit := do
    -- First cleanup the context since we're going to do `substEqs` and we don't want to
    -- accidentally use variables not actually used by the theorem.
    let mvarId ← mvarId.cleanup
    let (_, mvarId) ← mvarId.intros
    let mvarId := (← mvarId.substEqs).getD mvarId
    try mvarId.refl; return catch _ => pure ()
    try mvarId.hrefl; return catch _ => pure ()
    if ← mvarId.proofIrrelHeq then return
    -- Make the goal be an eq and then try `Subsingleton.elim`
    let mvarId ← mvarId.heqOfEq
    if ← mvarId.subsingletonElim then return
    -- We have no more tricks.
    throwError "was not able to solve for proof"
  trySolve (ty : Expr) : MetaM (Option Expr) := observing? do
    let mvar ← mkFreshExprMVar ty
    trace[congr!.synthesize] "trySolve {mvar.mvarId!}"
    -- The proofs we generate shouldn't require unfolding anything.
    withReducible <| trySolveCore mvar.mvarId!
    trace[congr!.synthesize] "trySolve success!"
    let pf ← instantiateMVars mvar
    return pf

/-- Returns whether or not it's reasonable to consider an equality between types  `ty1` and `ty2`.
The heuristic is the following:

- If `ty1` and `ty2` are in `Prop`, then yes.
- If in whnf both `ty1` and `ty2` have the same head and if (recursively) it's reasonable to
  consider an equality between corresponding type arguments, then yes.
- Otherwise, no.

This helps keep congr from going too far and generating hypotheses like `ℝ = ℤ`.

To keep things from going out of control, there is a `maxDepth`. Additionally, if we do the check
with `maxDepth = 0` then the heuristic answers "no". -/
def Congr!.possiblyEqualTypes (ty1 ty2 : Expr) (maxDepth : Nat := 5) : MetaM Bool :=
  match maxDepth with
  | 0 => return false
  | maxDepth + 1 => do
    -- Props are possibly equal
    if (← isProp ty1) && (← isProp ty2) then
      return true
    -- Types from different type universes are not possibly equal
    unless ← withNewMCtxDepth <| isDefEq (← inferType ty1) (← inferType ty2) do
      return false
    -- Now put the types into whnf, check they have the same head, and then recurse on arguments
    let ty1 ← whnfD ty1
    let ty2 ← whnfD ty2
    unless ← withNewMCtxDepth <| isDefEq ty1.getAppFn ty2.getAppFn do
      return false
    for arg1 in ty1.getAppArgs, arg2 in ty2.getAppArgs do
      if (← isType arg1) && (← isType arg2) then
        unless ← possiblyEqualTypes arg1 arg2 maxDepth do
          return false
    return true

/--
This is like `Lean.MVarId.hcongr?` but (1) looks at both sides when generating the congruence lemma
and (2) inserts additional hypotheses from equalities from previous arguments.

It uses `Congr!.mkHCongrThm` to generate the congruence lemmas.

If the goal is an `Eq`, uses `eq_of_heq` first.

As a backup strategy, it uses the LHS/RHS method like in `Lean.MVarId.congrSimp?`
(where `Congr!.Config.preferLHS` determines which side to try first). This uses a particular side
of the target, generates the congruence lemma, then tries applying it. This can make progress
with higher transparency settings. To help the unifier, in this mode it assumes both sides have the
exact same function.
-/
partial
def Lean.MVarId.smartHCongr? (config : Congr!.Config) (mvarId : MVarId) :
    MetaM (Option (List MVarId)) :=
  mvarId.withContext do
    mvarId.checkNotAssigned `congr!
    commitWhenSome? do
      let mvarId ← mvarId.eqOfHEq
      let some (_, lhs, _, rhs) := (← withReducible mvarId.getType').heq? | return none
      if let some mvars ← loop mvarId 0 lhs rhs [] [] then
        return mvars
      -- The "correct" behavior failed. However, it's often useful
      -- to apply congruence lemmas while unfolding definitions, which is what the
      -- basic `congr` tactic does due to limitations in how congruence lemmas are generated.
      -- We simulate this behavior here by generating congruence lemmas for the LHS and RHS and
      -- then applying them.
      trace[congr!] "Default smartHCongr? failed, trying LHS/RHS method"
      let (fst, snd) := if config.preferLHS then (lhs, rhs) else (rhs, lhs)
      if let some mvars ← forSide mvarId fst then
        return mvars
      else if let some mvars ← forSide mvarId snd then
        return mvars
      else
        return none
where
  loop (mvarId : MVarId) (numArgs : Nat) (lhs rhs : Expr) (lhsArgs rhsArgs : List Expr) :
      MetaM (Option (List MVarId)) :=
    match lhs.cleanupAnnotations, rhs.cleanupAnnotations with
    | .app f a, .app f' b => do
      if not (config.numArgsOk (numArgs + 1)) then
        return none
      let lhsArgs' := a :: lhsArgs
      let rhsArgs' := b :: rhsArgs
      -- We try to generate a theorem for the maximal number of arguments
      if let some mvars ← loop mvarId (numArgs + 1) f f' lhsArgs' rhsArgs' then
        return mvars
      -- That failing, we now try for the present number of arguments.
      if not config.partialApp && f.isApp && f'.isApp then
        -- It's a partial application on both sides though.
        return none
      -- The congruence generator only handles the case where both functions have
      -- definitionally equal types.
      unless ← withNewMCtxDepth <| isDefEq (← inferType f) (← inferType f') do
        return none
      let funDefEq ← withReducible <| withNewMCtxDepth <| isDefEq f f'
      if config.sameFun && not funDefEq then
        return none
      let info ← getFunInfoNArgs f (numArgs + 1)
      let mut fixed : Array Bool := #[]
      for larg in lhsArgs', rarg in rhsArgs' do
        if not config.typeEqs &&
            (← isType larg) && (← isType rarg) && not (← Congr!.possiblyEqualTypes larg rarg) then
          fixed := fixed.push true
        else
          fixed := fixed.push (← withReducible <| withNewMCtxDepth <| isDefEq larg rarg)
      let (congrThm, congrProof) ← Congr!.mkHCongrThm (← inferType f) info
                                    (fixedFun := funDefEq) (fixedParams := fixed)
      -- Now see if the congruence theorem actually applies in this situation by applying it!
      let (congrThm', congrProof') :=
        if funDefEq then
          (congrThm.bindingBody!.instantiate1 f, congrProof.beta #[f])
        else
          (congrThm.bindingBody!.bindingBody!.instantiateRev #[f, f'],
           congrProof.beta #[f, f'])
      observing? <| applyCongrThm? config mvarId congrThm' congrProof'
    | _, _ => return none
  forSide (mvarId : MVarId) (side : Expr) : MetaM (Option (List MVarId)) := do
    let side := side.cleanupAnnotations
    if not side.isApp then return none
    let numArgs := config.maxArgsFor side.getAppNumArgs
    if not config.partialApp && numArgs < side.getAppNumArgs then
        return none
    let mut f := side
    for _ in [:numArgs] do
      f := f.appFn!'
    let info ← getFunInfoNArgs f numArgs
    let mut fixed : Array Bool := #[]
    if not config.typeEqs then
      -- We need some strategy for fixed parameters to keep `forSide` from applying
      -- in cases where `Congr!.possiblyEqualTypes` suggested not to in the previous pass.
      for pinfo in info.paramInfo, arg in side.getAppArgs do
        if pinfo.isProp || not (← isType arg) then
          fixed := fixed.push false
        else if not pinfo.backDeps.isEmpty then
          -- We can't immediately say such an equality is a bad idea, because the argument might
          -- be something like `Fin n`.
          -- Though, if the argument isn't explicit it probably would be surprising to generate
          -- an equality.
          fixed := fixed.push (pinfo.binderInfo != .default)
        else
          fixed := fixed.push true
    let (congrThm, congrProof) ←
      Congr!.mkHCongrThm (← inferType f) info (fixedFun := true) (fixedParams := fixed)
    let congrThm' := congrThm.bindingBody!.instantiate1 f
    let congrProof' := congrProof.beta #[f]
    observing? <| applyCongrThm? config mvarId congrThm' congrProof'

/--
Like `Lean.MVarId.congr?` but instead of using only the congruence lemma associated to the LHS,
it tries the RHS too, in the order specified by `config.preferLHS`.

It uses `Lean.Meta.mkCongrSimp?` to generate a congruence lemma, like in the `congr` tactic.

Applies the congruence generated congruence lemmas according to `config`.
-/
def Lean.MVarId.congrSimp? (config : Congr!.Config) (mvarId : MVarId) :
    MetaM (Option (List MVarId)) :=
  mvarId.withContext do
    unless config.useCongrSimp do return none
    mvarId.checkNotAssigned `congrSimp?
    let some (_, lhs, rhs) := (← withReducible mvarId.getType').eq? | return none
    let (fst, snd) := if config.preferLHS then (lhs, rhs) else (rhs, lhs)
    if let some mvars ← forSide mvarId fst then
      return mvars
    else if let some mvars ← forSide mvarId snd then
      return mvars
    else
      return none
where
  forSide (mvarId : MVarId) (side : Expr) : MetaM (Option (List MVarId)) :=
    commitWhenSome? do
      let side := side.cleanupAnnotations
      if not side.isApp then return none
      let numArgs := config.maxArgsFor side.getAppNumArgs
      if not config.partialApp && numArgs < side.getAppNumArgs then
        return none
      let mut f := side
      for _ in [:numArgs] do
        f := f.appFn!'
      let some congrThm ← mkCongrSimpNArgs f numArgs
        | return none
      observing? <| applyCongrThm? config mvarId congrThm.type congrThm.proof
  /-- Like `mkCongrSimp?` but takes in a specific arity. -/
  mkCongrSimpNArgs (f : Expr) (nArgs : Nat) : MetaM (Option CongrTheorem) := do
    let f := (← instantiateMVars f).cleanupAnnotations
    let info ← getFunInfoNArgs f nArgs
    mkCongrSimpCore? f info
      (← getCongrSimpKinds f info) (subsingletonInstImplicitRhs := false)

/--
Try applying user-provided congruence lemmas. If any are applicable,
returns a list of new goals.

Tries a congruence lemma associated to the LHS and then, if that failed, the RHS.
-/
def Lean.MVarId.userCongr? (config : Congr!.Config)  (mvarId : MVarId) :
    MetaM (Option (List MVarId)) :=
  mvarId.withContext do
    mvarId.checkNotAssigned `userCongr?
    let some (lhs, rhs) := (← withReducible mvarId.getType').eqOrIff? | return none
    let (fst, snd) := if config.preferLHS then (lhs, rhs) else (rhs, lhs)
    if let some mvars ← forSide fst then
      return mvars
    else if let some mvars ← forSide snd then
      return mvars
    else
      return none
where
  forSide (side : Expr) : MetaM (Option (List MVarId)) := do
    let side := side.cleanupAnnotations
    if not side.isApp then return none
    let some name := side.getAppFn.constName? | return none
    let congrTheorems := (← getSimpCongrTheorems).get name
    -- Note: congruence theorems are provided in decreasing order of priority.
    for congrTheorem in congrTheorems do
      let res ← observing? do
        let cinfo ← getConstInfo congrTheorem.theoremName
        let us ← cinfo.levelParams.mapM fun _ => mkFreshLevelMVar
        let proof := mkConst congrTheorem.theoremName us
        let ptype ← instantiateTypeLevelParams cinfo us
        applyCongrThm? config mvarId ptype proof
      if let some mvars := res then
        return mvars
    return none

/-- Helper theorem for `Lean.MVar.liftReflToEq`. -/
theorem Lean.MVarId.rel_of_eq_and_refl {R : α → α → Prop} (hxy : x = y) (h : R x x) :
    R x y := hxy ▸ h

/--
Use a `refl`-tagged lemma to convert the goal into an `Eq`. If this can't be done, returns
the original `MVarId`.
-/
def Lean.MVarId.liftReflToEq (mvarId : MVarId) : MetaM MVarId := do
  mvarId.checkNotAssigned `liftReflToEq
  let tgt ← withReducible mvarId.getType'
  let .app (.app rel _) _ := tgt | return mvarId
  if rel.isAppOf `Eq then
    -- No need to lift Eq to Eq
    return mvarId
  let reflLemmas ← (Mathlib.Tactic.reflExt.getState (← getEnv)).getMatch rel
  for lem in reflLemmas do
    let res ← observing? do
      -- First create an equality relating the LHS and RHS
      -- and reduce the goal to proving that LHS is related to LHS.
      let [mvarIdEq, mvarIdR] ←
            mvarId.apply (← mkConstWithFreshMVarLevels ``Lean.MVarId.rel_of_eq_and_refl)
        | failure
      -- Then fill in the proof of the latter by reflexivity.
      let [] ← mvarIdR.apply (← mkConstWithFreshMVarLevels lem) | failure
      return mvarIdEq
    if let some mvarId := res then
      return mvarId
  return mvarId

/--
Try to apply `pi_congr`. This is similar to `Lean.MVar.congrImplies?`.
-/
def Lean.MVarId.congrPi? (mvarId : MVarId) : MetaM (Option (List MVarId)) :=
  observing? do withReducible <| mvarId.apply (← mkConstWithFreshMVarLevels `pi_congr)

/--
Try to apply `funext`, but only if it is an equality of two functions where at least one is
a lambda expression.

One thing this check prevents is accidentally applying `funext` to a set equality, but also when
doing congruence we don't want to apply `funext` unnecessarily.
-/
def Lean.MVarId.obviousFunext? (mvarId : MVarId) : MetaM (Option (List MVarId)) :=
  mvarId.withContext <| observing? do
    let some (_, lhs, rhs) := (← withReducible mvarId.getType').eq? | failure
    if not lhs.cleanupAnnotations.isLambda && not rhs.cleanupAnnotations.isLambda then failure
    mvarId.apply (← mkConstWithFreshMVarLevels ``funext)

/--
Try to apply `Function.hfunext`, returning the new goals if it succeeds.
Like `Lean.MVarId.obviousFunext?`, we only do so if at least one side of the `HEq` is a lambda.
This prevents unfolding of things like `Set`.

Need to have `Mathlib.Logic.Function.Basic` imported for this to succeed.
-/
def Lean.MVarId.obviousHfunext? (mvarId : MVarId) : MetaM (Option (List MVarId)) :=
  mvarId.withContext <| observing? do
    let some (_, lhs, _, rhs) := (← withReducible mvarId.getType').heq? | failure
    if not lhs.cleanupAnnotations.isLambda && not rhs.cleanupAnnotations.isLambda then failure
    mvarId.apply (← mkConstWithFreshMVarLevels `Function.hfunext)

/--
Try to apply `Subsingleton.helim` if the goal is a `HEq`. Tries synthesizing a `Subsingleton`
instance for both the LHS and the RHS.

If successful, this reduces proving `@HEq α x β y` to proving `α = β`.
-/
def Lean.MVarId.subsingletonHelim? (mvarId : MVarId) : MetaM (Option (List MVarId)) :=
  mvarId.withContext <| observing? do
    mvarId.checkNotAssigned `subsingletonHelim
    let some (α, lhs, β, rhs) := (← withReducible mvarId.getType').heq? | failure
    let eqmvar ← mkFreshExprSyntheticOpaqueMVar (← mkEq α β) (← mvarId.getTag)
    -- First try synthesizing using the left-hand side for the Subsingleton instance
    if let some pf ← observing? (mkAppM ``Subsingleton.helim #[eqmvar, lhs, rhs]) then
      mvarId.assign pf
      return [eqmvar.mvarId!]
    let eqsymm ← mkAppM ``Eq.symm #[eqmvar]
    -- Second try synthesizing using the right-hand side for the Subsingleton instance
    if let some pf ← observing? (mkAppM ``Subsingleton.helim #[eqsymm, rhs, lhs]) then
      mvarId.assign (← mkAppM ``HEq.symm #[pf])
      return [eqmvar.mvarId!]
    failure

/--
A list of all the congruence strategies used by `Lean.MVarId.congrCore!`.
-/
def Lean.MVarId.congrPasses! :
    List (String × (Congr!.Config → MVarId → MetaM (Option (List MVarId)))) :=
  [("user congr", userCongr?),
   ("hcongr lemma", smartHCongr?),
   ("congr simp lemma", congrSimp?),
   ("Subsingleton.helim", fun _ => subsingletonHelim?),
   ("obvious funext", fun _ => obviousFunext?),
   ("obvious hfunext", fun _ => obviousHfunext?),
   ("congr_implies", fun _ => congrImplies?),
   ("congr_pi", fun _ => congrPi?)]

/--
Does `Lean.MVarId.intros` but then cleans up the introduced hypotheses, removing anything
that is trivial.

Cleaning up includes:
- deleting hypotheses of the form `HEq x x`, `x = x`, and `x ↔ x`.
- deleting Prop hypotheses that are already in the local context.
- converting `HEq x y` to `x = y` if possible.
- converting `x = y` to `x ↔ y` if possible.
-/
partial
def Lean.MVarId.introsClean (mvarId : MVarId) : MetaM (Array FVarId × MVarId) :=
  loop #[] mvarId
where
  fvarEqOfHEq (mvarId : MVarId) (fvarId : FVarId) : MetaM (Option (FVarId × MVarId)) :=
    observing? <| mvarId.withContext do
      let pf ← mkEqOfHEq (.fvar fvarId)
      let decl ← fvarId.getDecl
      let mvarId ← mvarId.assert decl.userName (← inferType pf) pf
      let (fvarId', mvarId) ← mvarId.intro1
      return (fvarId', ← mvarId.clear fvarId)
  fvarIffOfEq (mvarId : MVarId) (fvarId : FVarId) : MetaM (Option (FVarId × MVarId)) :=
    observing? <| mvarId.withContext do
      let pf ← mkIffOfEq (.fvar fvarId)
      let decl ← fvarId.getDecl
      let mvarId ← mvarId.assert decl.userName (← inferType pf) pf
      let (fvarId', mvarId) ← mvarId.intro1
      return (fvarId', ← mvarId.clear fvarId)
  loop (fvars : Array FVarId) (mvarId : MVarId) : MetaM (Array FVarId × MVarId) :=
    mvarId.withContext do
      let ty ← withReducible <| mvarId.getType'
      if ty.isForall then
        let (fvarId, mvarId) ← mvarId.intro1
        if not ty.isArrow then
          return ← loop (fvars.push fvarId) mvarId
        let (fvarId, mvarId) := (← fvarEqOfHEq mvarId fvarId).getD (fvarId, mvarId)
        let (fvarId, mvarId) := (← fvarIffOfEq mvarId fvarId).getD (fvarId, mvarId)
        mvarId.withContext do
          let ty ← instantiateMVars (← fvarId.getType)
          if (← isTrivialType ty)
              || (← getLCtx).any (fun decl => decl.fvarId != fvarId && decl.type == ty) then
            let mvarId ← mvarId.clear fvarId
            return ← loop fvars mvarId
          return ← loop (fvars.push fvarId) mvarId
      else
        return (fvars, mvarId)
  isTrivialType (ty : Expr) : MetaM Bool := do
    let ty ← instantiateMVars ty
    unless ← Meta.isProp ty do
      return false
    if let some (lhs, rhs) := ty.eqOrIff? then
      if lhs.cleanupAnnotations == rhs.cleanupAnnotations then
        return true
    if let some (α, lhs, β, rhs) := ty.heq? then
      if α.cleanupAnnotations == β.cleanupAnnotations
          && lhs.cleanupAnnotations == rhs.cleanupAnnotations then
        return true
    return false

/-- Convert a goal into an `Eq` goal if possible (since we have a better shot at those).
Also try to dispatch the goal using an assumption, `Subsingleton.Elim`, or definitional equality. -/
def Lean.MVarId.preCongr! (mvarId : MVarId) : MetaM (Option MVarId) := do
  -- Congr lemmas might have created additional hypotheses.
  let (_, mvarId) ← mvarId.introsClean
  -- Next, turn `HEq` and `Iff` into `Eq`
  let mvarId ← mvarId.heqOfEq
  -- This is a good time to check whether we have a relevant hypothesis.
  if ← mvarId.assumptionCore then return none
  let mvarId ← mvarId.iffOfEq
  -- Now try definitional equality. No need to try `mvarId.hrefl` since we already did `heqOfEq`.
  -- We allow synthetic opaque metavariables to be assigned to fill in `x = _` goals that might
  -- appear (for example, due to using `convert` with placeholders).
  try withAssignableSyntheticOpaque mvarId.refl; return none catch _ => pure ()
  -- Now we go for (heterogenous) equality via subsingleton considerations
  if ← mvarId.subsingletonElim then return none
  if ← mvarId.proofIrrelHeq then return none
  return some mvarId

def Lean.MVarId.congrCore! (config : Congr!.Config) (mvarId : MVarId) :
    MetaM (Option (List MVarId)) := do
  /- We do `liftReflToEq` here rather than in `preCongr!` since we don't want it to stick
     if there are no relevant congr lemmas. -/
  mvarId.checkNotAssigned `congr!
  let s ← saveState
  let mvarId ← mvarId.liftReflToEq
  for (passName, pass) in congrPasses! do
    try
      if let some mvarIds ← pass config mvarId then
        trace[congr!] "pass succeded: {passName}"
        return mvarIds
    catch e =>
      throwTacticEx `congr! mvarId
        m!"internal error in congruence pass {passName}, {e.toMessageData}"
    if ← mvarId.isAssigned then
      throwTacticEx `congr! mvarId
        s!"congruence pass {passName} assigned metavariable but failed"
  restoreState s
  trace[congr!] "no passes succeeded"
  return none

/-- A pass to clean up after `Lean.MVarId.preCongr!` and `Lean.MVarId.congrCore!`. -/
def Lean.MVarId.postCongr! (option : Congr!.Config) (mvarId : MVarId) : MetaM (Option MVarId) := do
  let some mvarId ← mvarId.preCongr! | return none
  -- Convert `p = q` to `p ↔ q`, which is likely the more useful form:
  let mvarId ← mvarId.propext
  if ← mvarId.assumptionCore then return none
  if option.etaExpand then
    if let some (_, lhs, rhs) := (← withReducible mvarId.getType').eq? then
      let lhs' ← Meta.etaExpand lhs
      let rhs' ← Meta.etaExpand rhs
      return ← mvarId.change (← mkEq lhs' rhs')
  return mvarId

/-- A more insistent version of `Lean.MVarId.congrN`.
See the documentation on the `congr!` syntax.

The `depth?` argument controls the depth of the recursion. If `none`, then it uses a reasonably
large bound that is linear in the expression depth. -/
def Lean.MVarId.congrN! (mvarId : MVarId)
    (depth? : Option Nat := none) (config : Congr!.Config := {}) : MetaM (List MVarId) := do
  let ty ← withReducible <| mvarId.getType'
  -- A reasonably large yet practically bounded default recursion depth.
  let defaultDepth := max 1000000 (8 * (1 + ty.approxDepth.toNat))
  let depth := depth?.getD defaultDepth
  let (_, s) ← go depth depth mvarId |>.run #[]
  return s.toList
where
  post (mvarId : MVarId) : StateRefT (Array MVarId) MetaM Unit := do
    let some mvarId ← mvarId.postCongr! config
        | do trace[congr!] "Dispatched goal by post-processing step."
             return
    modify (·.push mvarId)
  go (depth : Nat) (n : Nat) (mvarId : MVarId) : StateRefT (Array MVarId) MetaM Unit := do
    let some mvarId ← withTransparency config.preTransparency mvarId.preCongr! | return
    match n with
      | 0 =>
        trace[congr!] "At level {depth - n}, doing post-processing. {mvarId}"
        post mvarId
      | n + 1 =>
        trace[congr!] "At level {depth - n}, trying congrCore!. {mvarId}"
        let some mvarIds ← mvarId.congrCore! config
          | post mvarId
        mvarIds.forM (go depth n)

namespace Congr!

declare_config_elab elabConfig Config

/--
Equates pieces of the left-hand side of a goal to corresponding pieces of the right-hand side by
recursively applying congruence lemmas. For example, with `⊢ f as = g bs` we could get
two goals `⊢ f = g` and `⊢ as = bs`.

The `congr!` tactic is similar to `congr` but is more insistent in trying to equate left-hand sides
to right-hand sides of goals. Here is a list of things it can try:

- If `R` in `⊢ R x y` is a reflexive relation, it will convert the goal to `⊢ x = y` if possible.
  The list of reflexive relations is maintained using the `@[refl]` attribute.
  As a special case, `⊢ p ↔ q` is converted to `⊢ p = q` during congruence processing and then
  returned to `⊢ p ↔ q` form at the end.

- If there is a user congruence lemma associated to the goal (for instance, a `@[congr]`-tagged
  lemma applying to `⊢ List.map f xs = List.map g ys`), then it will use that.

- It uses a congruence lemma generator at least as capable as the one used by `congr` and `simp`.
  If there is a subexpression that can be rewritten by `simp`, then `congr!` should be able
  to generate an equality for it.

- It uses `implies_congr` and `pi_congr` to do congruences of pi types.

- Before applying congruences, it will run the `intros` tactic automatically.
  The introduced variables can be given names using the `rename_i` tactic as needed.
  This helps when user congruence lemmas are applied, since they often provide
  additional hypotheses.

- When there is an equality between functions, so long as at least one is obviously a lambda, we
  apply `funext` or `Function.hfunext`, which allows for congruence of lambda bodies.

- It can try to close goals using a few strategies, including checking
  definitional equality, trying to apply `Subsingleton.elim` or `proof_irrel_heq`, and using the
  `assumption` tactic.

The optional parameter is the depth of the recursive applications.
This is useful when `congr!` is too aggressive in breaking down the goal.
For example, given `⊢ f (g (x + y)) = f (g (y + x))`,
`congr!` produces the goals `⊢ x = y` and `⊢ y = x`,
while `congr! 2` produces the intended `⊢ x + y = y + x`.

The `congr!` tactic also takes a configuration option, for example
```lean
congr! (config := {transparency := .default}) 2
```
This overrides the default, which is to apply congruence lemmas at reducible transparency.

The `congr!` tactic is aggressive with equating two sides of everything. There is a predefined
configuration that uses a different strategy:
Try
```lean
congr! (config := .unfoldSameFun)
```
This only allows congruences between functions applications of definitionally equal functions,
and it applies congruence lemmas at default transparency (rather than just reducible).
This is somewhat like `congr`.

See `Congr!.Config` for all options.
-/
syntax (name := congr!) "congr!" (Parser.Tactic.config)? (num)? : tactic

elab_rules : tactic
| `(tactic| congr! $[$cfg:config]? $[$n]?) => do
  let config ← elabConfig (mkOptionalNode cfg)
  liftMetaTactic fun g ↦
    let depth := n.map (·.getNat)
    g.congrN! depth config

end Congr!


import phase2.flexible_completion
import phase2.reduction
import phase2.refine

open quiver set sum with_bot
open_locale classical

universe u

namespace con_nf

namespace struct_approx
variables [params.{u}] {α : Λ} [position_data.{}] [phase_2_assumptions α] {β : Iic α}
  {γ : Iic α} {δ ε : Iio α} (hδ : (δ : Λ) < γ) (hε : (ε : Λ) < γ) (hδε : δ ≠ ε)
  {A : path (β : type_index) γ} {t : tangle δ}
  (H : hypothesis ⟨inr (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t).to_near_litter,
    (A.cons (coe_lt hε)).cons (bot_lt_coe _)⟩)

/-- The inductive hypothesis used for proving freedom of action:
Every free approximation exactly approximates some allowable permutation. -/
def foa_ih (β : Iic α) : Prop :=
∀ (π₀ : struct_approx β), π₀.free → ∃ (π : allowable β), π₀.exactly_approximates π.to_struct_perm

/-- A proof-relevant statement that `L` is `A`-inflexible (excluding `ε = ⊥`). -/
structure inflexible_coe (L : litter) (A : extended_index β) :=
(γ : Iic α) (δ ε : Iio α) (hδ : (δ : Λ) < γ) (hε : (ε : Λ) < γ) (hδε : δ ≠ ε)
(B : quiver.path (β : type_index) γ) (t : tangle δ)
(hL : L = f_map (coe_ne_coe.mpr $ coe_ne' hδε) t)
(hA : A = (B.cons (coe_lt hε)).cons (bot_lt_coe _))

instance (L : litter) (A : extended_index β) : subsingleton (inflexible_coe L A) :=
begin
  constructor,
  rintros ⟨γ₁, δ₁, ε₁, hδ₁, hε₁, hδε₁, B₁, t₁, rfl, rfl⟩
    ⟨γ₂, δ₂, ε₂, hδ₂, hε₂, hδε₂, B₂, t₂, hL₂, hA₂⟩,
  cases subtype.coe_injective (coe_eq_coe.mp (path.obj_eq_of_cons_eq_cons hA₂)),
  cases subtype.coe_injective (coe_eq_coe.mp (path.obj_eq_of_cons_eq_cons
    (path.heq_of_cons_eq_cons hA₂).eq)),
  cases (path.heq_of_cons_eq_cons (path.heq_of_cons_eq_cons hA₂).eq).eq,
  have h₁ := f_map_β (coe_ne_coe.mpr $ coe_ne' hδε₁) t₁,
  have h₂ := f_map_β (coe_ne_coe.mpr $ coe_ne' hδε₂) t₂,
  rw [hL₂, h₂] at h₁,
  cases subtype.coe_injective (coe_eq_coe.mp h₁),
  cases f_map_injective _ hL₂,
  refl,
end

/-- A proof-relevant statement that `L` is `A`-inflexible, where `δ = ⊥`. -/
structure inflexible_bot (L : litter) (A : extended_index β) :=
(γ : Iic α) (ε : Iio α) (hε : (ε : Λ) < γ)
(B : quiver.path (β : type_index) γ) (a : atom)
(hL : L = f_map (show (⊥ : type_index) ≠ (ε : Λ), from bot_ne_coe) a)
(hA : A = (B.cons (coe_lt hε)).cons (bot_lt_coe _))

instance (L : litter) (A : extended_index β) : subsingleton (inflexible_bot L A) :=
begin
  constructor,
  rintros ⟨γ₁, ε₁, hε₁, B₁, a₁, rfl, rfl⟩ ⟨γ₂, ε₂, hε₂, B₂, a₂, hL₂, hA₂⟩,
  cases subtype.coe_injective (coe_eq_coe.mp (path.obj_eq_of_cons_eq_cons hA₂)),
  cases subtype.coe_injective (coe_eq_coe.mp (path.obj_eq_of_cons_eq_cons
    (path.heq_of_cons_eq_cons hA₂).eq)),
  cases (path.heq_of_cons_eq_cons (path.heq_of_cons_eq_cons hA₂).eq).eq,
  cases f_map_injective _ hL₂,
  refl,
end

lemma inflexible_bot_inflexible_coe {L : litter} {A : extended_index β} :
  inflexible_bot L A → inflexible_coe L A → false :=
begin
  rintros ⟨γ₁, ε₁, hε₁, B₁, a₁, rfl, rfl⟩ ⟨γ₂, δ₂, ε₂, hδ₂, hε₂, hδε₂, B₂, t₂, hL₂, hA₂⟩,
  have h₁ := f_map_β (show (⊥ : type_index) ≠ (ε₁ : Λ), from bot_ne_coe) a₁,
  have h₂ := f_map_β (coe_ne_coe.mpr $ coe_ne' hδε₂) t₂,
  rw [hL₂, h₂] at h₁,
  cases h₁,
end

lemma inflexible_coe.δ_lt_β {L : litter} {A : extended_index β} (h : inflexible_coe L A) :
  (h.δ : Λ) < β :=
h.hδ.trans_le (show _, from coe_le_coe.mp (le_of_path h.B))

lemma inflexible_bot.constrains {L : litter} {A : extended_index β} (h : inflexible_bot L A) :
  relation.trans_gen (constrains α β)
    (inl h.a, (h.B.cons (bot_lt_coe _))) (inr L.to_near_litter, A) :=
begin
  have := constrains.f_map_bot h.hε h.B h.a,
  rw [← h.hL, ← h.hA] at this,
  exact relation.trans_gen.single this,
end

class freedom_of_action_hypothesis (β : Iic α) :=
(freedom_of_action_of_lt : ∀ γ < β, foa_ih γ)

export freedom_of_action_hypothesis (freedom_of_action_of_lt)

variable [freedom_of_action_hypothesis β]

/-- For the support map of `t`, we use everything that constrains `t`. -/
def inflexible_support {L : litter} {A : extended_index β} (h : inflexible_coe L A) :
  set (support_condition h.δ) :=
(λ c, (c.1, (h.B.cons (coe_lt h.hδ)).comp c.2)) ⁻¹'
{c | relation.trans_gen (constrains α β) c
  (inr (f_map (coe_ne_coe.mpr $ coe_ne' h.hδε) h.t).to_near_litter,
    (h.B.cons (coe_lt h.hε)).cons (bot_lt_coe _))}

lemma inflexible_support_small {L : litter} {A : extended_index β} (h : inflexible_coe L A) :
  small (inflexible_support h) :=
begin
  refine lt_of_le_of_lt (cardinal.mk_preimage_of_injective _ _ _) _,
  { intros c d h,
    simp only [prod.mk.inj_iff, path.comp_inj_right] at h,
    exact prod.ext h.1 h.2, },
  { refine small.mono _ (reduction_small' α (small_singleton
    (inr (f_map (coe_ne_coe.mpr $ coe_ne' h.hδε) h.t).to_near_litter,
      (h.B.cons (coe_lt h.hε)).cons (bot_lt_coe _)))),
    intros c hc,
    exact ⟨_, rfl, hc.to_refl⟩, },
end

lemma inflexible_support_supports_f_map {π : allowable β} {γ : Iic α} {δ ε : Iio α}
  (hδ : (δ : Λ) < γ) (hε : (ε : Λ) < γ) (hδε : δ ≠ ε)
  {B : path (β : type_index) γ} {t : tangle δ}
  (hπ : ∀ ⦃a : support_condition ↑β⦄,
    a ≺[α] (inr (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t).to_near_litter,
      (B.cons (coe_lt hε)).cons (bot_lt_coe _)) → π • a = a)
  (hc : (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t).to_near_litter.is_litter →
    inflexible α (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t)
      ((B.cons (coe_lt hε)).cons (bot_lt_coe _))) :
  (allowable.derivative (show path ((β : Iic_index α) : type_index) (ε : Iic_index α),
      from B.cons (coe_lt hε)) π : allowable (ε : Iic_index α)) •
    f_map (coe_ne_coe.mpr $ coe_ne' hδε) t =
    f_map (coe_ne_coe.mpr $ coe_ne' hδε) t :=
begin
  have h₁ := allowable.derivative_cons (show path ((β : Iic_index α) : type_index)
    (γ : Iic_index α), from B) (coe_lt hε),
  have h₂ := @smul_f_map _ _ _ _ (γ : Iic_index α) (δ : Iio_index α) ε
    (coe_lt hδ) (coe_lt hε) (Iio.coe_injective.ne hδε)
    (allowable.derivative (show path ((β : Iic_index α) : type_index)
      (γ : Iic_index α), from B) π) t,
  rw h₁,
  refine h₂.trans (congr_arg _ _),
  refine (designated_support t).supports _ (λ c hc, _),
  have := congr_arg prod.fst (hπ (constrains.f_map hδ hε hδε B t c hc)),
  obtain ⟨c, C⟩ := c,
  refine prod.ext (eq.trans _ this) rfl,
  rw ← allowable.to_struct_perm_smul at this ⊢,
  rw [← phase_2_assumptions.allowable_derivative_eq, ← allowable.derivative_to_struct_perm],
  change _ • _ = _ • _,
  simp only [struct_perm.derivative_derivative, path.comp_cons, path.comp_nil],
end

-- TODO: Does `litter_map_injective` follow from `atom_mem`?
structure hypothesis_injective_inflexible {L : litter} {A : extended_index β}
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A) : Prop :=
(atom_map_injective : ∀ a b B
  (ha : (inl a, B) ∈ inflexible_support h) (hb : (inl b, B) ∈ inflexible_support h),
  H.atom_image a ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at ha) =
  H.atom_image b ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at hb) → a = b)
(litter_map_injective : ∀ (L₁ L₂ : litter) B
  (hL₁ : (inr L₁.to_near_litter, B) ∈ inflexible_support h)
  (hL₂ : (inr L₂.to_near_litter, B) ∈ inflexible_support h),
  (H.near_litter_image L₁.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL₁) ∩
  H.near_litter_image L₂.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL₂) : set atom).nonempty → L₁ = L₂)
(atom_mem : ∀ a (L : litter) B
  (ha : (inl a, B) ∈ inflexible_support h) (hL : (inr L.to_near_litter, B) ∈ inflexible_support h),
  a ∈ litter_set L ↔
    H.atom_image a ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at ha) ∈
    H.near_litter_image L.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL))
(map_flexible : ∀ (L : litter) B (hL₁ : (inr L.to_near_litter, B) ∈ inflexible_support h)
  (hL₂ : flexible α L B),
  flexible α (H.near_litter_image L.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL₁)).1 B)

def hypothesised_weak_struct_approx {L : litter} {A : extended_index β}
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A)
  (hH : hypothesis_injective_inflexible H h) : weak_struct_approx h.δ :=
λ B, {
  atom_map := λ a, ⟨(inl a, B) ∈ inflexible_support h,
    λ ha, H.atom_image a ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at ha)⟩,
  litter_map := λ L, ⟨(inr L.to_near_litter, B) ∈ inflexible_support h,
    λ hL, H.near_litter_image L.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL)⟩,
  atom_map_dom_small := begin
    simp only [pfun.dom_mk],
    refine lt_of_le_of_lt _ (inflexible_support_small h),
    refine ⟨⟨λ a, ⟨_, a.prop⟩, λ a b h, _⟩⟩,
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff, subtype.coe_inj, eq_self_iff_true, and_true] at h,
    exact h,
  end,
  litter_map_dom_small := begin
    simp only [pfun.dom_mk],
    refine lt_of_le_of_lt _ (inflexible_support_small h),
    refine ⟨⟨λ L, ⟨_, L.prop⟩, λ L₁ L₂ h, _⟩⟩,
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff, eq_self_iff_true, and_true,
      litter.to_near_litter_injective.eq_iff, subtype.coe_inj] at h,
    exact h,
  end,
  atom_map_injective := λ a b ha hb, hH.atom_map_injective a b B ha hb,
  litter_map_injective := λ L₁ L₂ hL₁ hL₂, hH.litter_map_injective L₁ L₂ B hL₁ hL₂,
  atom_mem := λ a ha L hL, hH.atom_mem a L B ha hL,
}

@[simp] lemma hypothesised_weak_struct_approx_atom_map {L : litter} {A : extended_index β}
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A)
  (hH : hypothesis_injective_inflexible H h) (B : extended_index h.δ) (a : atom) :
  (hypothesised_weak_struct_approx H h hH B).atom_map a = {
    dom := (inl a, B) ∈ inflexible_support h,
    get := λ ha, H.atom_image a ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at ha)
  } := rfl

@[simp] lemma hypothesised_weak_struct_approx_litter_map {L : litter} {A : extended_index β}
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A)
  (hH : hypothesis_injective_inflexible H h) (B : extended_index h.δ) (L : litter) :
  (hypothesised_weak_struct_approx H h hH B).litter_map L = {
    dom := (inr L.to_near_litter, B) ∈ inflexible_support h,
    get := λ hL, H.near_litter_image L.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL)
  } := rfl

lemma hypothesised_weak_struct_approx_free (π : struct_approx β) (hπ : π.free) {L : litter}
  {A : extended_index β} (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A)
  (hH : hypothesis_injective_inflexible H h) :
  @struct_approx.free _ _ _ _ (h.δ : Iic α)
  (hypothesised_weak_struct_approx H h hH).refine.complete :=
begin
  rintros B L' ((hL' | ⟨L', hL', rfl⟩) | hL'),
  { exact hL'.2, },
  { rw weak_near_litter_approx.rough_litter_map_or_else_of_dom _ hL'.1,
    exact hH.map_flexible L' B hL'.1 hL'.2, },
  { exact (local_perm.sandbox_subset_subset _ _ hL').2, },
end

noncomputable def allowable_of_weak_struct_approx (π : struct_approx β) (hπ : π.free)
  {γ : Iic α} {δ : Iio α} (hδ : (δ : Λ) < γ) (B : path (β : type_index) γ)
  (w : weak_struct_approx δ)
  (hw : (show struct_approx (δ : Iic α), from w.complete).free) :
  allowable δ :=
(freedom_of_action_of_lt (δ : Iic α)
  (hδ.trans_le (show _, from coe_le_coe.mp (le_of_path B))) _ hw).some

lemma allowable_of_weak_struct_approx_exactly_approximates (π : struct_approx β) (hπ : π.free)
  {γ : Iic α} {δ : Iio α} (hδ : (δ : Λ) < γ) (B : path (β : type_index) γ)
  (w : weak_struct_approx δ)
  (hw : (show struct_approx (δ : Iic α), from w.complete).free) :
  w.complete.exactly_approximates (allowable_of_weak_struct_approx π hπ hδ B w hw).to_struct_perm :=
(freedom_of_action_of_lt (δ : Iic α)
  (hδ.trans_le (show _, from coe_le_coe.mp (le_of_path B))) _ hw).some_spec

noncomputable def hypothesised_allowable (π : struct_approx β) (hπ : π.free)
  {L : litter} {A : extended_index β} (h : inflexible_coe L A)
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (hH : hypothesis_injective_inflexible H h) :
  allowable h.δ :=
allowable_of_weak_struct_approx π hπ h.hδ h.B _ (hypothesised_weak_struct_approx_free π hπ H h hH)

lemma hypothesised_allowable_exactly_approximates (π : struct_approx β) (hπ : π.free)
  {L : litter} {A : extended_index β} (h : inflexible_coe L A)
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (hH : hypothesis_injective_inflexible H h) :
  (hypothesised_weak_struct_approx H h hH).refine.complete.exactly_approximates
    (hypothesised_allowable π hπ h H hH).to_struct_perm :=
allowable_of_weak_struct_approx_exactly_approximates π hπ h.hδ h.B _
  (hypothesised_weak_struct_approx_free π hπ H h hH)

-- TODO: Rename next few lemmas.
-- TODO: Trim assumptions from lots of these little lemmas, then package into `variables`.
lemma mem_inflexible_support (π : struct_approx β) (hπ : π.free)
  {L : litter} {A : extended_index β} (h : inflexible_coe L A)
  (B : extended_index h.δ) (a : atom)
  (d : support_condition h.δ) (hd₁ : d ∈ designated_support h.t)
  (hd₂ : relation.refl_trans_gen (constrains α h.δ) (inl a, B) d) :
    (inl a, B) ∈ inflexible_support h :=
relation.trans_gen.tail'
  (refl_trans_gen_constrains_comp hd₂ _)
  (constrains.f_map h.hδ h.hε h.hδε h.B h.t d hd₁)

noncomputable def litter_completion (π : struct_approx β) (hπ : π.free)
  (L : litter) (A : extended_index β) (H : hypothesis ⟨inr L.to_near_litter, A⟩) : litter :=
if h : nonempty (inflexible_coe L A) then
  if hH : hypothesis_injective_inflexible H h.some then
    f_map (coe_ne_coe.mpr $ coe_ne' h.some.hδε)
      (hypothesised_allowable π hπ h.some H hH • h.some.t)
  else
    near_litter_approx.flexible_completion α (π A) A • L
else if h : nonempty (inflexible_bot L A) then
  f_map (show (⊥ : type_index) ≠ (h.some.ε : Λ), from bot_ne_coe)
    (H.atom_image h.some.a (h.some.B.cons (bot_lt_coe _)) h.some.constrains)
else
  near_litter_approx.flexible_completion α (π A) A • L

lemma litter_completion_of_flexible (π : struct_approx β) (hπ : π.free)
  (L : litter) (A : extended_index β) (H : hypothesis ⟨inr L.to_near_litter, A⟩)
  (hflex : flexible α L A) :
  litter_completion π hπ L A H = near_litter_approx.flexible_completion α (π A) A • L :=
begin
  rw [litter_completion, dif_neg, dif_neg],
  { rintro ⟨⟨γ, ε, hε, C, a, rfl, rfl⟩⟩,
    exact hflex (inflexible.mk_bot _ _ _), },
  { rintro ⟨⟨γ, δ, ε, hδ, hε, hδε, C, t, rfl, rfl⟩⟩,
    exact hflex (inflexible.mk_coe hδ _ _ _ _), },
end

lemma litter_completion_of_inflexible_coe (π : struct_approx β) (hπ : π.free)
  (L : litter) (A : extended_index β) (H : hypothesis ⟨inr L.to_near_litter, A⟩)
  (h : inflexible_coe L A) (hH : hypothesis_injective_inflexible H h) :
  litter_completion π hπ L A H =
  f_map (coe_ne_coe.mpr $ coe_ne' h.hδε) (hypothesised_allowable π hπ h H hH • h.t) :=
begin
  rw [litter_completion, dif_pos, dif_pos],
  { repeat {
      congr' 1;
      try { rw subsingleton.elim h, },
    }, },
  { rw subsingleton.elim h at hH,
    exact hH, },
  { exact ⟨h⟩, },
end

lemma litter_completion_of_inflexible_bot (π : struct_approx β) (hπ : π.free)
  (L : litter) (A : extended_index β) (H : hypothesis ⟨inr L.to_near_litter, A⟩)
  (h : inflexible_bot L A) :
  litter_completion π hπ L A H =
  f_map (show (⊥ : type_index) ≠ (h.ε : Λ), from bot_ne_coe)
    (H.atom_image h.a (h.B.cons (bot_lt_coe _)) h.constrains) :=
begin
  rw [litter_completion, dif_neg, dif_pos, subsingleton.elim h],
  { exact ⟨h⟩, },
  { rintro ⟨h'⟩,
    exact inflexible_bot_inflexible_coe h h', },
end

end struct_approx

end con_nf


import for_mathlib.algebraic_topology.homotopical_algebra.bifibrant_replacement
import for_mathlib.algebraic_topology.homotopical_algebra.cofibrant_replacement

noncomputable theory

open category_theory category_theory.limits category_theory.category category_theory

namespace algebraic_topology

namespace model_category

variables {C : Type*} [category C] [model_category C]

variables {Hcof : Type*} [category Hcof] (Lcof : cofibrant_object C ⥤ Hcof)
  [Lcof.is_localization cofibrant_object.weq]

lemma Lcof_map_surjective_both_fibrant (X Y : cofibrant_object C)
  [is_fibrant X.obj] [is_fibrant Y.obj] :
  function.surjective (@category_theory.functor.map _ _ _ _ Lcof X Y) := λ f,
begin
  unfreezingI { rcases X with ⟨X, Xcof⟩, rcases Y with ⟨Y, Ycof⟩, },
  let X' := bifibrant_object.mk X,
  let Y' := bifibrant_object.mk Y,
  let f' : (bifibrant_object.forget_fib C ⋙ Lcof).obj X' ⟶
    (bifibrant_object.forget_fib C ⋙ Lcof).obj Y' := f,
  refine ⟨(bifibrant_object.forget_fib C).map
    ((bifibrant_object.forget_fib C ⋙ Lcof).preimage f'), _⟩,
  rw [← functor.comp_map, functor.image_preimage],
end

lemma Lcof_map_eq_iff_bifibrant_Q_map_eq {X Y : bifibrant_object C} (f₁ f₂ : X ⟶ Y) :
  Lcof.map ((bifibrant_object.forget_fib C).map f₁) =
    Lcof.map ((bifibrant_object.forget_fib C).map f₂) ↔
  bifibrant_object.homotopy_category.Q.map f₁ = bifibrant_object.homotopy_category.Q.map f₂ :=
begin
  erw ← functor.map_eq_iff_of_nat_iso (Lbif_comp_Hobif_to_Hocof_iso Lcof
    bifibrant_object.homotopy_category.Q),
  dsimp only [functor.comp_map],
  apply (Hobif_to_Hocof Lcof bifibrant_object.homotopy_category.Q).map_eq_iff,
end

lemma Lcof_map_surjective (X Y : cofibrant_object C) [is_fibrant Y.obj] :
  function.surjective (@category_theory.functor.map _ _ _ _ Lcof X Y) := λ g,
begin
  let X' := cofibrant_object.mk (CM5a.obj (terminal.from X.obj)),
  let f : X ⟶ X' := CM5a.i (terminal.from X.obj),
  have hf : cofibrant_object.weq f,
  { change model_category.weq (CM5a.i (terminal.from X.obj)),
    exact weak_eq.property, },
  haveI : is_iso (Lcof.map f) := is_iso_Lcof_map' Lcof f hf,
  rcases Lcof_map_surjective_both_fibrant Lcof _ _ (inv (Lcof.map f) ≫ g) with ⟨φ, hφ⟩,
  exact ⟨f ≫ φ, by rw [Lcof.map_comp, hφ, is_iso.hom_inv_id_assoc]⟩,
end

lemma Lcof_map_eq_iff'_both_fibrant {X Y : cofibrant_object C} [is_fibrant X.obj] [is_fibrant Y.obj]
  (P : path_object Y.obj) (f₁ f₂ : X ⟶ Y) :
  Lcof.map f₁ = Lcof.map f₂ ↔ nonempty (model_category.right_homotopy P.pre f₁ f₂) :=
begin
  unfreezingI { rcases X with ⟨X, Xcof⟩, rcases Y with ⟨Y, Ycof⟩, },
  let g₁ : bifibrant_object.mk X ⟶ bifibrant_object.mk Y := f₁,
  let g₂ : bifibrant_object.mk X ⟶ bifibrant_object.mk Y := f₂,
  let P' : path_object (bifibrant_object.mk Y).obj := P,
  erw ← bifibrant_object.homotopy_category.Q_map_eq_iff' P' g₁ g₂,
  erw ← functor.map_eq_iff_of_nat_iso (Lbif_comp_Hobif_to_Hocof_iso Lcof
    bifibrant_object.homotopy_category.Q) g₁ g₂,
  dsimp only [functor.comp_map],
  apply (Hobif_to_Hocof Lcof bifibrant_object.homotopy_category.Q).map_eq_iff,
end

lemma Lcof_map_eq_iff' {X Y : cofibrant_object C} [is_fibrant Y.obj] (P : path_object Y.obj)
  (f₁ f₂ : X ⟶ Y) :
  Lcof.map f₁ = Lcof.map f₂ ↔ nonempty (model_category.right_homotopy P.pre f₁ f₂) :=
begin
  split,
  { intro h,
    let X' := CM5a.obj (terminal.from X.obj),
    let i : X.obj ⟶ X' := CM5a.i (terminal.from X.obj),
    have sq₁ : comm_sq ((cofibrant_object.forget C).map f₁) i (terminal.from Y.obj) (terminal.from X') := by tidy,
    have sq₂ : comm_sq ((cofibrant_object.forget C).map f₂) i (terminal.from Y.obj) (terminal.from X') := by tidy,
    let g₁ : cofibrant_object.mk X' ⟶ Y := sq₁.lift,
    let g₂ : cofibrant_object.mk X' ⟶ Y := sq₂.lift,
    have eq : Lcof.map g₁ = Lcof.map g₂,
    { let j : X ⟶ cofibrant_object.mk X' := i,
      haveI : weak_eq ((cofibrant_object.forget C).map j) := by { dsimp [j], apply_instance, },
      haveI := is_iso_Lcof_map Lcof j,
      simp only [← cancel_epi (Lcof.map j), ← functor.map_comp],
      convert h,
      exacts [sq₁.fac_left, sq₂.fac_left], },
    rw Lcof_map_eq_iff'_both_fibrant Lcof P g₁ g₂ at eq,
    convert nonempty.intro (eq.some.comp_left i),
    exacts [sq₁.fac_left.symm, sq₂.fac_left.symm], },
  { intro h,
    change (cofibrant_replacement.π Lcof).map (cofibrant_object.homotopy_category.Q.map f₁) =
      (cofibrant_replacement.π Lcof).map (cofibrant_object.homotopy_category.Q.map f₂),
    congr' 1,
    apply category_theory.quotient.sound,
    exact cofibrant_object.right_homotopy.trans_closure.mk
      (cofibrant_object.right_homotopy.mk P h.some), },
end

lemma Lcof_map_eq_iff {X Y : cofibrant_object C} [is_fibrant Y.obj] (Cyl : cylinder X.obj)
  (f₁ f₂ : X ⟶ Y) :
  Lcof.map f₁ = Lcof.map f₂ ↔ nonempty (left_homotopy Cyl.pre f₁ f₂) :=
begin
  let P := path_object.some Y.obj,
  rw Lcof_map_eq_iff' Lcof P,
  split,
  { exact λ h, nonempty.intro (h.some.to_left_homotopy Cyl), },
  { exact λ h, nonempty.intro (h.some.to_right_homotopy P), },
end

namespace fundamental_lemma

variables {Ho : Type*} [category Ho] (L : C ⥤ Ho) [L.is_localization weq] (C)

variables {C}

lemma map_surjective (X Y : C) [is_cofibrant X] [is_fibrant Y] :
  function.surjective (@category_theory.functor.map _ _ _ _ L X Y) :=
begin
  let Y' := CM5b.obj (initial.to Y),
  suffices : function.surjective (@category_theory.functor.map _ _ _ _ L X Y'),
  { intro g,
    let p : Y' ⟶ Y := CM5b.p (initial.to Y),
    haveI := localization.inverts L weq p weak_eq.property,
    rcases this (g ≫ inv (L.map p)) with ⟨φ, hφ⟩,
    exact ⟨φ ≫ p, by rw [L.map_comp, hφ, assoc, is_iso.inv_hom_id, comp_id]⟩, },
  suffices : ∀ (A B : cofibrant_object C) [is_fibrant B.obj], function.surjective
    (@category_theory.functor.map _ _ _ _ (cofibrant_object.forget C ⋙ L) A B),
  { exact this (cofibrant_object.mk X) (cofibrant_object.mk Y'), },
  simp only [← functor.function_surjective_map_iff_of_iso (Lcof_comp_Hocof_to_Ho_iso Lcof' L)],
  introsI A B hB,
  exact function.surjective.comp (Hocof_to_Ho Lcof' L).map_surjective
    (Lcof_map_surjective Lcof' A B),
end

instance {X Y : C} (f : X ⟶ Y) [weak_eq f] : is_iso (L.map f) :=
localization.inverts L weq f weak_eq.property

lemma map_eq_of_left_homotopy {X Y : C} {f₁ f₂ : X ⟶ Y} {P : precylinder X}
  (h : left_homotopy P f₁ f₂) : L.map f₁ = L.map f₂ :=
begin
  simp only [← h.h₀, ← h.h₁, L.map_comp],
  congr' 1,
  simp only [← cancel_mono (L.map P.σ), ← L.map_comp, P.σd₀, P.σd₁],
end

lemma map_eq_iff {X Y : C} [is_cofibrant X] [is_fibrant Y] (Cyl : cylinder X) (f₁ f₂ : X ⟶ Y) :
  L.map f₁ = L.map f₂ ↔ nonempty (left_homotopy Cyl.pre f₁ f₂) :=
begin
  split,
  { intro h,
    let Y' := CM5b.obj (initial.to Y),
    let i : Y' ⟶ Y := CM5b.p (initial.to Y),
    have sq₁ : comm_sq (initial.to Y') (initial.to X) i f₁ := by tidy,
    have sq₂ : comm_sq (initial.to Y') (initial.to X) i f₂ := by tidy,
    let g₁ : cofibrant_object.mk X ⟶ cofibrant_object.mk Y' := sq₁.lift,
    let g₂ : cofibrant_object.mk X ⟶ cofibrant_object.mk Y' := sq₂.lift,
    haveI := localization.inverts L weq i weak_eq.property,
    rw [← sq₁.fac_right, ← sq₂.fac_right, L.map_comp, L.map_comp,
      cancel_mono] at h,
    change (cofibrant_object.forget C ⋙ L).map g₁ =
      (cofibrant_object.forget C ⋙ L).map g₂ at h,
    rw ← functor.map_eq_iff_of_nat_iso (Lcof_comp_Hocof_to_Ho_iso Lcof' L) at h,
    have h' := (Hocof_to_Ho Lcof' L).map_injective h,
    let Cyl' : cylinder (cofibrant_object.mk X).obj := Cyl,
    rw Lcof_map_eq_iff Lcof' Cyl' g₁ g₂ at h',
    rw [← sq₁.fac_right, ← sq₂.fac_right],
    exact nonempty.intro (h'.some.comp_right i), },
  { intro h,
    exact map_eq_of_left_homotopy L h.some, },
end

lemma map_eq_iff' {X Y : C} [is_cofibrant X] [is_fibrant Y] (P : path_object Y) (f₁ f₂ : X ⟶ Y) :
  L.map f₁ = L.map f₂ ↔ nonempty (right_homotopy P.pre f₁ f₂) :=
begin
  let Cyl := cylinder.some X,
  rw map_eq_iff L Cyl f₁ f₂,
  split,
  { exact λ h, nonempty.intro (h.some.to_right_homotopy P), },
  { exact λ h, nonempty.intro (h.some.to_left_homotopy Cyl), },
end

end fundamental_lemma

end model_category

end algebraic_topology


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.PostPort

universes u v w z u_1 u_2 u_3

namespace Mathlib

namespace list

/- zip & unzip -/

@[simp] theorem zip_with_cons_cons {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (a : α) (b : β) (l₁ : List α) (l₂ : List β) : zip_with f (a :: l₁) (b :: l₂) = f a b :: zip_with f l₁ l₂ :=
  rfl

@[simp] theorem zip_cons_cons {α : Type u} {β : Type v} (a : α) (b : β) (l₁ : List α) (l₂ : List β) : zip (a :: l₁) (b :: l₂) = (a, b) :: zip l₁ l₂ :=
  rfl

@[simp] theorem zip_with_nil_left {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (l : List β) : zip_with f [] l = [] :=
  rfl

@[simp] theorem zip_with_nil_right {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (l : List α) : zip_with f l [] = [] :=
  list.cases_on l (Eq.refl (zip_with f [] [])) fun (l_hd : α) (l_tl : List α) => Eq.refl (zip_with f (l_hd :: l_tl) [])

@[simp] theorem zip_nil_left {α : Type u} {β : Type v} (l : List α) : zip [] l = [] :=
  rfl

@[simp] theorem zip_nil_right {α : Type u} {β : Type v} (l : List α) : zip l [] = [] :=
  zip_with_nil_right Prod.mk l

@[simp] theorem zip_swap {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) : map prod.swap (zip l₁ l₂) = zip l₂ l₁ := sorry

@[simp] theorem length_zip_with {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (l₁ : List α) (l₂ : List β) : length (zip_with f l₁ l₂) = min (length l₁) (length l₂) := sorry

@[simp] theorem length_zip {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) : length (zip l₁ l₂) = min (length l₁) (length l₂) :=
  length_zip_with Prod.mk

theorem lt_length_left_of_zip_with {α : Type u} {β : Type v} {γ : Type w} {f : α → β → γ} {i : ℕ} {l : List α} {l' : List β} (h : i < length (zip_with f l l')) : i < length l :=
  and.left
    (eq.mp (Eq._oldrec (Eq.refl (i < min (length l) (length l'))) (propext lt_min_iff))
      (eq.mp (Eq._oldrec (Eq.refl (i < length (zip_with f l l'))) (length_zip_with f l l')) h))

theorem lt_length_right_of_zip_with {α : Type u} {β : Type v} {γ : Type w} {f : α → β → γ} {i : ℕ} {l : List α} {l' : List β} (h : i < length (zip_with f l l')) : i < length l' :=
  and.right
    (eq.mp (Eq._oldrec (Eq.refl (i < min (length l) (length l'))) (propext lt_min_iff))
      (eq.mp (Eq._oldrec (Eq.refl (i < length (zip_with f l l'))) (length_zip_with f l l')) h))

theorem lt_length_left_of_zip {α : Type u} {β : Type v} {i : ℕ} {l : List α} {l' : List β} (h : i < length (zip l l')) : i < length l :=
  lt_length_left_of_zip_with h

theorem lt_length_right_of_zip {α : Type u} {β : Type v} {i : ℕ} {l : List α} {l' : List β} (h : i < length (zip l l')) : i < length l' :=
  lt_length_right_of_zip_with h

theorem zip_append {α : Type u} {β : Type v} {l₁ : List α} {r₁ : List α} {l₂ : List β} {r₂ : List β} (h : length l₁ = length l₂) : zip (l₁ ++ r₁) (l₂ ++ r₂) = zip l₁ l₂ ++ zip r₁ r₂ := sorry

theorem zip_map {α : Type u} {β : Type v} {γ : Type w} {δ : Type z} (f : α → γ) (g : β → δ) (l₁ : List α) (l₂ : List β) : zip (map f l₁) (map g l₂) = map (prod.map f g) (zip l₁ l₂) := sorry

theorem zip_map_left {α : Type u} {β : Type v} {γ : Type w} (f : α → γ) (l₁ : List α) (l₂ : List β) : zip (map f l₁) l₂ = map (prod.map f id) (zip l₁ l₂) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (zip (map f l₁) l₂ = map (prod.map f id) (zip l₁ l₂))) (Eq.symm (zip_map f id l₁ l₂))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (zip (map f l₁) l₂ = zip (map f l₁) (map id l₂))) (map_id l₂)))
      (Eq.refl (zip (map f l₁) l₂)))

theorem zip_map_right {α : Type u} {β : Type v} {γ : Type w} (f : β → γ) (l₁ : List α) (l₂ : List β) : zip l₁ (map f l₂) = map (prod.map id f) (zip l₁ l₂) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (zip l₁ (map f l₂) = map (prod.map id f) (zip l₁ l₂))) (Eq.symm (zip_map id f l₁ l₂))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (zip l₁ (map f l₂) = zip (map id l₁) (map f l₂))) (map_id l₁)))
      (Eq.refl (zip l₁ (map f l₂))))

theorem zip_map' {α : Type u} {β : Type v} {γ : Type w} (f : α → β) (g : α → γ) (l : List α) : zip (map f l) (map g l) = map (fun (a : α) => (f a, g a)) l := sorry

theorem mem_zip {α : Type u} {β : Type v} {a : α} {b : β} {l₁ : List α} {l₂ : List β} : (a, b) ∈ zip l₁ l₂ → a ∈ l₁ ∧ b ∈ l₂ := sorry

theorem map_fst_zip {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) : length l₁ ≤ length l₂ → map prod.fst (zip l₁ l₂) = l₁ := sorry

theorem map_snd_zip {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) : length l₂ ≤ length l₁ → map prod.snd (zip l₁ l₂) = l₂ := sorry

@[simp] theorem unzip_nil {α : Type u} {β : Type v} : unzip [] = ([], []) :=
  rfl

@[simp] theorem unzip_cons {α : Type u} {β : Type v} (a : α) (b : β) (l : List (α × β)) : unzip ((a, b) :: l) = (a :: prod.fst (unzip l), b :: prod.snd (unzip l)) := sorry

theorem unzip_eq_map {α : Type u} {β : Type v} (l : List (α × β)) : unzip l = (map prod.fst l, map prod.snd l) := sorry

theorem unzip_left {α : Type u} {β : Type v} (l : List (α × β)) : prod.fst (unzip l) = map prod.fst l := sorry

theorem unzip_right {α : Type u} {β : Type v} (l : List (α × β)) : prod.snd (unzip l) = map prod.snd l := sorry

theorem unzip_swap {α : Type u} {β : Type v} (l : List (α × β)) : unzip (map prod.swap l) = prod.swap (unzip l) := sorry

theorem zip_unzip {α : Type u} {β : Type v} (l : List (α × β)) : zip (prod.fst (unzip l)) (prod.snd (unzip l)) = l := sorry

theorem unzip_zip_left {α : Type u} {β : Type v} {l₁ : List α} {l₂ : List β} : length l₁ ≤ length l₂ → prod.fst (unzip (zip l₁ l₂)) = l₁ := sorry

theorem unzip_zip_right {α : Type u} {β : Type v} {l₁ : List α} {l₂ : List β} (h : length l₂ ≤ length l₁) : prod.snd (unzip (zip l₁ l₂)) = l₂ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (prod.snd (unzip (zip l₁ l₂)) = l₂)) (Eq.symm (zip_swap l₂ l₁))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (prod.snd (unzip (map prod.swap (zip l₂ l₁))) = l₂)) (unzip_swap (zip l₂ l₁))))
      (unzip_zip_left h))

theorem unzip_zip {α : Type u} {β : Type v} {l₁ : List α} {l₂ : List β} (h : length l₁ = length l₂) : unzip (zip l₁ l₂) = (l₁, l₂) := sorry

theorem zip_of_prod {α : Type u} {β : Type v} {l : List α} {l' : List β} {lp : List (α × β)} (hl : map prod.fst lp = l) (hr : map prod.snd lp = l') : lp = zip l l' := sorry

theorem map_prod_left_eq_zip {α : Type u} {β : Type v} {l : List α} (f : α → β) : map (fun (x : α) => (x, f x)) l = zip l (map f l) := sorry

theorem map_prod_right_eq_zip {α : Type u} {β : Type v} {l : List α} (f : α → β) : map (fun (x : α) => (f x, x)) l = zip (map f l) l := sorry

@[simp] theorem length_revzip {α : Type u} (l : List α) : length (revzip l) = length l := sorry

@[simp] theorem unzip_revzip {α : Type u} (l : List α) : unzip (revzip l) = (l, reverse l) :=
  unzip_zip (Eq.symm (length_reverse l))

@[simp] theorem revzip_map_fst {α : Type u} (l : List α) : map prod.fst (revzip l) = l :=
  eq.mpr (id (Eq._oldrec (Eq.refl (map prod.fst (revzip l) = l)) (Eq.symm (unzip_left (revzip l)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (prod.fst (unzip (revzip l)) = l)) (unzip_revzip l)))
      (Eq.refl (prod.fst (l, reverse l))))

@[simp] theorem revzip_map_snd {α : Type u} (l : List α) : map prod.snd (revzip l) = reverse l :=
  eq.mpr (id (Eq._oldrec (Eq.refl (map prod.snd (revzip l) = reverse l)) (Eq.symm (unzip_right (revzip l)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (prod.snd (unzip (revzip l)) = reverse l)) (unzip_revzip l)))
      (Eq.refl (prod.snd (l, reverse l))))

theorem reverse_revzip {α : Type u} (l : List α) : reverse (revzip l) = revzip (reverse l) := sorry

theorem revzip_swap {α : Type u} (l : List α) : map prod.swap (revzip l) = revzip (reverse l) := sorry

theorem nth_zip_with {α : Type u_1} {β : Type u_1} {γ : Type u_1} (f : α → β → γ) (l₁ : List α) (l₂ : List β) (i : ℕ) : nth (zip_with f l₁ l₂) i = f <$> nth l₁ i <*> nth l₂ i := sorry

theorem nth_zip_with_eq_some {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β → γ) (l₁ : List α) (l₂ : List β) (z : γ) (i : ℕ) : nth (zip_with f l₁ l₂) i = some z ↔ ∃ (x : α), ∃ (y : β), nth l₁ i = some x ∧ nth l₂ i = some y ∧ f x y = z := sorry

theorem nth_zip_eq_some {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) (z : α × β) (i : ℕ) : nth (zip l₁ l₂) i = some z ↔ nth l₁ i = some (prod.fst z) ∧ nth l₂ i = some (prod.snd z) := sorry

@[simp] theorem nth_le_zip_with {α : Type u} {β : Type v} {γ : Type w} {f : α → β → γ} {l : List α} {l' : List β} {i : ℕ} {h : i < length (zip_with f l l')} : nth_le (zip_with f l l') i h =
  f (nth_le l i (lt_length_left_of_zip_with h)) (nth_le l' i (lt_length_right_of_zip_with h)) := sorry

@[simp] theorem nth_le_zip {α : Type u} {β : Type v} {l : List α} {l' : List β} {i : ℕ} {h : i < length (zip l l')} : nth_le (zip l l') i h = (nth_le l i (lt_length_left_of_zip h), nth_le l' i (lt_length_right_of_zip h)) :=
  nth_le_zip_with

theorem mem_zip_inits_tails {α : Type u} {l : List α} {init : List α} {tail : List α} : (init, tail) ∈ zip (inits l) (tails l) ↔ init ++ tail = l := sorry