/-
# Macros

## What is a macro
Macros in Lean are `Syntax → MacroM Syntax` functions. `MacroM` is the macro
monad which allows macros to have some static guarantees we will discuss in the
next section, you can mostly ignore it for now.

Macros are registered as handlers for a specific syntax declaration using the
`macro` attribute. The compiler will take care of applying these function
to the syntax for us before performing actual analysis of the input. This
means that the only thing we have to do is declare our syntax with a specific
name and bind a function of type `Lean.Macro` to it. Let's try to reproduce
the `LXOR` notation from the `Syntax` chapter:
-/

import Lean

open Lean

syntax:10 (name := lxor) term:10 " LXOR " term:11 : term

@[macro lxor] def lxorImpl : Macro
  | `($l:term LXOR $r:term) => `(!$l && $r) -- we can use the quotation mechanism to create `Syntax` in macros
  | _ => Macro.throwUnsupported

#eval true LXOR true -- false
#eval true LXOR false -- false
#eval false LXOR true -- true
#eval false LXOR false -- false

/-
That was quite easy! The `Macro.throwUnsupported` function can be used by a macro
to indicate that "it doesn't feel responsible for this syntax". In this case
it's merely used to fill a wildcard pattern that should never be reached anyways.

However we can in fact register multiple macros for the same syntax this way
if we desire, they will be tried one after another (the later registered ones have
higher priority)  -- is "higher" correct?
until one throws either a real error using `Macro.throwError` or succeeds, that
is it does not `Macro.throwUnsupported`. Let's see this in action:
-/

@[macro lxor] def lxorImpl2 : Macro
  -- special case that changes behaviour of the case where the left and
  -- right hand side are these specific identifiers
  | `(true LXOR true) => `(true)
  | _ => Macro.throwUnsupported

#eval true LXOR true -- true, handled by new macro
#eval true LXOR false -- false, still handled by the old

/-
This capability is obviously *very* powerful! It should not be used
lightly and without careful thinking since it can introduce weird
behaviour while writing code later on. The following example illustrates
this weird behaviour:
-/

#eval true LXOR true -- true, handled by new macro

def foo := true
#eval foo LXOR foo -- false, handled by old macro, after all the identifiers have a different name

/-
Without knowing exactly how this macro is implemented this behaviour
will be very confusing to whoever might be debugging an issue based on this.
The rule of thumb for when to use a macro vs. other mechanisms like
elaboration is that as soon as you are building real logic like in the 2nd
macro above, it should most likely not be a macro but an elaborator
(explained in the elaboration chapter). This means ideally we want to
use macros for simple syntax to syntax translations, that a human could
easily write out themselves as well but is too lazy to.

## Simplifying macro declaration
Now that we know the basics of what a macro is and how to register it
we can take a look at slightly more automated ways to do this (in fact
all of the ways about to be presented are implemented as macros themselves).

First things first there is `macro_rules` which basically desugars to
functions like the ones we wrote above, for example:
-/

syntax:10 term:10 " RXOR " term:11 : term

macro_rules
  | `($l:term RXOR $r:term) => `($l && !$r)

/-
As you can see, it figures out lot's of things on its own for us:
- the name of the syntax declaration
- the `macro` attribute registration
- the `throwUnsupported` wildcard

apart from this it just works like a function that is using pattern
matching syntax, we can in theory encode arbitrarily complex macro
functions on the right hand side.

If this is still not short enough for you, there is a next step using the
`macro` macro:
-/

macro l:term:10 " ⊕ " r:term:11 : term => `((!$l && $r) || ($l && !$r))

#eval true ⊕ true -- false
#eval true ⊕ false -- true
#eval false ⊕ true -- true
#eval false ⊕ false -- false

/-
As you can see, `macro` is quite close to `notation` already:
- it performed syntax declaration for us
- it automatically wrote a `macro_rules` style function to match on it

The are of course differences as well:
- `notation` is limited to the `term` syntax category
- `notation` cannot have arbitrary macro code on the right hand side

## `Syntax` Quotations
### The basics
So far we've handwaved the `` `(foo $bar) `` syntax to both create and
match on `Syntax` objects but it's time for a full explanation since
it will be essential to all non trivial things that are syntax related.

First things first we call the `` `() `` syntax a `Syntax` quotation.
When we plug variables into a syntax quotation like this: `` `($x) ``
we call the `$x` part an anti-quotation. When we insert `x` like this
it is required that `x` is of type `TSyntax x` where `x` is some `Name`
of a syntax category. The Lean compiler is actually smart enough to figure
the syntax categories that are allowed in this place out. Hence you might
sometimes see errors of the form:
```
application type mismatch
  x.raw
argument
  x
has type
  TSyntax `a : Type
but is expected to have type
  TSyntax `b : Type
```
If you are sure that your thing from the `a` syntax category can be
used as a `b` here you can declare a coercion of the form:
-/

instance : Coe (TSyntax `a) (TSyntax `b) where
  coe s := ⟨s.raw⟩

/-!
Which will allow Lean to perform the type cast automatically. If you
notice that your `a` can not be used in place of the `b` here congrats,
you just discovered a bug in your `Syntax` function. Similar to the Lean
compiler you could can also declare functions that are specific to certain
`TSynax` variants. For example as we have seen in the syntax chapter
there exists the function:
-/
#check TSyntax.getNat -- TSyntax.getNat : TSyntax numLitKind → Nat
/-!
Which is guaranteed to not panic because we know that the `Syntax` that
the function is receiving is a numeric literal and can thus naturally
be converted to a `Nat`.

If we use the antiquotation syntax in pattern matching it will, as discussed
in the syntax chapter, give us a a variable `x` of type `` TSyntax y `` where
`y` is the `Name` of the syntax category that fits in the spot where we pattern matched.
If we wish to insert a literal `$x` into the `Syntax` for some reason,
for example macro creating macros, we can escape the anti quotation using: `` `($$x) ``.

If we want to specify the syntax kind we wish `x` to be interpreted as
we can make this explicit using: `` `($x:term) `` where `term` can be
replaced with any other valid syntax category (e.g. `command`) or parser
(e.g. `ident`).

So far this is only a more formal explanation of the intuitive things
we've already seen in the syntax chapter and up to now in this chapter,
next we'll discuss some more advanced anti-quotations.

### Advanced anti-quotations
For convenince we can also use anti-quotations in a way similar to
format strings: `` `($(mkIdent `c)) `` is the same as: `` let x := mkIdent `c; `($x) ``.

Furthermore there are sometimes situations in which we are not working
with basic `Syntax` but `Syntax` wrapped in more complex datastructures,
most notably `Array (TSyntax c)` or `TSepArray c s`. Where `TSepArray c s`, is a
`Syntax` specific type, it is what we get if we pattern match on some
`Syntax` that users a separator `s` to separate things from the category `c`.
For example if we match using: `$xs,*`, `xs` will have type `TSepArray c ","`,.
With the special case of matching on no specific separator (i.e. whitespace):
`$xs*` in which we will receive an `Array (TSyntax c)`.

If we are dealing with `xs : Array (TSyntax c)` and want to insert it into
a quotation we have two main ways to achieve this:
1. Insert it using a separator, most commonly `,`: `` `($xs,*) ``.
  This is also the way to insert a `TSepArray c ",""`
2. Insert it point blank without a separator (TODO): `` `() ``

For example:
-/

-- syntactically cut away the first element of a tuple if possible
syntax "cut_tuple " "(" term ", " term,+ ")" : term

macro_rules
  -- cutting away one element of a pair isn't possible, it would not result in a tuple
  | `(cut_tuple ($x, $y)) => `(($x, $y))
  | `(cut_tuple ($x, $y, $xs,*)) => `(($y, $xs,*))

#check cut_tuple (1, 2) -- (1, 2) : Nat × Nat
#check cut_tuple (1, 2, 3) -- (2, 3) : Nat × Nat

/-!
The last thing for this section will be so called "anti-quotation splices".
There are two kinds of anti quotation splices, first the so called optional
ones. For example we might declare a syntax with an optional argument,
say our own `let` (in real projects this would most likely be a `let`
in some functional language we are writing a theory about):
-/

syntax "mylet " ident (" : " term)? " := " term " in " term : term

/-!
There is this optional `(" : " term)?` argument involved which can let
the user define the type of the term to the left of it. With the methods
we know so far we'd have to write two `macro_rules` now, one for the case
with, one for the case without the optional argument. However the rest
of the syntactic translation works exactly the same with and without
the optional argument so what we can do using a splice here is to essentially
define both cases at once:
-/

macro_rules
  | `(mylet $x $[: $ty]? := $val in $body) => `(let $x $[: $ty]? := $val; $body)

/-!
The `$[...]?` part is the splice here, it basically says "if this part of
the syntax isn't there, just ignore the parts on the right hand side that
involve anti quotation variables involved here". So now we can run
this syntax both with and without type ascription:
-/

#eval mylet x := 5 in x - 10 -- 0, due to subtraction behaviour of `Nat`
#eval mylet x : Int := 5 in x - 10 -- -5, after all it is an `Int` now

/-!
The second and last splice might remind readers of list comprehension
as seen for example in Python. We will demonstrate it using an implementation
of `map` as a macro:
-/

-- run the function given at the end for each element of the list
syntax "foreach " "[" term,* "]" term : term

macro_rules
  | `(foreach [ $[$x:term],* ] $func:term) => `(let f := $func; [ $[f $x],* ])

#eval foreach [1,2,3,4] (Nat.add 2) -- [3, 4, 5, 6]

/-!
In this case the `$[...],*` part is the splice. On the match side it tries
to match the pattern we define inside of it repetetively (given the seperator
we tell it to). However unlike regular separator matching it does not
give us an `Array` or `SepArray`, instead it allows us to write another
splice on the right hand side that gets evaluated for each time the
pattern we specified matched, with the specific values from the match
per iteration.
-/

/-!
## Hygiene issues and how to solve them
If you are familiar with macro systems in other languages like C you
probably know about so called macro hygiene issues already.
A hygiene issue is when a macro introduces an identifier that collides with an
identifier from some syntax that it is including. For example:
-/

-- Applying this macro produces a function that binds a new identifier `x`.
macro "const" e:term : term => `(fun x => $e)

-- But `x` can also be defined by a user
def x : Nat := 42

-- Which `x` should be used by the compiler in place of `$e`?
#eval (const x) 10 -- 42

/-
Given the fact that macros perform only syntactic translations one might
expect the above `eval` to return 10 instead of 42: after all, the resulting
syntax should be `(fun x => x) 10`. While this was of course not the intention
of the author, this is what would happen in more primitive macro systems like
the one of C. So how does Lean avoid these hygiene issues? You can read
about this in detail in the excellent [Beyond Notations](https://lmcs.episciences.org/9362/pdf)
paper which discusses the idea and implementation in Lean in detail.
We will merely give an overview of the topic, since the details are not
that interesting for practical uses. The idea described in Beyond Notations
comes down to a concept called "macro scopes". Whenever a new macro
is invoked, a new macro scope (basically a unique number) is added to
a list of all the macro scopes that are active right now. When the current
macro introduces a new identifier what is actually getting added is an
identifier of the form:
```
<actual name>._@.(<module_name>.<scopes>)*.<module_name>._hyg.<scopes>
```
For example, if the module name is `Init.Data.List.Basic`, the name is
`foo.bla`, and macros scopes are [2, 5] we get:
```
foo.bla._@.Init.Data.List.Basic._hyg.2.5
```
Since macro scopes are unique numbers the list of macro scopes appended in the end
of the name will always be unique across all macro invocations, hence macro hygiene
issues like the ones above are not possible.

If you are wondering why there is more than just the macro scopes to this
name generation, that is because we may have to combine scopes from different files/modules.
The main module being processed is always the right most one.
This situation may happen when we execute a macro generated in a file
imported in the current file.
```
foo.bla._@.Init.Data.List.Basic.2.1.Init.Lean.Expr_hyg.4
```
The delimiter `_hyg` at the end is used just to improve performance of
the function `Lean.Name.hasMacroScopes` -- the format could also work without it.

This was a lot of technical details. You do not have to understand them
in order to use macros, if you want you can just keep in mind that Lean
will not allow name clashes like the one in the `const` example.

Note that this extends to *all* names that are introduced using syntax
quotations, that is if you write a macro that produces:
`` `(def foo := 1) ``, the user will not be able to access `foo`
because the name will subject to hygienie. Luckily there is a way to
circumvent this. You can use `mkIdent` to generate a raw identifier,
for example: `` `(def $(mkIdent `foo) := 1) ``. In this case it won't
be subject to hygiene and accessible to the user.

## `MonadQuotation` and `MonadRef`
Based on this description of the hygiene mechanism one interesting
question pops up, how do we know what the current list of macro scopes
actually is? After all in the macro functions that were defined above
there is never any explicit passing around of the scopes happening.
As is quite common in functional programming, as soon as we start
having some additional state that we need to bookkeep (like the macro scopes)
this is done with a monad, this is the case here as well with a slight twist.

Instead of implementing this for only a single monad `MacroM` the general
concept of keeping track of macro scopes in monadic way is abstracted
away using a type class called `MonadQuotation`. This allows any other
monad to also easily provide this hygienic `Syntax` creation mechanism
by simply implementing this type class.

This is also the reason that while we are able to use pattern matching on syntax
with `` `(syntax) `` we cannot just create `Syntax` with the same
syntax in pure functions: there is no `Monad` implementing `MonadQuotation`
involved in order to keep track of the macro scopes.

Now let's take a brief look at the `MonadQuotation` type class:
-/

namespace Playground

class MonadRef (m : Type → Type) where
  getRef      : m Syntax
  withRef {α} : Syntax → m α → m α

class MonadQuotation (m : Type → Type) extends MonadRef m where
  getCurrMacroScope : m MacroScope
  getMainModule     : m Name
  withFreshMacroScope {α : Type} : m α → m α

end Playground

/-
Since `MonadQuotation` is based on `MonadRef`, let's take a look at `MonadRef`
first. The idea here is quite simple: `MonadRef` is meant to be seen as an extension
to the `Monad` typeclass which
- gives us a reference to a `Syntax` value with `getRef`
- can evaluate a certain monadic action `m α` with a new reference to a `Syntax`
  using `withRef`

On it's own `MonadRef` isn't exactly interesting, but once it is combined with
`MonadQuotation` it makes sense.

As you can see `MonadQuotation` extends `MonadRef` and adds 3 new functions:
- `getCurrMacroScope` which obtains the latest `MacroScope` that was created
- `getMainModule` which (obviously) obtains the name of the main module,
  both of these are used to create these hygienic identifiers explained above
- `withFreshMacroScope` which will compute the next macro scope and run
  some computation `m α` that performs syntax quotation with this new
  macro scope in order to avoid name clashes. While this is mostly meant
  to be used internally whenever a new macro invocation happens, it can sometimes
  make sense to use this in our own macros, for example when we are generating
  some syntax block repeatedly and want to avoid name clashes.

How `MonadRef` comes into play here is that Lean requires a way to indicate
errors at certain positions to the user. One thing that wasn't introduced
in the `Syntax` chapter is that values of type `Syntax` actually carry their
position in the file around as well. When an error is detected, it is usually
bound to a `Syntax` value which tells Lean where to indicate the error in the file.
What Lean will do when using `withFreshMacroScope` is to apply the position of
the result of `getRef` to each introduced symbol, which then results in better
error positions than not applying any position.

To see error positioning in action, we can write a little macro that makes use of it:
-/

syntax "error_position" ident : term

macro_rules
  | `(error_position all) => Macro.throwError "Ahhh"
  -- the `%$tk` syntax gives us the Syntax of the thing before the %,
  -- in this case `error_position`, giving it the name `tk`
  | `(error_position%$tk first) => withRef tk (Macro.throwError "Ahhh")

#eval error_position all -- the error is indicated at `error_position all`
#eval error_position first -- the error is only indicated at `error_position`

/-
Obviously controlling the positions of errors in this way is quite important
for a good user experience.

## Mini project
As a final mini project for this section we will re-build the arithmetic
DSL from the syntax chapter in a slightly more advanced way, using a macro
this time so we can actually fully integrate it into the Lean syntax.
-/
declare_syntax_cat arith

syntax num : arith
syntax arith "-" arith : arith
syntax arith "+" arith : arith
syntax "(" arith ")" : arith
syntax "[Arith|" arith "]" : term

macro_rules
  | `([Arith| $x:num]) => `($x)
  | `([Arith| $x:arith + $y:arith]) => `([Arith| $x] + [Arith| $y]) -- recursive macros are possible
  | `([Arith| $x:arith - $y:arith]) => `([Arith| $x] - [Arith| $y])
  | `([Arith| ($x:arith)]) => `([Arith| $x])

#eval [Arith| (12 + 3) - 4] -- 11

/-! Again feel free to play around with it. If you want to build more complex
things, like expressions with variables, maybe consider building an inductive type
using macros instead. Once you got your arithmetic expression term
as an inductive, you could then write a function that takes some form of
variable assignment and evaluates the given expression for this
assignment. You could also try to embed arbitrary `term`s into your
arith language using some special syntax or whatever else comes to your mind.
-/

/-!
## More elaborate examples
### Binders 2.0
As promised in the syntax chapter here is Binders 2.0. We'll start by
reintroducing our theory of sets:
-/
def Set (α : Type u) := α → Prop
def Set.mem (x : α) (X : Set α) : Prop := X x

-- Integrate into the already existing typeclass for membership notation
instance : Membership α (Set α) where
  mem := Set.mem

def Set.empty : Set α := λ _ => False

-- the basic "all elements such that" function for the notation
def setOf {α : Type} (p : α → Prop) : Set α := p

/-!
The goal for this section will be to allow for both `{x : X | p x}`
and `{x ∈ X, p x}` notations. In principle there are two ways to do this:
1. Define a syntax and macro for each way to bind a variable we might think of
2. Define a syntax cateogry of binders that we could reuse across other
   binder constructs such as `Σ` or `Π` as well and implement macros for
   the `{ | }` case

In this section we will use approach 2 because it is more easily reusable.
-/

declare_syntax_cat binder_construct
syntax "{" binder_construct "|" term "}" : term

/-!
Now let's define the two binders constructs we are interested in:
-/
syntax ident " : " term : binder_construct
syntax ident " ∈ " term : binder_construct

/-!
And finally the macros to expand our syntax:
-/

macro_rules
  | `({ $var:ident : $ty:term | $body:term }) => `(setOf (fun ($var : $ty) => $body))
  | `({ $var:ident ∈ $s:term | $body:term }) => `(setOf (fun $var => $var ∈ $s ∧ $body))

-- Old examples with better syntax:
#check { x : Nat | x ≤ 1 } -- setOf fun x => x ≤ 1 : Set Nat

example : 1 ∈ { y : Nat | y ≤ 1 } := by simp[Membership.mem, Set.mem, setOf]
example : 2 ∈ { y : Nat | y ≤ 3 ∧ 1 ≤ y } := by simp[Membership.mem, Set.mem, setOf]

-- New examples:
def oneSet : Set Nat := λ x => x = 1
#check { x ∈ oneSet | 10 ≤ x } -- setOf fun x => x ∈ oneSet ∧ 10 ≤ x : Set Nat

example : ∀ x, ¬(x ∈ { y ∈ oneSet | y ≠ 1 }) := by
  intro x h
  -- h : x ∈ setOf fun y => y ∈ oneSet ∧ y ≠ 1
  -- ⊢ False
  cases h
  -- : x ∈ oneSet
  -- : x ≠ 1
  contradiction

/-!
## Reading further
If you want to know more about macros you can read:
- the API docs: TODO link
- the source code: the lower parts of [Init.Prelude](https://github.com/leanprover/lean4/blob/master/src/Init/Prelude.lean)
  as you can see they are declared quite early in Lean because of their importance
  to building up syntax
- the aforementioned [Beyond Notations](https://lmcs.episciences.org/9362/pdf) paper
-/


-- Author(s): Andrés Goens
-- See Copyright Notice in LICENSE

import Pop.Util
open Util Std.HashMap

namespace Pop

def RequestId := Nat deriving ToString, BEq, Inhabited, Hashable
def Value := Option Nat deriving ToString, BEq, Inhabited
def Address := Nat deriving ToString, BEq, Inhabited
def ThreadId := Nat deriving Ord, LT, LE, ToString, Inhabited, Hashable, DecidableEq
inductive ConditionalValue
  | const : Nat → ConditionalValue
  | tentative : Nat → ConditionalValue
  --| transaction : Nat → ConditionalValue
  | fetchAndAdd : ConditionalValue
  | failed : ConditionalValue
  deriving BEq, Inhabited

def ConditionalValue.update : ConditionalValue → Value → ConditionalValue
  | c@(.const v), some v' => if v == v' then c else .failed
  | c@(.tentative v), some v' => if v == v' then c else .failed
  | (.const _), none => .failed
  | (.tentative _), none => .failed
  | .failed , _ => .failed
  | .fetchAndAdd, some v => .tentative (v + 1)
  | .fetchAndAdd, none => .failed

def ConditionalValue.validate : ConditionalValue → ConditionalValue
  | .tentative v => .const v
  | c => c

def RequestId.toNat : RequestId → Nat := λ x => x
def ThreadId.toNat : ThreadId → Nat := λ x => x
def RequestId.ofNat : Nat → RequestId := λ x => x
def ThreadId.ofNat : Nat → ThreadId := λ x => x
def Address.ofNat : Nat → Address := λ x => x
def Value.ofNat : Nat → Value := λ x => some x
def Value.ofOptionNat : Option Nat → Value := λ x => x

instance : OfNat ThreadId n where  ofNat := ThreadId.ofNat n
instance : OfNat RequestId n where  ofNat := RequestId.ofNat n
instance : OfNat Address n where ofNat := Address.ofNat n
instance : OfNat Value n where ofNat := Value.ofNat n
instance : Coe RequestId Nat where coe := RequestId.toNat

instance : BEq ThreadId := @instBEq ThreadId instThreadIdDecidableEq
instance : Lean.Quote ThreadId where quote := λ n => Lean.quote (ThreadId.toNat n)
instance : ToString ConditionalValue where toString
  | .const n => s!"{n}"
  | .tentative n => s!"{n}?"
  | .fetchAndAdd => s!"(n+1)"
  | .failed => "FAILED"

instance : LawfulBEq ThreadId := inferInstance
instance : LawfulBEq (List ThreadId) := inferInstance

def Address.prettyPrint (addr : Address) : String :=
  match (OfNat.ofNat addr) with
    | 0 => s!"x"
    | 1 => s!"y"
    | 2 => s!"z"
    | 3 => s!"w"
    | addr => s!"v{addr}"

inductive BlockingKinds
  | Read2ReadPred
  | Read2ReadNoPred
  | Read2WritePred
  | Read2WriteNoPred
  | Write2Read
  | Write2Write
  deriving BEq

abbrev BlockingSemantics := List BlockingKinds

def BlockingKinds.toString : BlockingKinds → String
  | .Read2ReadPred => "R → R (P)"
  | .Read2ReadNoPred => "R → R (NP)"
  | .Read2WritePred => "R → W (P)"
  | .Read2WriteNoPred => "R → W (NP)"
  | .Write2Read => "W → R"
  | .Write2Write => "W → W"

instance : ToString BlockingKinds where toString := BlockingKinds.toString

class ArchReq where
  (type : Type 0)
  (instBEq : BEq type)
  (instInhabited : Inhabited type)
  (instToString : ToString type)
  (prettyPrint : type → String := instToString.toString)
  (isPermanentRead : type → Bool := λ _ => false)

variable [ArchReq]

inductive Atomicity where
  | nonatomic : Atomicity
  | transactional : Atomicity
  | atomic : Atomicity
  deriving BEq, Inhabited

instance : ToString Atomicity where toString
  | .nonatomic => ""
  | .transactional => "t"
  | .atomic => "a"

structure ReadRequest where
 addr : Address
 reads_from : Option RequestId
 atomicity : Atomicity
 val : Value
 deriving BEq, Inhabited

structure WriteRequest where
 addr : Address
 val : ConditionalValue
 atomicity : Atomicity
 deriving BEq, Inhabited

instance : BEq ArchReq.type := ArchReq.instBEq
instance : Inhabited ArchReq.type := ArchReq.instInhabited
instance : ToString ArchReq.type := ArchReq.instToString

inductive BasicRequest
 | read : ReadRequest → ArchReq.type → BasicRequest
 | write : WriteRequest → ArchReq.type → BasicRequest
 | fence : ArchReq.type → BasicRequest
 deriving BEq

instance : Inhabited BasicRequest where default := BasicRequest.fence default

def BasicRequest.atomicity : BasicRequest → Atomicity
  | .read rr _ => rr.atomicity
  | .write wr _ => wr.atomicity
  | .fence _ => .nonatomic

def BasicRequest.toString : BasicRequest → String
  | BasicRequest.read  rr ty =>
    let tyStr := match s!"{ty}" with | "" => "" | str => s!". {str}"
    s!"R{rr.atomicity}{tyStr} {rr.addr.prettyPrint}" ++ match rr.val with | none => "" | some v => s!" // {v}"
  | BasicRequest.write  wr ty =>
    let tyStr := match s!"{ty}" with | "" => "" | str => s!". {str}"
    s!"W{wr.atomicity}{tyStr} {wr.addr.prettyPrint} {wr.val}"
  | BasicRequest.fence ty =>
    let tyStr := match s!"{ty}" with | "" => "" | str => s!". {str}"
    s!"Fence{tyStr}"

def BasicRequest.prettyPrint : BasicRequest → String
  | BasicRequest.read rr ty =>
    let valStr := match rr.val with
      | none => ""
      | some val => s!"({val})"
    let tyStr := match s!"{ArchReq.prettyPrint ty}" with
      | "" => ""
      | str => s!".{str}"
    s!"R{rr.atomicity}{tyStr} {rr.addr.prettyPrint}{valStr}"
  | BasicRequest.write  wr ty =>
    let tyStr := match s!"{ArchReq.prettyPrint ty}" with
      | "" => ""
      | str => s!".{str}"
    s!"W{wr.atomicity}{tyStr} {wr.addr.prettyPrint}({wr.val})"
  | BasicRequest.fence ty =>
    let tyStr := match s!"{ArchReq.prettyPrint ty}" with
      | "" => ""
      | str => s!".{str}"
    s!"Fence{tyStr}"

instance : ToString (BasicRequest) where toString := BasicRequest.toString

def BasicRequest.type : BasicRequest → ArchReq.type
  | BasicRequest.read  _ t => t
  | BasicRequest.write  _ t => t
  | BasicRequest.fence t => t

def BasicRequest.readRequest? : BasicRequest → Option ReadRequest
  | BasicRequest.read  rr _ => some rr
  | BasicRequest.write  _ _ => none
  | BasicRequest.fence _ => none

def BasicRequest.writeRequest? : BasicRequest → Option WriteRequest
  | BasicRequest.read  _ _ => none
  | BasicRequest.write  wr _ => some wr
  | BasicRequest.fence _ => none

def BasicRequest.updateType : BasicRequest → (ArchReq.type → ArchReq.type) → BasicRequest
  | .read  rr t, f => .read rr (f t)
  | .write  wr t, f => .write wr (f t)
  | .fence t, f => .fence (f t)

def BasicRequest.setValue : BasicRequest → Value → BasicRequest
  | BasicRequest.read rr rt, v => BasicRequest.read {rr with val := v} rt
  | br, _ => br

def BasicRequest.updateValue : BasicRequest → Value → BasicRequest
  | BasicRequest.write wr rt, v => BasicRequest.write {wr with val := wr.val.update v} rt
  | br, _ => br

def BasicRequest.validateWrite : BasicRequest → BasicRequest
  | BasicRequest.write wr rt => BasicRequest.write {wr with val := wr.val.validate} rt
  | br => br

def BasicRequest.value? : BasicRequest → Value
  | BasicRequest.read rr _ => rr.val
  | BasicRequest.write wr _ => match wr.val with
    | .const n => some n
    | .tentative n => some n
    |  _ => none
  | _ => none

def BasicRequest.conditionalValue? : BasicRequest → Option ConditionalValue
  | .write wr _ => some wr.val
  | _ => none

structure ValidScopes where
  system_scope : List ThreadId
  scopes : ListTree ThreadId
  --scopes_consistent : ∀ s, scopes.elem s → s.sublist system_scope
  --system_scope_is_scope : system_scope ∈ scopes

def ValidScopes.default : ValidScopes :=
    { system_scope := [], scopes := ListTree.leaf [],
     -- scopes_consistent :=
     --     (by
     --      intros s h
     --      simp [ListTree.elem] at h
     --      rw [h]
     --      simp),
     -- system_scope_is_scope :=
     --     (by simp [ (· ∈ ·) ])
    }

instance : Inhabited ValidScopes where default := ValidScopes.default

def ValidScopes.toStringHet (threadType : Option (ThreadId → String)) (scopes : ValidScopes) : String :=
  let scopeFun := match threadType with
    | none => λ _ => ""
    | some f => λ ss =>
       let labs := removeDuplicates $ List.map f ss
       if labs == ["default"] || labs == [] then "" else
       if labs.length == 1 then labs.head! else
       String.intercalate "+" labs
  let scopeLab := λ s : List ThreadId => if s.isEmpty then "" else toString s ++ scopeFun s
  "{" ++ String.intercalate ", " (scopes.scopes.toList.map scopeLab) ++ "}"

def ValidScopes.toString (scopes : ValidScopes) : String := scopes.toStringHet none
instance : ToString ValidScopes where toString := ValidScopes.toString

open Lean in
private def quoteValidScopes : ValidScopes → Term
  | ValidScopes.mk system_scope scopes /-consistent system_is_scope-/ => Syntax.mkCApp ``ValidScopes.mk #[quote system_scope, quote scopes] -- , sorry, sorry]
instance : Lean.Quote ValidScopes where quote := quoteValidScopes

structure Scope {V : ValidScopes} where
  threads : List ThreadId
  valid : threads ∈ V.scopes

instance {V : ValidScopes} : ToString (@Scope V) where toString := λ ⟨threads,_⟩ => s!"{threads}"

instance {V : ValidScopes} : BEq (@Scope V) where
  beq := λ scope₁ scope₂ => scope₁.threads == scope₂.threads

instance {V : ValidScopes} : BEq (@Scope V) where
  beq := λ scope₁ scope₂ => scope₁.threads == scope₂.threads

instance {V : ValidScopes} : LE (@Scope V) where
  le := λ scope₁ scope₂ => List.sublist scope₁.threads scope₂.threads

structure Request where
  id : RequestId
  propagated_to : List ThreadId
  predecessor_at : List ThreadId
  thread : ThreadId
  basic_type : BasicRequest
  occurrence : Nat
  pairedRequest? : Option RequestId
  -- scope : Scope
  -- type : α
  deriving BEq

def Request.default : Request :=
  {id := 0, propagated_to := [], predecessor_at := [], thread := 0,
   occurrence := 0, basic_type := BasicRequest.fence Inhabited.default, pairedRequest? := none}
instance : Inhabited (Request) where default := Request.default

def Request.toString : Request → String
  | req => s!" Request {req.id} {req.basic_type.prettyPrint} : [propagated to {req.propagated_to}, origin thread : {req.thread}, pred. at : {req.predecessor_at}]"
instance : ToString (Request) where toString := Request.toString

def Request.toShortString : Request → String
  | req => s!"{req.id}[{req.basic_type.toString}]"

def BasicRequest.isRead    (r : BasicRequest) : Bool := match r with | read  _ _ => true | _ => false
def BasicRequest.isWrite   (r : BasicRequest) : Bool := match r with | write _ _ => true | _ => false
def BasicRequest.isFence (r : BasicRequest) : Bool := match r with | fence _ => true | _ => false

def BasicRequest.isAtomic (r : BasicRequest) : Bool := match r with | .read rr _ => rr.atomicity == .atomic | .write wr _ => wr.atomicity == .atomic | .fence _ => false
def BasicRequest.isTransactional (r : BasicRequest) : Bool := match r with | .read rr _ => rr.atomicity == .transactional | .write wr _ => wr.atomicity == .transactional | .fence _ => false
def Request.isRead    (r : Request) : Bool := r.basic_type.isRead
def Request.isWrite   (r : Request) : Bool := r.basic_type.isWrite
def Request.isFence (r : Request) : Bool := r.basic_type.isFence
def Request.isMem     (r : Request) : Bool := !r.basic_type.isFence
def Request.isPermanentRead (r : Request) : Bool := r.isRead && ArchReq.isPermanentRead r.basic_type.type

def Request.value? (r : Request) : Value := r.basic_type.value?
def Request.setValue (r : Request) (v : Value) : Request := { r with basic_type := r.basic_type.setValue v}
def Request.updateValue (r : Request) (v : Value) : Request :=
  { r with basic_type := r.basic_type.updateValue v}
def Request.validateWrite (r : Request) : Request := { r with basic_type := r.basic_type.validateWrite}
def Request.isSatisfied (r : Request) : Bool := match r.basic_type with
  | .read rr _ => rr.val.isSome
  | _ => false

def Request.isAtomic (r : Request) : Bool := r.basic_type.isAtomic
def Request.isTransactional (r : Request) : Bool := r.basic_type.isTransactional

def BasicRequest.address? (r : BasicRequest) : Option Address := match r with
  | read  req _ => some req.addr
  | write req _ => some req.addr
  | _ => none

def Request.address? (r : Request) : Option Address := r.basic_type.address?

def Request.equivalent (r₁ r₂ : Request) : Bool :=
  if r₁.isFence then r₁.basic_type == r₂.basic_type
  else r₁.address? == r₂.address? && r₁.value? == r₂.value? && r₁.thread == r₂.thread &&
       ((r₁.isWrite && r₂.isWrite) || (r₁.isRead && r₂.isRead))

-- Read, Write
def SatisfiedRead := RequestId × RequestId deriving ToString, BEq

--instance [BEq α] : Membership (List α) (ListTree α) where
--  mem lst tree := tree.elem lst = true

def decideThreadsValid (threads : List ThreadId) (V : ValidScopes) : Decidable (threads ∈ V.scopes) :=
  if h : V.scopes.elem threads then
    Decidable.isTrue h
  else
    Decidable.isFalse h

instance {threads : List ThreadId} {V : ValidScopes} : Decidable (threads ∈ V.scopes) := decideThreadsValid threads V

def ValidScopes.validate (V : ValidScopes) (threads : List ThreadId) : Option (@Scope V) :=
    if h : threads ∈ V.scopes then
        some { threads := threads, valid := h }
    else
        none

-- Gives the subscopes of S, including S.
def ValidScopes.subscopes (V : ValidScopes) (S : @Scope V) : List (@Scope V) :=
  let children := V.scopes.nodesBelow S.threads
  filterNones $ children.map V.validate

def ValidScopes.containThread (V: ValidScopes) (t : ThreadId) : List (@Scope V) :=
  let containing := V.scopes.nodesAbove [t]
  filterNones $ containing.map V.validate

def ValidScopes.systemScope {V : ValidScopes } : @Scope V :=
  {threads := V.system_scope, valid := sorry} -- V.system_scope_is_scope}

instance {V : ValidScopes} : Inhabited (@Scope V) where
 default := V.systemScope

def ValidScopes.isUnscoped (V : ValidScopes) : Bool :=
  V.scopes == (ListTree.leaf V.system_scope)

def ValidScopes.jointScope : (V : ValidScopes) → ThreadId → ThreadId → (@Scope V)
 | valid, t₁, t₂ => match valid.scopes.meet t₁ t₂ with
   | some scope => {threads := scope, valid := sorry}
   | none => panic! s!"can't find the joint scope of {t₁} and {t₂} in {valid.scopes}"-- can we get rid of this case distinction?

def ValidScopes.reqThreadScope (V : ValidScopes ) (req : Request) : (@Scope V) :=
   V.jointScope req.thread req.thread

def ValidScopes.intersection : (V : ValidScopes) → @Scope V → @Scope V → Option (@Scope V)
  | V, s1, s2 => V.validate $ s1.threads.intersection s2.threads

def Request.propagatedTo (r : Request) (t : ThreadId) : Bool := r.propagated_to.elem t

def Request.fullyPropagated {V : ValidScopes}  (r : Request) (s : optParam (@Scope V) V.systemScope) : Bool :=
  let propToList := s.threads.map (λ t => Request.propagatedTo r t)
  propToList.foldl (init:= true) (. && .)

def Request.isPredecessorAt (req : Request) (thId : ThreadId) : Bool :=
  req.predecessor_at.contains thId

def Request.makePredecessorAt (req : Request) (thId : ThreadId) : Request :=
  if req.isPredecessorAt thId then req else { req with predecessor_at := thId :: req.predecessor_at}

/-
 We have scoped order constraints, i.e. a different set of order constraints
 for each scope. Order constraints specify a partial order on requests, and
 we represent them with a Bool value for a pair of (r₁,r₂) : RequestId × RequestId,
 which is true ↔ there is an order constraint r₁ →s r₂, for the scope s.

 However, we have a property (by construction) that if s' ≤ s and r₁ →s r₂, then
 also r₁ →s' r₂. Can we use this to find a more compact representation?
-/
structure OrderConstraints {V : ValidScopes} where
  val : Std.HashMap (List ThreadId) (Std.HashMap (RequestId × RequestId) Bool)
  default : Bool

def OrderConstraints.empty {V : ValidScopes} (numReqs : optParam Nat 10) : @OrderConstraints V :=
 let scopes := V.scopes.toList
 { default := false, val :=
 Std.mkHashMap (capacity := scopes.length) |> scopes.foldl λ acc s => acc.insert s (Std.mkHashMap (capacity := numReqs))
 }

-- TODO: make scope an optional parameter and just do the intersection by default?
-- Would need to move around things in Arch typeclass...
def OrderConstraints.lookup {V : ValidScopes} (ordc : @OrderConstraints V)
  (S : @Scope V) (req₁ req₂ : RequestId) : Bool :=
  let sc_ordc := ordc.val.find? S.threads
  match sc_ordc with
    | none => ordc.default
    | some hashmap =>
      hashmap.findD (req₁, req₂) ordc.default

def OrderConstraints.predecessors {V : ValidScopes} (S : @Scope V) (req : RequestId)
    (reqs : List RequestId) (constraints : @OrderConstraints V)  : List RequestId :=
    let sc_oc := constraints.lookup S -- hope this gets optimized accordingly...
    reqs.filter (λ x => sc_oc x req)

def OrderConstraints.successors {V : ValidScopes} (S : @Scope V) (req : RequestId)
  (reqs : List RequestId) (constraints : @OrderConstraints V)  : List RequestId :=
  let sc_oc := constraints.lookup S -- hope this gets optimized accordingly...
  reqs.filter (λ x => sc_oc req x)

 def OrderConstraints.transitiveSuccessors {V : ValidScopes} (S : @Scope V) (req : RequestId)
   (reqs : List RequestId) (constraints : @OrderConstraints V)  : List RequestId :=
   let sc_oc := constraints.lookup S
   Id.run do
     let mut succ := []
     let mut succ' := [req]
     while succ != succ' do
       succ := succ'
       succ' := reqs.filter
         λ x => succ'.any
           λ s => x == s || sc_oc s x
     return succ'

def OrderConstraints.between {V : ValidScopes} (S : @Scope V) (req₁ req₂ : RequestId)
  (reqs : List RequestId) (constraints : @OrderConstraints V)  : List RequestId :=
  let preds₁ := constraints.predecessors S req₁ reqs
  let preds₂ := constraints.predecessors S req₂ reqs
  preds₂.removeAll (req₁::preds₁)

-- TODO: is this really a quasi top sort?
def OrderConstraints.qtopSort {V : ValidScopes} (S : @Scope V)
  (reqs : List Request) (constraints : @OrderConstraints V)  : List Request :=
  reqs.toArray.qsort (λ r₁ r₂ => constraints.lookup S r₁.id r₂.id) |>.toList

/-
def SystemState.betweenRequests (state : SystemState) (req₁ req₂ : Request) : List Request :=
  let betweenIds := state.orderConstraints.between
    req₁.id req₂.id (reqIds state.requests)
  state.idsToReqs betweenIds
  -/

def OrderConstraints.compare {V₁ V₂ : ValidScopes} ( oc₁ : @OrderConstraints V₁) (oc₂ : @OrderConstraints V₂)
  (requests : List RequestId) : Bool :=
  if V₁.scopes.toList != V₂.scopes.toList
    then false
    else
      let scopes₁ := V₁.scopes.toList.map V₁.validate
      let scopes₂ := V₂.scopes.toList.map V₂.validate
      let scopes := scopes₁.zip scopes₂ -- pretty hacky: should get types to match
      let reqPairs := List.join $ requests.map λ r₁ => requests.foldl (init := []) λ reqs r₂ => (r₁,r₂)::reqs
      let keys := List.join $ scopes.map λ s => reqPairs.foldl (init := []) λ ks (r₁,r₂) => (s,r₁,r₂)::ks
      keys.all λ (s,r₁,r₂) => match s with
        | (some s₁, some s₂) => (oc₁.lookup s₁ r₁ r₂ == oc₂.lookup s₂ r₁ r₂)
        | _ => panic! s!"invalid scopes {scopes₁} or {scopes₂}"

def OrderConstraints.addSingleScope {V : ValidScopes} (constraints : @OrderConstraints V)
  (scope : @Scope V) (reqs : List (RequestId × RequestId)) (val := true) : @OrderConstraints V :=
  match constraints.val.find? scope.threads with
   | none => constraints
   | some sc_oc =>
       let sc_oc' := reqs.foldl (init := sc_oc) λ oc req => oc.insert req val
       let val' := constraints.val.insert scope.threads sc_oc'
       { constraints with val := val' }

-- Updates `constraints` to add all pairs in `reqs` to the scope `scope` and each
-- of its suscopes. The optional value `val` is what the constraint is updated to,
-- and defaults to `true`.
def OrderConstraints.addSubscopes {V : ValidScopes} (constraints : @OrderConstraints V)
(scope : @Scope V) (reqs : List (RequestId × RequestId)) (val := true) : @OrderConstraints V :=
  let subscopes := V.subscopes scope
  --dbg_trace s!"{scope.threads}.subscopes: {subscopes.map λ s => s.threads}"
  subscopes.foldl (init := constraints) λ oc sc => oc.addSingleScope sc reqs (val := val)

def OrderConstraints.swap {V : ValidScopes} (oc : @OrderConstraints V)
  (scope : @Scope V) (req₁ req₂ : RequestId) : @OrderConstraints V :=
  let c₁₂ := oc.lookup scope req₁ req₂
  let c₂₁ := oc.lookup scope req₂ req₁
  Id.run do
    if c₁₂ == c₂₁ then
      panic! "cycle {req₁.id} ↔ {req₂.id} detected in order constraints."
    let mut add := []
    let mut remove := []
    if c₁₂ then
      add :=( req₂,req₁) :: add
      remove :=( req₁,req₂) :: remove
    if c₂₁ then
      add :=( req₁,req₂) :: add
      remove :=( req₂,req₁) :: remove
    let mut oc' := oc
    oc' := oc'.addSubscopes scope add
    oc' := oc'.addSubscopes scope remove (val := false)
    return oc'

def OrderConstraints.groupsToString : List Request → List Request → String
  | [],_ => ""
  | _,[] => ""
  | reqs₁, reqs₂ =>
    let vars₁ := removeDuplicates $ reqs₁  |>.map Request.address?
    let vars₂ := removeDuplicates $ reqs₂  |>.map Request.address?
    let vars := vars₁.filter vars₂.contains
    let colorFun := λ r => if vars.contains r.address? && r.address?.isSome then
      colorString Color.magenta r.toShortString else r.toShortString
    let (r₁strings, r₂strings) := (reqs₁.map colorFun, reqs₂.map colorFun)
    "{" ++ (String.intercalate ", " $ r₁strings) ++
                    "} → {" ++ (String.intercalate ", " $ r₂strings) ++ "}"

def OrderConstraints.toString {V : ValidScopes} (constraints : @OrderConstraints V) (scope : @Scope V) (reqs : List Request) : String := Id.run do
   let reqsSorted := constraints.qtopSort scope reqs
   let mut pairs := []
   for req in reqsSorted do
     let deps := reqsSorted.filter λ req' => constraints.lookup scope req.id req'.id
       if deps.isEmpty then
         continue
       pairs := pairs ++ [ (req,deps) ]
   let mut res : List (List Request × List Request) := []
   for (req,deps) in pairs do
     if res.any λ (lhs,_) => lhs.contains req then
       continue
     let mut lhs := [req]
     for req' in reqsSorted do
       if req' == req then
         continue
       if pairs.lookup req' == some deps then
         lhs := req'::lhs
     res := res ++ [(lhs,deps)]
   String.intercalate ";   " $ res.map λ (lhs,rhs) => OrderConstraints.groupsToString lhs rhs

private def opReqId? : Option (Request) → Option RequestId := Option.map λ r => r.id

private def valConsistent (vals :  Array (Option (Request))) : Bool :=
  let valOpIds := vals.map opReqId?
  let valConsistent := λ idx opVal => match opVal with
    | none => true
    | some val => val == idx.val
  let consistentVals := valOpIds.mapIdx valConsistent
  consistentVals.foldl (. && .) true

structure RequestArray where
  val : Array (Option (Request))
  coherent : valConsistent val = true

instance : BEq (RequestArray) where beq := λ arr₁ arr₂ => arr₁.val == arr₂.val

def RequestArray.getReq? : RequestArray → RequestId → Option (Request)
  | arr, rId => match arr.val[rId.toNat]? with
    | some (some req) => some req
    | _ => none

def RequestArray.getReq! : RequestArray → RequestId → Request
  | arr, rId => arr.val[rId.toNat]?.get!.get!

def RequestArray.printReq : RequestArray → RequestId → String
  | arr, rId => match arr.getReq? rId with
    | none => ""
    | some r => r.toShortString

def RequestArray.seen : RequestArray → List RequestId
  | arr => List.range arr.val.size

def RequestArray.map {β : Type} : RequestArray → (Request → β) → Array β
 | rarr, f => filterNonesArr $ rarr.val.map λ opreq => Option.map f opreq
-- instance : GetElem RequestArray RequestId (Option Request) where getElem

theorem emptyArrayCoherent : valConsistent (Array.mk ([] : List (Option (Request)))) := by
  sorry -- metavariable screws up simp

def RequestArray.empty : RequestArray :=
  { val := Array.mk [], coherent := emptyArrayCoherent }

def RequestArray.toString : RequestArray → String
  | arr => String.intercalate ",\n" $ List.map Request.toString $ filterNones arr.val.toList

instance : ToString (RequestArray) where toString := RequestArray.toString

def RequestArray.filter : RequestArray → (Request → Bool) → List Request
  | ra, f =>
  let fOp : Option Request → Bool
    | some r => f r
    | none => false
  filterNones $ Array.toList $ ra.val.filter fOp

def RequestArray.prettyPrint (arr : RequestArray) (numThreads : Nat) (order : @OrderConstraints V) (colWidth := 25) (highlight : optParam (Option $ ThreadId × RequestId) none) : String := Id.run do
  let mut threads := []
  let mut res := ""
  for thId in (List.range numThreads) do
    if thId != 0 then
      res := res ++ "||"
    res := res ++ s!" T{thId}" ++ (String.mk $ List.replicate (colWidth - 3) ' ')
    let mut thread := []
    for req in arr.filter (λ r => !(r.isWrite && r.value? == some 0)) do
      if highlight == some (thId, req.id) then
        thread := thread ++ [(Color.yellow, req)]
      else if req.thread == thId then
        thread := thread ++ [(Color.cyan, req)]
      else if req.propagatedTo thId then
        thread := thread ++ [(Color.black, req)]
    threads := threads ++ [thread]
  res := res ++ "|\n" ++ (String.mk $ List.replicate (colWidth * numThreads + 2 * (numThreads - 1)) '-') ++ "\n"
  threads := threads.map
    (λ th => th.toArray.qsort
      (λ r₁ r₂ => order.lookup (V.jointScope r₁.2.thread r₂.2.thread) r₁.2.id r₂.2.id)
        |>.toList)
  while threads.any (!·.isEmpty) do
    let mut sep := false
    for thread in threads do
      if sep then
        res := res ++ "||"
      else
        sep := true
      res := res ++ match thread.head? with
        | none => (String.mk $ List.replicate colWidth ' ')
        | some (color,r) => " " ++ (colorString color r.toShortString) ++ (String.mk $ List.replicate (colWidth - r.toShortString.length - 1) ' ')
    res := res ++ "|\n"
    threads := threads.map List.tail
  return res

def reqIds : (RequestArray) → List RequestId
 | arr =>
   let opIds :=  Array.toList $ arr.val.map (Option.map Request.id)
   filterNones opIds

def growArray {α : Type} (a : Array (Option α)) (n : Nat) : Array (Option α) :=
  --dbg_trace s!"growing array of size {a.size} by {n}"
  a.append (Array.mkArray (a.size - n) none)

private def RequestArray._insert : RequestArray → Request → Array (Option (Request))
  | arr, req =>
    --dbg_trace "growing [{arr}] of size {arr.val.size} to {req.id.toNat + 1} for Request {req}"
    let vals' := growArray arr.val (req.id.toNat + 1)
    let i := req.id.toNat.toUSize
    if h : i.toNat < vals'.size
    then vals'.uset i (some req) h
    -- If we use `i.toNat == vals'.size` then Lean won't unfold the typeclass
    -- instance of BEq.beq (which is Nat.beq) and we can't use Nat.beq_eq.
    -- Maybe ask on Zulip?
    else if h: (Nat.beq i.toNat vals'.size) then
      let hless : i.toNat < vals'.size + 1 := by
        {apply Nat.lt_of_succ_le
         apply Nat.le_of_eq
         rw [Nat.succ_eq_add_one]
         rw [Nat.beq_eq] at h
         rw [h]
         }
      let idfin := Fin.mk i.toNat hless
      vals'.insertAt idfin (some req)
    else unreachable! -- because of growArray before

-- can't be proving these things right now
theorem RequestArrayInsertConsistent (arr : RequestArray) (req : Request) :
  valConsistent (arr._insert req) = true := by sorry
  -- unfold RequestArray._insert
  -- simp

def RequestArray.insertAtPosition : RequestArray → Option (Request) → USize → RequestArray
  | arr, opReq, i =>
    let val' := if h : i.toNat < arr.val.size
      then arr.val.uset i opReq h
      else match opReq with
        | some req => arr._insert req
        | none => arr.val
      -- RequestArrayInsertConsistent arr req
    { val := val', coherent := sorry}

-- Inserst request at the position given by its id.
-- Will overwrite another request with that same id.
def RequestArray.insert : RequestArray → Request → RequestArray
  | arr, req =>
    let i := req.id.toNat.toUSize
    arr.insertAtPosition (some req) i

def RequestArray.remove : RequestArray → RequestId → RequestArray
  | arr, reqId =>
  match arr.getReq? reqId with
    | none => arr
    | some req =>
      let i := req.id.toNat.toUSize
      arr.insertAtPosition none i

structure SystemState where
  requests : RequestArray
  removed : List (Request) -- TODO: remove, def. "active" to ignore satisfied reads
  scopes : ValidScopes
  satisfied : List SatisfiedRead
  threadTypes : ThreadId → String
  orderConstraints : @OrderConstraints scopes
  removedCoherent : ∀ id : RequestId, id ∈ (removed.map Request.id) → id ∈ reqIds requests

def SystemState.beq (state₁ state₂ : SystemState)
  -- (samesystem : state₁.system = state₂.system)
  : Bool :=
  state₁.requests == state₂.requests &&
  state₁.removed == state₂.removed &&
  state₁.satisfied == state₂.satisfied &&
  -- this will be expensive!
  state₁.orderConstraints.compare state₂.orderConstraints (reqIds state₁.requests)

instance : BEq (SystemState) where beq := SystemState.beq

def SystemState.findMaybeRemoved? (state : SystemState) (rId : RequestId) : Option Request :=
  match state.requests.getReq? rId with
    | some r => some r
    | none => state.removed.find? (·.id == rId)

def SystemState.oderConstraintsString (state : SystemState)
(scope : optParam (@Scope state.scopes) state.scopes.systemScope) : String :=
  state.orderConstraints.toString scope $ filterNones $ state.requests.val.toList

def SystemState.threads : SystemState → List ThreadId
 | s => s.scopes.system_scope

def SystemState.prettyPrint (state : SystemState) (highlight : optParam (Option $ ThreadId × RequestId) none) : String :=
  let ocString := if state.scopes.scopes.toList.length == 1
    then s!"constraints: {state.oderConstraintsString}\n"
    else String.intercalate "\n" $ state.scopes.scopes.toList.map
      λ scope => s!"constraints (scope {scope}) : {state.oderConstraintsString (state.scopes.validate scope).get!}"
  let satisfiedStr := state.satisfied.map
    λ (r₁, r₂) => s!"{(state.findMaybeRemoved? r₁).get!.toShortString} with {state.requests.printReq r₂}"
  s!"requests:\n{state.requests.toString}\n\n"++
  s!"{state.requests.prettyPrint state.threads.length state.orderConstraints (highlight := highlight)}\n"  ++
  s!"removed: {state.removed.toString}\n" ++
  s!"satisfied: {satisfiedStr}\n" ++
  ocString

def SystemState.toString : SystemState → String
  | state =>
  let ocString := if state.scopes.scopes.toList.length == 1
    then s!"constraints: {state.oderConstraintsString}\n"
    else String.intercalate "\n" $ state.scopes.scopes.toList.map
      λ scope => s!"constraints (scope {scope}) : {state.oderConstraintsString (state.scopes.validate scope).get!}"
  let satisfiedStr := state.satisfied.map
    λ (r₁, r₂) => s!"{(state.findMaybeRemoved? r₁).get!.toShortString} with {state.requests.printReq r₂}"
  s!"requests:\n{state.requests}\n"  ++
  s!"removed: {state.removed.toString}\n" ++
  s!"satisfied: {satisfiedStr}\n" ++
  ocString

def SystemState.orderPredecessors (state : SystemState) (scope : @Scope state.scopes)
  (reqId : RequestId) : List RequestId :=
  state.orderConstraints.predecessors scope reqId (reqIds state.requests)

instance : ToString (SystemState) where toString := SystemState.toString

theorem emptyCoherent (requests : RequestArray) :
  ∀ id : RequestId, id ∈ [] → id ∈ reqIds requests := by
  intros id h
  contradiction

theorem empty2Coherent (seen : List RequestId) :
  ∀ id₁ id₂ : RequestId, (id₁,id₂) ∈ [] → id₁ ∈ seen ∧ id₂ ∈ seen := by
  intros
  contradiction

def SystemState.init (S : ValidScopes) (threadTypes : ThreadId → String): SystemState :=
  { requests := RequestArray.empty, removed := [],
    scopes := S, satisfied := [], orderConstraints := OrderConstraints.empty,
    removedCoherent := emptyCoherent RequestArray.empty, threadTypes
  }

def SystemState.default := SystemState.init ValidScopes.default (λ _ => "default")
instance : Inhabited (SystemState) where default := SystemState.default

def SystemState.seen : SystemState → List RequestId
  | state => state.requests.seen

def SystemState.idsToReqs : SystemState → List RequestId → List (Request)
  | state, ids => filterNones $ ids.map (λ id => state.requests.getReq? id)

def SystemState.isSatisfied : SystemState → RequestId → Bool
  | state, rid =>
  !(state.satisfied.filter λ (srd,_) => srd == rid).isEmpty

def SystemState.reqPropagatedTo : SystemState → RequestId → ThreadId → Bool
  | state, rid, tid => match state.requests.getReq? rid with
    | none => false
    | some req => req.propagatedTo tid

def SystemState.updateRequest : SystemState → Request → SystemState
  | state, request =>
   let requests' := state.requests.insert request
   SystemState.mk requests' state.removed state.scopes state.satisfied
   state.threadTypes state.orderConstraints sorry
   --{requests := requests', seen := state.seen, removed := state.removed,
   -- scopes := state.scopes, satisfied := state.satisfied,
   -- orderConstraints := state.orderConstraints,
   -- seenCoherent := state.seenCoherent, removedCoherent := state.removedCoherent,
   -- satisfiedCoherent := state.satisfiedCoherent}
def SystemState.allRequests (state : SystemState) : List Request := state.removed ++ filterNones state.requests.val.toList

class Arch where
  (req : ArchReq)
  (orderCondition : ValidScopes → Request → Request → Bool)
  (blockingSemantics : Request → BlockingSemantics)
  (scopeIntersection : (valid : ValidScopes) → Request → Request → @Scope valid := λ v _ _ => v.systemScope)
  (predecessorConstraints : SystemState → RequestId → RequestId → Bool := λ _ _ _ => true)
  (acceptConstraints : SystemState → BasicRequest → ThreadId → Bool := λ _ _ _ => true)
  (acceptEffects : SystemState → RequestId → ThreadId → SystemState := λ st _ _ => st)
  (propagateConstraints : SystemState → RequestId → ThreadId → Bool := λ _ _ _ => true)
  (propagateEffects : SystemState → RequestId → ThreadId → SystemState := λ st _ _ => st)
  (satisfyReadConstraints : SystemState → RequestId → RequestId → Bool := λ _ _ _ => true)
  (satisfyReadEffects : SystemState → RequestId → RequestId → SystemState := λ st _ _ => st)

def Request.blockingSemantics  [inst : Arch] (req : @Request inst.req) : BlockingSemantics := Arch.blockingSemantics req

end Pop


import tactic.lint
import algebra.continued_fractions.computation.approximations
--set_option pp.all true
-- set_option profiler true
lemma another (g : 1000 = 2*500): 1000 = 2*500 ∧ 1000 = 2*500 :=
begin
  let h :ℕ :=1,
  exact ⟨rfl, rfl⟩
end
#print another
#lint

lemma foo (p : Prop) : p → p :=
assume hp : p,
have hp2 : p, from hp,
show p, from hp
#print foo

lemma fun_problem (p : Prop) : ¬ (p ↔ ¬ p) :=
assume hpnp,
have hnp : ¬ p, from
  assume hp : p,
  have hnp : ¬ p, from hpnp.mp hp,
  show false, from hnp hp,
have hp : p, from
  have unnecessary : ¬ p, from hnp,
  show p, from hpnp.mpr hnp,
show false, from hnp hp

open tactic declaration expr

meta def find_unused_have_macro : expr → tactic (list name)
| (app a a_1) := (++) <$> find_unused_have_macro a <*> find_unused_have_macro a_1
| (lam var_name bi var_type body) :=  find_unused_have_macro body
| (pi var_name bi var_type body) := find_unused_have_macro body
| (elet var_name type assignment body) := find_unused_have_macro body
| (macro md [lam ppnm _ _ bd]) := do
       (++) (if bd.has_zero_var then [] else [ppnm]) <$>
        find_unused_have_macro bd
| (macro md l) := do ls ← l.mmap find_unused_have_macro, return ls.join
| _ := return []

meta def find_unused_let_macro : expr → tactic (list name)
| (app a a_1) := (++) <$> find_unused_let_macro a <*> find_unused_let_macro a_1
| (lam var_name bi var_type body) :=  find_unused_let_macro body
| (pi var_name bi var_type body) := find_unused_let_macro body
| (elet var_name type assignment body) := do
  --trace body,
       (++) (if body.has_zero_var then [] else [var_name]) <$>
        find_unused_let_macro body

| (macro md [lam ppnm _ _ bd]) :=find_unused_let_macro bd
| (macro md l) := do ls ← l.mmap find_unused_let_macro, return ls.join
| _ := return []

meta def unused_of_decl : declaration → tactic (list name)
| (defn a a_1 a_2 bd a_4 a_5) := find_unused_let_macro bd
| (thm a a_1 a_2 bd) := find_unused_let_macro bd.get
| _ := return []

run_cmd
do d ← get_decl `generalized_continued_fraction.le_of_succ_succ_nth_continuants_aux_b,
unused_of_decl  d

@[linter] meta def linter.unused_lets : linter :=
{ test := λ d,
  (do
  --trace d.to_name,
  ns ← unused_of_decl d,
   if ns.length = 0 then return none else return (", ".intercalate (ns.map to_string))),
  no_errors_found := "all good",
  errors_found := "DECLS HAVE UNNEEDED LETS",
  is_fast := tt,
  auto_decls := ff }
lemma tmp : ∃ n, n = 1 :=
let a := 1, b:=1 in
begin
  set t := 2,
  use a,
end
#print tmp
#lint only unused_lets


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module data.rbtree.basic
! leanprover-community/mathlib commit 5cb17dd1617d2dc55eb17777c3dcded3306fadb5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Rbtree.Init
import Mathbin.Logic.IsEmpty
import Mathbin.Tactic.Interactive

universe u

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
unsafe def tactic.interactive.blast_disjs : tactic Unit :=
  sorry
#align tactic.interactive.blast_disjs tactic.interactive.blast_disjs

namespace Rbnode

variable {α : Type u}

open Color Nat

inductive IsNodeOf : Rbnode α → Rbnode α → α → Rbnode α → Prop
  | of_red (l v r) : is_node_of (red_node l v r) l v r
  | of_black (l v r) : is_node_of (black_node l v r) l v r
#align rbnode.is_node_of Rbnode.IsNodeOf

def Lift (lt : α → α → Prop) : Option α → Option α → Prop
  | some a, some b => lt a b
  | _, _ => True
#align rbnode.lift Rbnode.Lift

inductive IsSearchable (lt : α → α → Prop) : Rbnode α → Option α → Option α → Prop
  | leaf_s {lo hi} (hlt : Lift lt lo hi) : is_searchable leaf lo hi
  |
  red_s {l r v lo hi} (hs₁ : is_searchable l lo (some v)) (hs₂ : is_searchable r (some v) hi) :
    is_searchable (red_node l v r) lo hi
  |
  black_s {l r v lo hi} (hs₁ : is_searchable l lo (some v)) (hs₂ : is_searchable r (some v) hi) :
    is_searchable (black_node l v r) lo hi
#align rbnode.is_searchable Rbnode.IsSearchable

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
unsafe def is_searchable_tactic : tactic Unit :=
  sorry
#align rbnode.is_searchable_tactic rbnode.is_searchable_tactic

open Rbnode (Mem)

open IsSearchable

section IsSearchableLemmas

variable {lt : α → α → Prop}

theorem lo_lt_hi {t : Rbnode α} {lt} [IsTrans α lt] :
    ∀ {lo hi}, IsSearchable lt t lo hi → Lift lt lo hi :=
  by
  induction t <;> intro lo hi hs
  case leaf => cases hs; assumption
  all_goals
    cases hs
    have h₁ := t_ih_lchild hs_hs₁
    have h₂ := t_ih_rchild hs_hs₂
    cases lo <;> cases hi <;> simp [lift] at *
    apply trans_of lt h₁ h₂
#align rbnode.lo_lt_hi Rbnode.lo_lt_hi

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_of_isSearchable_of_incomp [IsStrictWeakOrder α lt] {t} :
    ∀ {lo hi hi'} (hc : ¬lt hi' hi ∧ ¬lt hi hi') (hs : IsSearchable lt t lo (some hi)),
      IsSearchable lt t lo (some hi') :=
  by
  classical
    induction t <;> intros <;>
      run_tac
        is_searchable_tactic
    · cases lo <;> simp_all [lift]
      apply lt_of_lt_of_incomp
      assumption
      exact ⟨hc.2, hc.1⟩
    all_goals apply t_ih_rchild hc hs_hs₂
#align rbnode.is_searchable_of_is_searchable_of_incomp Rbnode.isSearchable_of_isSearchable_of_incomp

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_of_incomp_of_isSearchable [IsStrictWeakOrder α lt] {t} :
    ∀ {lo lo' hi} (hc : ¬lt lo' lo ∧ ¬lt lo lo') (hs : IsSearchable lt t (some lo) hi),
      IsSearchable lt t (some lo') hi :=
  by
  classical
    induction t <;> intros <;>
      run_tac
        is_searchable_tactic
    · cases hi <;> simp_all [lift]
      apply lt_of_incomp_of_lt
      assumption
      assumption
    all_goals apply t_ih_lchild hc hs_hs₁
#align rbnode.is_searchable_of_incomp_of_is_searchable Rbnode.isSearchable_of_incomp_of_isSearchable

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_some_low_of_isSearchable_of_lt {t} [IsTrans α lt] :
    ∀ {lo hi lo'} (hlt : lt lo' lo) (hs : IsSearchable lt t (some lo) hi),
      IsSearchable lt t (some lo') hi :=
  by
  induction t <;> intros <;>
    run_tac
      is_searchable_tactic
  · cases hi <;> simp_all [lift]
    apply trans_of lt hlt
    assumption
  all_goals apply t_ih_lchild hlt hs_hs₁
#align rbnode.is_searchable_some_low_of_is_searchable_of_lt Rbnode.isSearchable_some_low_of_isSearchable_of_lt

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_none_low_of_isSearchable_some_low {t} :
    ∀ {y hi} (hlt : IsSearchable lt t (some y) hi), IsSearchable lt t none hi :=
  by
  induction t <;> intros <;>
    run_tac
      is_searchable_tactic
  · simp [lift]
  all_goals apply t_ih_lchild hlt_hs₁
#align rbnode.is_searchable_none_low_of_is_searchable_some_low Rbnode.isSearchable_none_low_of_isSearchable_some_low

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_some_high_of_isSearchable_of_lt {t} [IsTrans α lt] :
    ∀ {lo hi hi'} (hlt : lt hi hi') (hs : IsSearchable lt t lo (some hi)),
      IsSearchable lt t lo (some hi') :=
  by
  induction t <;> intros <;>
    run_tac
      is_searchable_tactic
  · cases lo <;> simp_all [lift]
    apply trans_of lt
    assumption
    assumption
  all_goals apply t_ih_rchild hlt hs_hs₂
#align rbnode.is_searchable_some_high_of_is_searchable_of_lt Rbnode.isSearchable_some_high_of_isSearchable_of_lt

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_none_high_of_isSearchable_some_high {t} :
    ∀ {lo y} (hlt : IsSearchable lt t lo (some y)), IsSearchable lt t lo none :=
  by
  induction t <;> intros <;>
    run_tac
      is_searchable_tactic
  · cases lo <;> simp [lift]
  all_goals apply t_ih_rchild hlt_hs₂
#align rbnode.is_searchable_none_high_of_is_searchable_some_high Rbnode.isSearchable_none_high_of_isSearchable_some_high

theorem range [IsStrictWeakOrder α lt] {t : Rbnode α} {x} :
    ∀ {lo hi}, IsSearchable lt t lo hi → Mem lt x t → Lift lt lo (some x) ∧ Lift lt (some x) hi :=
  by
  classical
    induction t
    case leaf => simp [mem]
    all_goals
      -- red_node and black_node are identical
      intro lo hi h₁ h₂
      cases h₁
      simp only [mem] at h₂
      have val_hi : lift lt (some t_val) hi :=
        by
        apply lo_lt_hi
        assumption
      have lo_val : lift lt lo (some t_val) :=
        by
        apply lo_lt_hi
        assumption
      cases_type*or.1
      · have h₃ : lift lt lo (some x) ∧ lift lt (some x) (some t_val) :=
          by
          apply t_ih_lchild
          assumption
          assumption
        cases' h₃ with lo_x x_val
        constructor
        show lift lt lo (some x)
        · assumption
        show lift lt (some x) hi
        · cases' hi with hi <;> simp [lift] at *
          apply trans_of lt x_val val_hi
      · cases h₂
        cases' lo with lo <;> cases' hi with hi <;> simp [lift] at *
        · apply lt_of_incomp_of_lt _ val_hi
          simp [*]
        · apply lt_of_lt_of_incomp lo_val
          simp [*]
        constructor
        · apply lt_of_lt_of_incomp lo_val
          simp [*]
        · apply lt_of_incomp_of_lt _ val_hi
          simp [*]
      · have h₃ : lift lt (some t_val) (some x) ∧ lift lt (some x) hi :=
          by
          apply t_ih_rchild
          assumption
          assumption
        cases' h₃ with val_x x_hi
        cases' lo with lo <;> cases' hi with hi <;> simp [lift] at *
        · assumption
        · apply trans_of lt lo_val val_x
        constructor
        · apply trans_of lt lo_val val_x
        · assumption
#align rbnode.range Rbnode.range

theorem lt_of_mem_left [IsStrictWeakOrder α lt] {y : α} {t l r : Rbnode α} :
    ∀ {lo hi}, IsSearchable lt t lo hi → IsNodeOf t l y r → ∀ {x}, Mem lt x l → lt x y :=
  by
  intro _ _ hs hn x hm; cases hn <;> cases hs
  all_goals exact (range hs_hs₁ hm).2
#align rbnode.lt_of_mem_left Rbnode.lt_of_mem_left

theorem lt_of_mem_right [IsStrictWeakOrder α lt] {y : α} {t l r : Rbnode α} :
    ∀ {lo hi}, IsSearchable lt t lo hi → IsNodeOf t l y r → ∀ {z}, Mem lt z r → lt y z :=
  by
  intro _ _ hs hn z hm; cases hn <;> cases hs
  all_goals exact (range hs_hs₂ hm).1
#align rbnode.lt_of_mem_right Rbnode.lt_of_mem_right

theorem lt_of_mem_left_right [IsStrictWeakOrder α lt] {y : α} {t l r : Rbnode α} :
    ∀ {lo hi},
      IsSearchable lt t lo hi → IsNodeOf t l y r → ∀ {x z}, Mem lt x l → Mem lt z r → lt x z :=
  by
  intro _ _ hs hn x z hm₁ hm₂; cases hn <;> cases hs
  all_goals
    have h₁ := range hs_hs₁ hm₁
    have h₂ := range hs_hs₂ hm₂
    exact trans_of lt h₁.2 h₂.1
#align rbnode.lt_of_mem_left_right Rbnode.lt_of_mem_left_right

end IsSearchableLemmas

inductive IsRedBlack : Rbnode α → Color → Nat → Prop
  | leaf_rb : is_red_black leaf black 0
  |
  red_rb {v l r n} (rb_l : is_red_black l black n) (rb_r : is_red_black r black n) :
    is_red_black (red_node l v r) red n
  |
  black_rb {v l r n c₁ c₂} (rb_l : is_red_black l c₁ n) (rb_r : is_red_black r c₂ n) :
    is_red_black (black_node l v r) black (succ n)
#align rbnode.is_red_black Rbnode.IsRedBlack

open IsRedBlack

theorem depth_min : ∀ {c n} {t : Rbnode α}, IsRedBlack t c n → n ≤ depth min t :=
  by
  intro c n' t h
  induction h
  case leaf_rb => exact le_refl _
  case red_rb =>
    simp [depth]
    have : min (depth min h_l) (depth min h_r) ≥ h_n := by apply le_min <;> assumption
    apply le_succ_of_le
    assumption
  case black_rb =>
    simp [depth]
    apply succ_le_succ
    apply le_min <;> assumption
#align rbnode.depth_min Rbnode.depth_min

private def upper : Color → Nat → Nat
  | red, n => 2 * n + 1
  | black, n => 2 * n
#align rbnode.upper rbnode.upper

private theorem upper_le : ∀ c n, upper c n ≤ 2 * n + 1
  | red, n => le_refl _
  | black, n => by apply le_succ
#align rbnode.upper_le rbnode.upper_le

theorem depth_max' : ∀ {c n} {t : Rbnode α}, IsRedBlack t c n → depth max t ≤ upper c n :=
  by
  intro c n' t h
  induction h
  case leaf_rb => simp [max, depth, upper, Nat.mul_zero]
  case
    red_rb =>
    suffices succ (max (depth max h_l) (depth max h_r)) ≤ 2 * h_n + 1 by simp_all [depth, upper]
    apply succ_le_succ
    apply max_le <;> assumption
  case
    black_rb =>
    have : depth max h_l ≤ 2 * h_n + 1 := le_trans h_ih_rb_l (upper_le _ _)
    have : depth max h_r ≤ 2 * h_n + 1 := le_trans h_ih_rb_r (upper_le _ _)
    suffices new : max (depth max h_l) (depth max h_r) + 1 ≤ 2 * h_n + 2 * 1
    · simp_all [depth, upper, succ_eq_add_one, Nat.left_distrib]
    apply succ_le_succ
    apply max_le <;> assumption
#align rbnode.depth_max' Rbnode.depth_max'

theorem depth_max {c n} {t : Rbnode α} (h : IsRedBlack t c n) : depth max t ≤ 2 * n + 1 :=
  le_trans (depth_max' h) (upper_le _ _)
#align rbnode.depth_max Rbnode.depth_max

theorem balanced {c n} {t : Rbnode α} (h : IsRedBlack t c n) : depth max t ≤ 2 * depth min t + 1 :=
  by
  have : 2 * depth min t + 1 ≥ 2 * n + 1 :=
    by
    apply succ_le_succ
    apply Nat.mul_le_mul_left
    apply depth_min h
  apply le_trans
  apply depth_max h
  apply this
#align rbnode.balanced Rbnode.balanced

end Rbnode


import Lean.Data.HashMap

inductive NEList (α : Type)
  | uno  : α → NEList α
  | cons : α → NEList α → NEList α

def NEList.contains [BEq α] : NEList α → α → Bool
  | uno  a,    x => a == x
  | cons a as, x => a == x || as.contains x

def NEList.noDup [BEq α] : NEList α → Bool
  | uno  a    => true
  | cons a as => ¬as.contains a && as.noDup

@[specialize]
def NEList.foldl (f : α → β → α) : (init : α) → NEList β → α
  | a, uno  b   => f a b
  | a, cons b l => foldl f (f a b) l

@[specialize]
def NEList.map (f : α → β) : NEList α → NEList β
  | uno  a     => uno  (f a)
  | cons a  as => cons (f a) (map f as)

inductive Literal
  | bool  : Bool   → Literal
  | int   : Int    → Literal
  | float : Float  → Literal
  | str   : String → Literal

inductive BinOp
  | add | mul | eq | ne | lt | le | gt | ge

inductive UnOp
  | not

mutual

  inductive Lambda
    | mk : (l : NEList String) → l.noDup → Program → Lambda

  inductive Expression
    | lit   : Literal → Expression
    | var   : String → Expression
    | lam   : Lambda → Expression
    | list  : List Literal → Expression
    | app   : Expression → NEList Expression → Expression
    | unOp  : UnOp  → Expression → Expression
    | binOp : BinOp → Expression → Expression → Expression

  inductive Program
    | skip  : Program
    | eval  : Expression → Program
    | decl  : String  → Program → Program
    | seq   : Program → Program → Program
    | fork  : Expression → Program → Program → Program
    | loop  : Expression → Program → Program
    | print : Expression → Program
    deriving Inhabited

end

inductive Value
  | nil  : Value
  | lit  : Literal → Value
  | list : List Literal → Value
  | lam  : Lambda → Value
  deriving Inhabited

abbrev Context := Lean.HashMap String Value

inductive ErrorType
  | name | type | runTime

def Literal.typeStr : Literal → String
  | bool  _ => "bool"
  | int   _ => "int"
  | float _ => "float"
  | str   _ => "str"

def removeRightmostZeros (s : String) : String :=
  let rec aux (buff res : List Char) : List Char → List Char
    | []      => res.reverse
    | a :: as =>
      if a != '0'
        then aux [] (a :: (buff ++ res)) as
        else aux (a :: buff) res as
  ⟨aux [] [] s.data⟩

protected def Literal.toString : Literal → String
  | bool  b => toString b
  | int   i => toString i
  | float f => removeRightmostZeros $ toString f
  | str   s => s

def Lambda.typeStr : Lambda → String
  | mk l .. => (l.foldl (init := "") fun acc _ => acc ++ "_ → ") ++ "_"

def Value.typeStr : Value → String
  | nil    => "nil"
  | lit  l => l.typeStr
  | list _ => "list"
  | lam  l => l.typeStr

def Literal.eq : Literal → Literal → Bool
  | bool  bₗ, bool  bᵣ => bₗ == bᵣ
  | int   iₗ, int   iᵣ => iₗ == iᵣ
  | float fₗ, float fᵣ => fₗ == fᵣ
  | int   iₗ, float fᵣ => (.ofInt iₗ) == fᵣ
  | float fₗ, int   iᵣ => fₗ == (.ofInt iᵣ)
  | str   sₗ, str   sᵣ => sₗ == sᵣ
  | _       , _        => false

def listLiteralEq : List Literal → List Literal → Bool
  | [], [] => true
  | a :: a' :: as, b :: b' :: bs =>
    a.eq b && listLiteralEq (a' :: as) (b' :: bs)
  | _, _   => false

def opError (app l r : String) : String :=
  s!"I can't perform a '{app}' operation between '{l}' and '{r}'"

def opError1 (app v : String) : String :=
  s!"I can't perform a '{app}' operation on '{v}'"

def Value.not : Value → Except String Value
  | lit $ .bool b => return lit $ .bool !b
  | v             => throw $ opError1 "!" v.typeStr

def Value.add : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ || bᵣ
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .int  $ iₗ +  iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .float $ fₗ +  fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .float $ (.ofInt iₗ) +  fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .float $ fₗ +  (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .str   $ sₗ ++ sᵣ
  | list         lₗ, list         lᵣ => return list  $ lₗ ++ lᵣ
  | list         l,  lit          r  => return list  $ l.concat r
  | l,               r               => throw $ opError "+" l.typeStr r.typeStr

def Value.mul : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return .lit $ .bool  $ bₗ && bᵣ
  | lit $ .int   iₗ, lit $ .int   iᵣ => return .lit $ .int   $ iₗ *  iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return .lit $ .float $ fₗ *  fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return .lit $ .float $ (.ofInt iₗ) *  fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return .lit $ .float $ fₗ *  (.ofInt iᵣ)
  | l,               r               => throw $ opError "*" l.typeStr r.typeStr

def Bool.toNat : Bool → Nat
  | false => 0
  | true  => 1

def Value.lt : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ.toNat < bᵣ.toNat
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .bool $ iₗ < iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .bool $ fₗ < fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .bool $ (.ofInt iₗ) < fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .bool $ fₗ < (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .bool $ sₗ < sᵣ
  | list lₗ, list lᵣ => return lit $ .bool $ lₗ.length < lᵣ.length
  | l,               r               => throw $ opError "<" l.typeStr r.typeStr

def Value.le : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ.toNat ≤ bᵣ.toNat
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .bool $ iₗ ≤ iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .bool $ fₗ ≤ fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .bool $ (.ofInt iₗ) ≤ fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .bool $ fₗ ≤ (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .bool $ sₗ < sᵣ || sₗ == sᵣ
  | list lₗ, list  lᵣ => return lit $ .bool $ lₗ.length ≤ lᵣ.length
  | l,         r      => throw $ opError "<=" l.typeStr r.typeStr

def Value.gt : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ.toNat > bᵣ.toNat
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .bool $ iₗ > iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .bool $ fₗ > fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .bool $ (.ofInt iₗ) > fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .bool $ fₗ > (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .bool $ sₗ > sᵣ
  | list lₗ, list lᵣ => return lit $ .bool $ lₗ.length > lᵣ.length
  | l,       r       => throw $ opError ">" l.typeStr r.typeStr

def Value.ge : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ.toNat ≥ bᵣ.toNat
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .bool $ iₗ ≥ iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .bool $ fₗ ≥ fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .bool $ (.ofInt iₗ) ≥ fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .bool $ fₗ ≥ (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .bool $ sₗ > sᵣ || sₗ == sᵣ
  | list lₗ, list  lᵣ => return lit $ .bool $ lₗ.length ≥ lᵣ.length
  | l,       r        => throw $ opError ">=" l.typeStr r.typeStr

def Value.eq : Value → Value → Except String Value
  | nil,     nil      => return lit $ .bool true
  | lit  lₗ, lit lᵣ   => return lit $ .bool $ lₗ.eq lᵣ
  | list lₗ, list  lᵣ => return lit $ .bool (listLiteralEq lₗ lᵣ)
  | lam .. , lam ..   => throw "I can't compare functions"
  | _,       _        => return lit $ .bool false

def Value.ne : Value → Value → Except String Value
  | nil,     nil      => return lit $ .bool false
  | lit  lₗ, lit lᵣ   => return lit $ .bool $ !(lₗ.eq lᵣ)
  | list lₗ, list  lᵣ => return lit $ .bool !(listLiteralEq lₗ lᵣ)
  | lam ..,  lam ..   => throw "I can't compare functions"
  | _,       _        => return lit $ .bool true

def Value.unOp : Value → UnOp → Except String Value
  | v, .not => v.not

def Value.binOp : Value → Value → BinOp → Except String Value
  | l, r, .add => l.add r
  | l, r, .mul => l.mul r
  | l, r, .lt  => l.lt r
  | l, r, .le  => l.le r
  | l, r, .gt  => l.gt r
  | l, r, .ge  => l.ge r
  | l, r, .eq  => l.eq r
  | l, r, .ne  => l.ne r

def NEList.unfoldStrings (l : NEList String) : String :=
  l.foldl (init := "") $ fun acc a => acc ++ s!" {a}" |>.trimLeft

mutual

  partial def unfoldExpressions (es : NEList Expression) : String :=
    (es.map exprToString).unfoldStrings

  partial def exprToString : Expression → String
    | .var  n    => n
    | .lit  l    => l.toString
    | .list l    => toString $ l.map Literal.toString
    | .lam  _    => "«function»"
    | .app  e es => s!"({exprToString e} {unfoldExpressions es})"
    | .unOp  .not e   => s!"!{exprToString e}"
    | .binOp .add l r => s!"({exprToString l} + {exprToString r})"
    | .binOp .mul l r => s!"({exprToString l} * {exprToString r})"
    | .binOp .eq  l r => s!"({exprToString l} = {exprToString r})"
    | .binOp .ne  l r => s!"({exprToString l} != {exprToString r})"
    | .binOp .lt  l r => s!"({exprToString l} < {exprToString r})"
    | .binOp .le  l r => s!"({exprToString l} <= {exprToString r})"
    | .binOp .gt  l r => s!"({exprToString l} > {exprToString r})"
    | .binOp .ge  l r => s!"({exprToString l} >= {exprToString r})"

end

instance : ToString Expression := ⟨exprToString⟩

def valToString : Value → String
    | .nil    => "«nil»"
    | .lit  l => l.toString
    | .list l => toString $ l.map Literal.toString
    | .lam  _ => "«function»"

instance : ToString Value := ⟨valToString⟩

def consume (p : Program) :
    NEList String → NEList Expression →
      Option ((Option (NEList String)) × Program)
  | .cons n ns, .cons e es => consume (.seq (.decl n (.eval e)) p) ns es
  | .cons n ns, .uno  e    => some (some ns, .seq (.decl n (.eval e)) p)
  | .uno  n,    .uno  e    => some (none, .seq (.decl n (.eval e)) p)
  | .uno  _,    .cons ..   => none

theorem noDupOfConsumeNoDup
  (h : ns.noDup) (h' : consume p' ns es = some (some l, p)) :
    l.noDup = true := by
  induction ns generalizing p' es with
  | uno  _      => cases es <;> cases h'
  | cons _ _ hi =>
    simp [NEList.noDup] at h
    cases es with
    | uno  _   => simp [consume] at h'; simp only [h.2, ← h'.1]
    | cons _ _ => exact hi h.2 h'

inductive Continuation
  | exit   : Continuation
  | seq    : Program → Continuation → Continuation
  | decl   : String → Continuation → Continuation
  | fork   : Expression → Program → Program → Continuation → Continuation
  | loop   : Expression → Program → Continuation → Continuation
  | unOp   : UnOp → Expression → Continuation → Continuation
  | binOp₁ : BinOp → Expression → Continuation → Continuation
  | binOp₂ : BinOp → Value → Continuation → Continuation
  | app    : Expression → NEList Expression → Continuation → Continuation
  | block  : Context → Continuation → Continuation
  | print  : Continuation → Continuation

inductive State
  | ret   : Value      → Context → Continuation → State
  | prog  : Program    → Context → Continuation → State
  | expr  : Expression → Context → Continuation → State
  | error : ErrorType  → Context → String → State
  | done  : Value      → Context → State

def cantEvalAsBool (e : Expression) (v : Value) : String :=
  s!"I can't evaluate '{e}' as a 'bool' because it reduces to '{v}', of " ++
    s!"type '{v.typeStr}'"

def notFound (n : String) : String :=
  s!"I can't find the definition of '{n}'"

def notAFunction (e : Expression) (v : Value) : String :=
  s!"I can't apply arguments to '{e}' because it evaluates to '{v}', of " ++
    s!"type '{v.typeStr}'"

def wrongNParameters (e : Expression) (allowed provided : Nat) : String :=
  s!"I can't apply {provided} arguments to '{e}' because the maximum " ++
    s!"allowed is {allowed}"

def NEList.length : NEList α → Nat
  | uno  _   => 1
  | cons _ l => 1 + l.length

def State.step : State → State
  | prog .skip c k => ret .nil c k
  | prog (.eval e) c k => expr e c k
  | prog (.seq p₁ p₂) c k => prog p₁ c (.seq p₂ k)
  | prog (.decl n p) c k => prog p c $ .block c (.decl n k)
  | prog (.fork e pT pF) c k => expr e c (.fork e pT pF k)
  | prog (.loop e p) c k => expr e c (.loop e p k)
  | prog (.print e) c k => expr e c (.print k)

  | expr (.lit l) c k => ret (.lit l) c k
  | expr (.list l) c k => ret (.list l) c k
  | expr (.var n) c k => match c[n] with
    | none   => error .name c $ notFound n
    | some v => ret v c k
  | expr (.lam l) c k => ret (.lam l) c k
  | expr (.app e es) c k => expr e c (.app e es k)
  | expr (.unOp o e) c k => expr e c (.unOp o e k)
  | expr (.binOp o e₁ e₂) c k => expr e₁ c (.binOp₁ o e₂ k)

  | ret v c .exit => done v c
  | ret v c (.print k) => dbg_trace v; ret .nil c k
  | ret _ c (.seq p k) => prog p c k

  | ret v _ (.block c k) => ret v c k

  | ret v c (.app e es k) => match v with
    | .lam $ .mk ns h p => match h' : consume p ns es with
      | some (some l, p) =>
        ret (.lam $ .mk l (noDupOfConsumeNoDup h h') p) c k
      | some (none, p) => prog p c (.block c k)
      | none => error .runTime c $ wrongNParameters e ns.length es.length
    | v                 => error .type c $ notAFunction e v

  | ret (.lit $ .bool true)  c (.fork _ pT _ k) => prog pT c k
  | ret (.lit $ .bool false) c (.fork _ _ pF k) => prog pF c k
  | ret v c (.fork e ..) => error .type c $ cantEvalAsBool e v

  | ret (.lit $ .bool true) c (.loop e p k) => prog (.seq p (.loop e p)) c k
  | ret (.lit $ .bool false) c (.loop _ _ k) => ret .nil c k
  | ret v c (.loop e ..) => error .type c $ cantEvalAsBool e v

  | ret v c (.decl n k) => ret .nil (c.insert n v) k

  | ret v c (.unOp o e k) => match v.unOp o with
    | .error m => error .type c m
    | .ok    v => ret v c k
  | ret v₁ c (.binOp₁ o e₂ k) => expr e₂ c (.binOp₂ o v₁ k)
  | ret v₂ c (.binOp₂ o v₁ k) => match v₁.binOp v₂ o with
    | .error m => error .type c m
    | .ok    v => ret v c k

  | s@(error ..) => s
  | s@(done ..)  => s

def State.isProg : State → Bool
  | prog .. => true
  | _       => false

def State.isEnd : State → Bool
  | done  .. => true
  | error .. => true
  | _        => false

def State.stepN : State → Nat → State
  | s, 0     => s
  | s, n + 1 => s.step.stepN n

notation s "^" "[" n "]" => State.stepN s n

theorem State.retProgression :
    ∃ n, (ret v c k^[n]).isEnd ∨ (ret v c k^[n]).isProg := by
  induction k generalizing v c with
  | app e es k hi =>
    cases v with
    | lam lm =>
      cases lm with
      | mk ns h p =>
        exists 1
        simp [stepN, step] -- doesn't seem to use `
        split
        next l p' h' => simp!; sorry
        next => simp!
        next => simp!
    | _ => exact ⟨1, by simp [stepN, step, isEnd]⟩
  | _ => sorry

#check @State.step.match_2.eq_1
#check @State.step.match_2.eq_2
#check @State.step.match_2.eq_3
#check @State.step.match_2.splitter


#exit

import Structure.Generic.Axioms

open GeneralizedRelation

set_option autoBoundImplicitLocal false

universes u v w

@[reducible] def mapOperation {α : Sort u} {β : Sort v} (op : α → α → β) {ω : Sort w} (m : ω → α) :
  ω → ω → β :=
λ a b => op (m a) (m b)

namespace GeneralizedProperty

  variable {α : Sort u} {V : Universe} (P : GeneralizedProperty α V)
           {ω : Sort w} (m : ω → α)

  instance mapInst [h : HasInst P] : HasInst (P ∘ m) := ⟨λ a => h.inst (m a)⟩

end GeneralizedProperty

namespace GeneralizedRelation

  variable {α : Sort u} {V : Universe} (R : GeneralizedRelation α V)

  section Mapping

    variable {ω : Sort w} (m : ω → α)

    instance mapRefl  [h : HasRefl  R] : HasRefl  (mapOperation R m) := ⟨λ a => h.refl (m a)⟩

    variable [HasInternalFunctors V]

    instance mapSymm  [h : HasSymm  R] : HasSymm  (mapOperation R m) := ⟨h.symm⟩
    instance mapTrans [h : HasTrans R] : HasTrans (mapOperation R m) := ⟨h.trans⟩

    instance mapPreorder    [IsPreorder    R] : IsPreorder    (mapOperation R m) := ⟨⟩
    instance mapEquivalence [IsEquivalence R] : IsEquivalence (mapOperation R m) := ⟨⟩

  end Mapping

  section Identity

    @[simp] theorem mapRefl.id  [h : HasRefl  R] : mapRefl  R id = h := match h with | ⟨_⟩ => rfl

    variable [HasInternalFunctors V]

    @[simp] theorem mapSymm.id  [h : HasSymm  R] : mapSymm  R id = h := match h with | ⟨_⟩ => rfl
    @[simp] theorem mapTrans.id [h : HasTrans R] : mapTrans R id = h := match h with | ⟨_⟩ => rfl

    @[simp] theorem mapPreorder.id    [h : IsPreorder    R] : mapPreorder    R id = h := match h with | { refl := _, trans := _ } => rfl
    @[simp] theorem mapEquivalence.id [h : IsEquivalence R] : mapEquivalence R id = h := match h with | { refl := _, symm := _, trans := _ } => rfl

  end Identity

end GeneralizedRelation

section Morphisms

  variable {α : Sort u} {V : Universe} [HasInternalFunctors V] [HasInstanceArrows V]
           (R : GeneralizedRelation α V)
           {ω : Sort w} (m : ω → α)

  instance mapComposition  [HasTrans      R] [h : IsCompositionRelation R] :
    IsCompositionRelation (mapOperation R m) :=
  { assocLR  := h.assocLR,
    assocRL  := h.assocRL }

  instance mapMorphisms    [IsPreorder    R] [h : IsMorphismRelation    R] :
    IsMorphismRelation    (mapOperation R m) :=
  { leftId   := h.leftId,
    rightId  := h.rightId }

  instance mapIsomorphisms [IsEquivalence R] [h : IsIsomorphismRelation R] :
    IsIsomorphismRelation (mapOperation R m) :=
  { leftInv  := h.leftInv,
    rightInv := h.rightInv,
    invInv   := h.invInv,
    compInv  := h.compInv,
    idInv    := λ a => h.idInv (m a) }

end Morphisms

section Functors

  variable {α : Sort u} {V W : Universe} [HasInstanceArrows W] [HasExternalFunctors V W]
           (R : GeneralizedRelation α V) (S : GeneralizedRelation α W)
           (F : BaseFunctor R S)
           {ω : Sort w} (m : ω → α)

  instance mapReflFunctor  [HasRefl  R] [HasRefl  S] [h : IsReflFunctor  R S F] :
    IsReflFunctor  (mapOperation R m) (mapOperation S m) F :=
  ⟨λ a => h.respectsRefl (m a)⟩

  variable [HasInternalFunctors V] [HasInternalFunctors W]

  instance mapSymmFunctor  [HasSymm  R] [HasSymm  S] [h : IsSymmFunctor  R S F] :
    IsSymmFunctor  (mapOperation R m) (mapOperation S m) F :=
  ⟨h.respectsSymm⟩

  instance mapTransFunctor [HasTrans R] [HasTrans S] [h : IsTransFunctor R S F] :
    IsTransFunctor (mapOperation R m) (mapOperation S m) F :=
  ⟨h.respectsTrans⟩

  instance mapPreorderFunctor    [IsPreorder    R] [IsPreorder    S] [IsPreorderFunctor    R S F] :
    IsPreorderFunctor    (mapOperation R m) (mapOperation S m) F := ⟨⟩
  instance mapEquivalenceFunctor [IsEquivalence R] [IsEquivalence S] [IsEquivalenceFunctor R S F] :
    IsEquivalenceFunctor (mapOperation R m) (mapOperation S m) F := ⟨⟩

end Functors

section NaturalTransformations

  variable {α : Sort u} {β : Sort v} {V W : Universe} [HasInternalFunctors W] [HasInstanceEquivalences W] [HasExternalFunctors V W]
           (R : GeneralizedRelation α V) (S : GeneralizedRelation β W) [h : HasTrans S]
           {mF mG : α → β} (F : ∀ {a b}, R a b ⟶' S (mF a) (mF b)) (G : ∀ {a b}, R a b ⟶' S (mG a) (mG b))
           (n : ∀ a, S (mF a) (mG a))
           {ω : Sort w} (m : ω → α)

  instance mapNaturality [h : IsNatural R S F G n] :
    IsNatural (mapOperation R m) S F G (λ a => n (m a)) :=
  ⟨h.nat⟩

end NaturalTransformations


import morphisms.isomorphism
import algebraic_geometry.pullback_carrier

open opposite category_theory category_theory.limits topological_space

noncomputable theory

namespace algebraic_geometry

lemma injective_of_surjective_diagonal {X Y : Scheme} (f : X ⟶ Y)
  (h : function.surjective (pullback.diagonal f).1.base) : function.injective f.1.base :=
begin
  intros x y e,
  let T : pullback.triplet f f := ⟨x, y, _, e, rfl⟩,
  obtain ⟨z, hz, hz'⟩ := T.exists_preimage,
  obtain ⟨z', rfl⟩ := h z,
  simp only [← Scheme.comp_val_base_apply, pullback.diagonal_fst, pullback.diagonal_snd] at hz hz',
  exact hz.symm.trans hz'
end

lemma surjective_diagonal_of_universally_injective {X Y : Scheme} (f : X ⟶ Y)
  (h : function.surjective (pullback.diagonal f).1.base) : function.injective f.1.base :=
begin
  intros x y e,
  let T : pullback.triplet f f := ⟨x, y, _, e, rfl⟩,
  obtain ⟨z, hz, hz'⟩ := T.exists_preimage,
  obtain ⟨z', rfl⟩ := h z,
  simp only [← Scheme.comp_val_base_apply, pullback.diagonal_fst, pullback.diagonal_snd] at hz hz',
  exact hz.symm.trans hz'
end

lemma injective_of_mono {X Y : Scheme} (f : X ⟶ Y) [mono f] :
  function.injective f.1.base :=
begin
  apply injective_of_surjective_diagonal,
  exact (as_iso $ (Scheme.forget_to_Top ⋙ forget Top).map
    (pullback.diagonal f)).to_equiv.surjective,
end

-- move me
lemma mono_eq_diagonal :
  @mono Scheme _ = morphism_property.diagonal (@is_iso Scheme _) :=
begin
  ext X Y f,
  split,
  { introI _, show is_iso _, apply_instance },
  { rintro (H : is_iso _),
    resetI,
  haveI : is_iso (pullback.fst : pullback f f ⟶ X),
  { rw (is_iso.inv_eq_of_hom_inv_id (pullback.diagonal_fst f)).symm, apply_instance },
  exact is_kernel_pair.mono_of_is_iso_fst (is_pullback.of_has_pullback f f) }
end

lemma mono_is_local_at_target :
  property_is_local_at_target (@mono _ _) :=
begin
  rw mono_eq_diagonal,
  exact is_iso_is_local_at_target.diagonal
end

end algebraic_geometry


macro "foo!" x:term:max : term => `($x - 1)

theorem ex1 : foo! 10 = 9 := rfl

macro (priority := high) "foo! " x:term:max : term => `($x + 1)

theorem ex2 : foo! 10 = 11 := rfl

macro (priority := low) "foo! " x:term:max : term => `($x * 2)

theorem ex3 : foo! 10 = 11 := rfl

macro (priority := high+1) "foo! " x:term:max : term => `($x * 2)

theorem ex4 : foo! 10 = 20 := rfl

macro (priority := high+4-2) "foo! " x:term:max : term => `($x * 3)

theorem ex5 : foo! 10 = 30 := rfl


example : n.succ = 1 → n = 0 := by
  intros h; injection h

example (h : n.succ = 1) : n = 0 := by
  injection h

opaque T : Type
opaque T.Pred : T → T → Prop

example {ρ} (hρ : ρ.Pred σ) : T.Pred ρ ρ := sorry


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

import category_theory.category
import pseudoelements
import tactic.combinators
import tactic.chase_tactic

open category_theory
open category_theory.abelian
open category_theory.abelian.pseudoelements
open tactic

namespace tactic.chase

section lemmas
universes v u
variables {C : Type u} [𝒞 : category.{v} C] [abelian.{v} C]
include 𝒞

local attribute [instance] object_to_sort
local attribute [instance] hom_to_fun

lemma pseudo_congr {X Y : C} {f g : X ⟶ Y} (h : f = g) (x : X) : f x = g x :=
by rw h

end lemmas

meta def try_apply_comm_lemma_at_aux (l : commutativity_lemma) :
  ℕ → diagram_term → option (diagram_term)
| 0 ⟨ms, elem⟩ :=
  match list.is_prefix_of l.lhs ms with
  | ff := none
  | tt := some ⟨list.append l.rhs (list.drop l.lhs.length ms), elem⟩
  end
| (n + 1) ⟨[], e⟩ := none
| (n + 1) ⟨t::ts, e⟩ :=
  match try_apply_comm_lemma_at_aux n ⟨ts, e⟩ with
  | none := none
  | some ⟨nt, ne⟩ := some ⟨t::nt, ne⟩
  end

meta def try_apply_element_lemma_at_aux (l : element_lemma) :
  ℕ → diagram_term → option (diagram_term)
| 0 ⟨ms, elem⟩ := if l.lhs = ⟨ms, elem⟩ then some l.rhs else none
| (n + 1) ⟨[], e⟩ := none
| (n + 1) ⟨t :: ts, e⟩ :=
  match try_apply_element_lemma_at_aux n ⟨ts, e⟩ with
  | none := none
  | some ⟨nt, ne⟩ := some ⟨t::nt, ne⟩
  end

meta inductive lemma_app
| comm : commutativity_lemma → ℕ → diagram_term → lemma_app
| elem : element_lemma → ℕ → diagram_term → lemma_app

meta instance format_lemma_app : has_to_format lemma_app :=
{ to_format := λ a,
  match a with
  | lemma_app.comm a b c := format!"comm: lemma ({a}) at {b} gives {c}"
  | lemma_app.elem a b c := format!"elem: lemma ({a}) at {b} gives {c}"
  end }

meta def next_term : lemma_app → diagram_term
| (lemma_app.comm _ _ t) := t
| (lemma_app.elem _ _ t) := t

meta def apply_comm_lemma_at_aux : ℕ → diagram_term → tactic (option expr)
| 0 t := some <$> (mk_eq_refl $ as_expr t)
| 1 ⟨t::[], e⟩ := some <$> (mk_eq_refl $ as_expr ⟨[t], e⟩)
| (n + 1) ⟨[], _⟩ := return none
| (n + 1) ⟨t::[], e⟩ := return none
| (n + 1) ⟨t::(u::ts), e⟩ :=
do
  some x ← i_to_expr ``(%%(u.ex) ≫ %%(t.ex)) >>= as_morphism,
  lhs ← mk_app `category_theory.abelian.pseudoelements.comp_apply [u.ex, t.ex, as_expr ⟨ts, e⟩] >>= mk_eq_symm,
  some rhs ← apply_comm_lemma_at_aux n ⟨x::ts, e⟩,
  some <$> mk_eq_trans lhs rhs

meta def apply_comm_lemma_at (l : commutativity_lemma) :
  ℕ → diagram_term → diagram_term → tactic (option expr)
| 0 ⟨ms, elem⟩ goal :=
do
  some one ← apply_comm_lemma_at_aux (l.lhs.length - 1) ⟨ms, elem⟩,
  let inner := as_expr ⟨list.drop (l.lhs.length) ms, elem⟩,
  two ← mk_app `tactic.chase.pseudo_congr [l.ex, inner],
  some three ← apply_comm_lemma_at_aux (l.rhs.length - 1) goal,
  three' ← mk_eq_symm three,
  onetwo ← mk_eq_trans one two,
  some <$> mk_eq_trans onetwo three'
| (n + 1) ⟨[], e⟩ goal := none
| (n + 1) fr ⟨[], e⟩ := none
| (n + 1) ⟨t::ts, e⟩ ⟨u::us, f⟩ :=
do
  some inner ← apply_comm_lemma_at n ⟨ts, e⟩ ⟨us, f⟩,
  some <$> mk_app `congr_arg [t.app, inner]

meta def apply_elem_lemma_at (l : element_lemma) :
  ℕ → diagram_term → tactic (option expr)
| 0 ⟨ms, elem⟩ := return $ some l.ex
| (n + 1) ⟨[], _⟩ := none
| (n + 1) ⟨t::ts, e⟩ :=
do
  some inner ← apply_elem_lemma_at n ⟨ts, e⟩,
  some <$> mk_app `congr_arg [t.app, inner]

meta def build_proof (t : diagram_term) : lemma_app → tactic expr
| (lemma_app.comm x y z) :=
do
  some u ← apply_comm_lemma_at x y t z,
  return u
| (lemma_app.elem x y z) :=
do
  some u ← apply_elem_lemma_at x y t,
  return u

meta def try_apply_comm_lemma_at (l : commutativity_lemma) (n : ℕ) (t : diagram_term) :
  option (lemma_app) :=
match try_apply_comm_lemma_at_aux l n t with
| none := none
| some t := lemma_app.comm l n t
end

meta def try_apply_elem_lemma_at (l : element_lemma) (n : ℕ) (t : diagram_term) :
  option lemma_app :=
match try_apply_element_lemma_at_aux l n t with
| none := none
| some t := lemma_app.elem l n t
end

meta def iota : ℕ → list ℕ
| 0 := [0]
| (n + 1) := (n + 1) :: iota n

meta def try_apply_comm_lemma (l : commutativity_lemma) (t : diagram_term) : list lemma_app :=
list.filter_map (λ n, try_apply_comm_lemma_at l n t) $ iota t.ms.length

meta def try_apply_elem_lemma (l : element_lemma) (t : diagram_term) : list lemma_app :=
list.filter_map (λ n, try_apply_elem_lemma_at l n t) $ iota t.ms.length

meta def try_all_comm (t : diagram_term) : chase_tactic (list lemma_app) :=
do
  l ← get,
  return $ list.join $ list.map (λ l, try_apply_comm_lemma l t) l.comm_lemmas

meta def try_all_elem (t : diagram_term) : chase_tactic (list lemma_app) :=
do
  l ← get,
  return $ list.join $ list.map (λ l, try_apply_elem_lemma l t) l.elem_lemmas

meta mutual def show_via_zero, find_proof_dfs
with show_via_zero : diagram_term → diagram_term → chase_tactic (option expr)
| cur goal := do
  l ← diagram_term.to_zero cur,
  match l with
  | none := return none
  | some e := do
    zer ← goal.zero,
    r ← find_proof_dfs goal zer [],
    match r with
    | none := return none
    | some f := (mk_eq_symm f) >>= (λ g, some <$> mk_eq_trans e g)
    end
  end
with find_proof_dfs :
diagram_term → diagram_term → list diagram_term → chase_tactic (option expr)
| cur goal seen := if cur = goal then some <$> mk_eq_refl (as_expr cur) else
do
  via_zero ← show_via_zero cur goal,
  match via_zero with
  | some e := return $ some e
  | none := do
    cands_comm ← try_all_comm cur,
    cands_elem ← try_all_elem cur,
    let cands := list.append cands_comm cands_elem,

    list.mfoldl (λ r s,
      match r with
      | some q := return $ some q
      | none :=
        ite (list.any seen (λ e, to_bool $ e = (next_term s))) (return none) $
        do
          --trace format!"trying {s}...",
          l ← find_proof_dfs (next_term s) goal (cur::seen),
          match l with
          | none := none
          | some q := do
            f ← build_proof cur s,
            t ← mk_eq_trans f q,
            return $ some t
          end
      end) none cands
    end

meta def find_direct_proof (cur goal : diagram_term) : chase_tactic (option expr) :=
find_proof_dfs cur goal []

meta def find_proof : diagram_term → diagram_term → chase_tactic (option expr)
| ⟨t, e⟩ ⟨t', e'⟩ := do
  mm ← diagram_term.type ⟨t, e⟩ >>= mono_with_domain,
  match mm with
  | none := find_direct_proof ⟨t, e⟩ ⟨t', e'⟩
  | some m := do
    ii ← find_proof ⟨m::t, e⟩ ⟨m::t', e'⟩,
    match ii with
    | none := none
    | some i := some <$> mk_app `category_theory.abelian.pseudoelements.pseudo_injective_of_mono [i]
    end
  end

meta def commutativity : chase_tactic unit :=
do
  (_, l, r) ← target_lhs_rhs,
  some lhs ← as_diagram_term l,
  some rhs ← as_diagram_term r,
  some p ← find_proof lhs rhs,
  tactic.exact p

end tactic.chase

namespace tactic.interactive
open interactive (parse)
open lean.parser (tk pexpr)

meta def commutativity (loc : parse ((tk "at" *> some <$> pexpr) <|> return none)) : tactic unit :=
do
  l ← match loc with
      | none := return none
      | some m := some <$> to_expr m
      end,
  chase.run_chase_tactic l tactic.chase.commutativity

end tactic.interactive