import tactic
import tactic.monotonicity
import tactic.norm_num
import category.basic
import category.nursery
import data.equiv.nursery
import data.serial.medium

universes u v w

abbreviation put_m' := medium.put_m'.{u} unsigned
abbreviation put_m  := medium.put_m'.{u} unsigned punit
abbreviation get_m  := medium.get_m.{u} unsigned

def serial_inverse {α : Type u} (encode : α → put_m) (decode : get_m α) : Prop :=
∀ w, decode -<< encode w = pure w

class serial (α : Type u) :=
  (encode : α → put_m)
  (decode : get_m α)
  (correctness : ∀ w, decode -<< encode w = pure w)

class serial1 (f : Type u → Type v) :=
  (encode : Π {α}, (α → put_m) → f α → put_m)
  (decode : Π {α}, get_m α → get_m (f α))
  (correctness : ∀ {α} put get, serial_inverse.{u} put get →
                 ∀ (w : f α), decode get -<< encode put w = pure w)

instance serial.serial1 {f α} [serial1 f] [serial α] : serial (f α) :=
{ encode := λ x, serial1.encode serial.encode x,
  decode := serial1.decode f (serial.decode α),
  correctness := serial1.correctness _ _ serial.correctness }

class serial2 (f : Type u → Type v → Type w) :=
  (encode : Π {α β}, (α → put_m.{u}) → (β → put_m.{v}) → f α β → put_m.{w})
  (decode : Π {α β}, get_m α → get_m β → get_m (f α β))
  (correctness : ∀ {α β} putα getα putβ getβ,
                   serial_inverse putα getα →
                   serial_inverse putβ getβ →
                 ∀ (w : f α β), decode getα getβ -<< encode putα putβ w = pure w)

instance serial.serial2 {f α β} [serial2 f] [serial α] [serial β] : serial (f α β) :=
{ encode := λ x, serial2.encode serial.encode serial.encode x,
  decode := serial2.decode f (serial.decode _) (serial.decode _),
  correctness := serial2.correctness _ _ _ _ serial.correctness serial.correctness }

instance serial1.serial2 {f α} [serial2 f] [serial α] : serial1 (f α) :=
{ encode := λ β put x, serial2.encode serial.encode put x,
  decode := λ β get, serial2.decode f (serial.decode _) get,
  correctness := λ β get put, serial2.correctness _ _ _ _ serial.correctness  }

export serial (encode decode)

namespace serial

open function
export medium (hiding put_m get_m put_m')

variables {α β σ γ : Type u} {ω : Type}

def serialize [serial α] (x : α) : list unsigned := (encode x).eval
def deserialize (α : Type u) [serial α] (bytes : list unsigned) : option α := (decode α).eval bytes

lemma deserialize_serialize  [serial α] (x : α) :
  deserialize _ (serialize x) = some x :=
by simp [deserialize,serialize,eval_eval,serial.correctness]; refl

lemma encode_decode_bind [serial α]
  (f : α → get_m β) (f' : punit → put_m) (w : α) :
  (decode α >>= f) -<< (encode w >>= f') = f w -<< f' punit.star :=
by { rw [read_write_mono]; rw serial.correctness; refl }

lemma encode_decode_bind' [serial α]
  (f : α → get_m β) (w : α) :
  (decode α >>= f) -<< (encode w) = f w -<< pure punit.star :=
by { rw [read_write_mono_left]; rw serial.correctness; refl }

lemma encode_decode_pure
  (w w' : α) (u : punit) :
  (pure w : get_m α) -<< (pure u) = pure w' ↔ w = w' :=
by split; intro h; cases h; refl

open ulift

protected def ulift.encode [serial α] (w : ulift.{v} α) : put_m :=
(liftable1.up _ equiv.punit_equiv_punit (encode (down w) : medium.put_m' unsigned _) : medium.put_m' unsigned _)

protected def ulift.decode [serial α] : get_m (ulift α) :=
get_m.up ulift.up (decode α)

instance [serial α] : serial (ulift.{v u} α) :=
{ encode := ulift.encode
, decode := ulift.decode
, correctness :=
  by { introv, simp [ulift.encode,ulift.decode],
       rw up_read_write' _ equiv.ulift.symm,
       rw [serial.correctness], cases w, refl,
       intro, refl } }

instance unsigned.serial : serial unsigned :=
{ encode := λ w, put_m'.write w put_m'.pure
, decode := get_m.read get_m.pure
, correctness := by introv; refl }

-- protected def write_word (w : unsigned) : put_m :=
-- encode (up.{u} w)

@[simp] lemma loop_read_write_word {α β γ : Type u}
  (w : unsigned) (x : α) (f : α → unsigned → get_m (β ⊕ α)) (g : β → get_m γ)
  (rest : punit → put_m) :
  get_m.loop f g x -<< (write_word w >>= rest) =
  (f x w >>= get_m.loop.rest f g) -<< rest punit.star := rfl

@[simp] lemma loop_read_write_word' {α β γ : Type u}
  (w : unsigned) (x : α) (f : α → unsigned → get_m (β ⊕ α)) (g : β → get_m γ)  :
  get_m.loop f g x -<< (write_word w) =
  (f x w >>= get_m.loop.rest f g) -<< pure punit.star := rfl

-- protected def read_word : get_m.{u} (ulift unsigned) :=
-- decode _

def select_tag' (tag : unsigned) : list (unsigned × get_m α) → get_m α
| [] := get_m.fail
| ((w,x) :: xs) := if w = tag then x else select_tag' xs

def select_tag (xs : list (unsigned × get_m α)) : get_m α :=
do w ← read_word,
   select_tag' (down w) xs

@[simp]
lemma read_write_tag_hit {w w' : unsigned} {x : get_m α}
  {xs : list (unsigned × get_m α)} {y : put_m}
  (h : w = w') :
  select_tag ( (w,x) :: xs ) -<< (write_word w' >> y) = x -<< y :=
by subst w'; simp [select_tag,(>>),encode_decode_bind,select_tag']

lemma read_write_tag_hit' {w w' : unsigned} {x : get_m α}
  {xs : list (unsigned × get_m α)}
  (h : w = w') :
  select_tag ( (w,x) :: xs ) -<< (write_word w') = x -<< pure punit.star :=
by subst w'; simp [select_tag,(>>),encode_decode_bind',select_tag']

@[simp]
lemma read_write_tag_miss {w w' : unsigned} {x : get_m α}
  {xs : list (unsigned × get_m α)} {y : put_m}
  (h : w ≠ w') :
  select_tag ( (w,x) :: xs ) -<< (write_word w' >> y) = select_tag xs -<< (write_word w' >> y) :=
by simp [select_tag,(>>),encode_decode_bind,select_tag',*]

def recursive_parser {α} : ℕ → (get_m α → get_m α) → get_m α
| 0 _ := get_m.fail
| (nat.succ n) rec_fn := rec_fn $ recursive_parser n rec_fn

lemma recursive_parser_unfold {α} (n : ℕ) (f : get_m α → get_m α) (h : 1 ≤ n) :
  recursive_parser n f = f (recursive_parser (n-1) f) :=
by cases n; [ cases h, refl ]

attribute [simp] serial.correctness

end serial

structure serializer (α : Type u) (β : Type u) :=
(encoder : α → put_m.{u})
(decoder : get_m β)

def serial.mk_serializer' (α) [serial α] : serializer α α :=
{ encoder := encode,
  decoder := decode α }

namespace serializer

def valid_serializer {α} (x : serializer α α) :=
serial_inverse
      (serializer.encoder x)
      (serializer.decoder x)

lemma serializer.eq {α β} (x y : serializer α β)
  (h : x.encoder = y.encoder)
  (h' : x.decoder = y.decoder) :
  x = y :=
by cases x; cases y; congr; assumption

namespace serializer.seq

variables {α : Type u} {i j : Type u}
variables (x : serializer α (i → j))
variables (y : serializer α i)

def encoder := λ (k : α), (x.encoder k >> y.encoder k : put_m' _)
def decoder := x.decoder <*> y.decoder

end serializer.seq

instance {α : Type u} : applicative (serializer.{u} α) :=
{ pure := λ i x, { encoder := λ _, (return punit.star : put_m' _), decoder := pure x }
, seq := λ i j x y,
  { encoder := serializer.seq.encoder x y
  , decoder := serializer.seq.decoder x y } }

section lawful_applicative

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

@[simp]
lemma decoder_pure (x : β) :
  (pure x : serializer σ β).decoder = pure x := rfl

@[simp]
lemma decoder_map (f : α → β) (x : serializer σ α) :
  (f <$> x).decoder = f <$> x.decoder := rfl

@[simp]
lemma decoder_seq (f : serializer σ (α → β)) (x : serializer σ α) :
  (f <*> x).decoder = f.decoder <*> x.decoder := rfl

@[simp]
lemma encoder_pure (x : β) (w : σ) :
  (pure x : serializer σ β).encoder w = (pure punit.star : put_m' _) := rfl

@[simp]
lemma encoder_map (f : α → β) (w : σ) (x : serializer σ α) :
  (f <$> x : serializer σ β).encoder w = x.encoder w := rfl

@[simp]
lemma encoder_seq (f : serializer σ (α → β)) (x : serializer σ α) (w : σ) :
  (f <*> x : serializer σ β).encoder w = (f.encoder w >> x.encoder w : put_m' _) := rfl

end lawful_applicative

instance {α} : is_lawful_functor (serializer.{u} α) :=
by refine { .. }; intros; apply serializer.eq; try { ext }; simp [map_map]

instance {α} : is_lawful_applicative (serializer.{u} α) :=
by{  constructor; intros; apply serializer.eq; try { ext };
     simp [(>>),pure_seq_eq_map,seq_assoc,bind_assoc],  }

protected def up {β} (ser : serializer β β) : serializer (ulift.{u v} β) (ulift.{u v} β) :=
{ encoder := pliftable.up' _ ∘ ser.encoder ∘ ulift.down,
  decoder := medium.get_m.up ulift.up ser.decoder }

def ser_field_with {α β} (ser : serializer β β) (f : α → β) : serializer α β :=
{ encoder := ser.encoder ∘ f,
  decoder := ser.decoder }

@[simp]
def ser_field_with' {α β} (ser : serializer β β) (f : α → β) : serializer.{max u v} α (ulift.{v} β) :=
ser_field_with ser.up (ulift.up ∘ f)

@[simp]
def ser_field {α β} [serial β] (f : α → β) : serializer α β :=
ser_field_with (serial.mk_serializer' β) f

@[simp]
lemma valid_mk_serializer (α) [serial α] :
  valid_serializer (serial.mk_serializer' α) :=
serial.correctness

variables {α β σ γ : Type u} {ω : Type}

def there_and_back_again
  (y : serializer γ α) (w : γ) : option α :=
y.decoder -<< y.encoder w

open medium (hiding put_m put_m' get_m)

lemma there_and_back_again_seq {ser : serializer α α}
  {x : serializer γ (α → β)} {f : α → β} {y : γ → α} {w : γ} {w' : β}
  (h' : there_and_back_again x w = pure f)
  (h : w' = f (y w))
  (h₀ : valid_serializer ser) :
  there_and_back_again (x <*> ser_field_with ser y) w = pure w' :=
by { simp [there_and_back_again,(>>),seq_eq_bind_map] at *,
     rw [read_write_mono h',map_read_write],
     rw [ser_field_with,h₀], subst w', refl }

lemma there_and_back_again_map {ser : serializer α α}
  {f : α → β} {y : γ → α} {w : γ}
  (h₀ : valid_serializer ser) :
  there_and_back_again (f <$> ser_field_with ser y) w = pure (f $ y w) :=
by rw [← pure_seq_eq_map,there_and_back_again_seq]; refl <|> assumption

lemma there_and_back_again_pure (x : β) (w : γ) :
  there_and_back_again (pure x) w =
  pure x := rfl

lemma valid_serializer_of_there_and_back_again
      {α : Type*} (y : serializer α α) :
  valid_serializer y ↔
  ∀ (w : α), there_and_back_again y w = pure w :=
by { simp [valid_serializer,serial_inverse],
     repeat { rw forall_congr, intro }, refl }

@[simp]
lemma valid_serializer_up (x: serializer α α) :
  valid_serializer (serializer.up.{v} x) ↔ valid_serializer x :=
by { cases x, simp [valid_serializer,serializer.up,serial_inverse,equiv.forall_iff_forall equiv.ulift],
     apply forall_congr, intro, dsimp [equiv.ulift,pliftable.up'],
     rw up_read_write' _ equiv.ulift.symm, split; intro h,
     { replace h := congr_arg (liftable1.down.{u} option (equiv.symm equiv.ulift)) h,
       simp [liftable1.down_up] at h, simp [h], refl },
     { simp [h], refl },
     { intro, refl, } }

open ulift

def ser_field' {α β} [serial β] (f : α → β) : serializer.{max u v} α (ulift.{v} β) :=
ser_field (up ∘ f)

def put₀ {α} (x : α) : put_m.{u} := (pure punit.star : put_m' _)
def get₀ {α} : get_m α := get_m.fail

def of_encoder {α} (x : α → put_m) : serializer α α :=
⟨ x, get₀ ⟩

def of_decoder {α} (x : get_m α) : serializer α α :=
⟨ put₀, x ⟩

section applicative

@[simp]
lemma encoder_ser_field (f : β → α) (x : serializer α α) (w : β) :
  (ser_field_with x f).encoder w = x.encoder (f w) := rfl

@[simp]
lemma encoder_up (x : serializer α α) (w : ulift α) :
  (serializer.up x).encoder w = pliftable.up' _ (x.encoder $ w.down) := rfl

@[simp]
lemma encoder_of_encoder (x : α → put_m) (w : α) :
  (of_encoder x).encoder w = x w := rfl

@[simp]
lemma decoder_ser_field (f : β → α) (x : serializer α α) :
  (ser_field_with x f).decoder = x.decoder := rfl

@[simp]
lemma decoder_up (x : serializer α α) :
  (serializer.up x).decoder = (x.decoder).up ulift.up := rfl

@[simp]
lemma decoder_of_decoder (x : get_m α) :
  (of_decoder x).decoder = x := rfl

end applicative
end serializer

namespace serial

open serializer

def of_serializer {α} (s : serializer α α)
  (h : ∀ w, there_and_back_again s w = pure w) : serial α :=
{ encode := s.encoder
, decode := s.decoder
, correctness := @h }

def of_serializer₁ {f : Type u → Type v}
  (s : Π α, serializer α α → serializer (f α) (f α))
  (h : ∀ α ser, valid_serializer ser →
       ∀ w, there_and_back_again (s α ser) w = pure w)
  (h₀ : ∀ {α} ser w, (s α (of_encoder (encoder ser))).encoder w = (s α ser).encoder w)
  (h₁ : ∀ {α} ser, (s α (of_decoder (decoder ser))).decoder = (s α ser).decoder) : serial1 f :=
{ encode := λ α put, (s α (of_encoder put)).encoder
, decode := λ α get, (s α (of_decoder get)).decoder
, correctness := by { introv hh, simp [h₀ ⟨put, get⟩,h₁ ⟨put,get⟩], apply h; assumption } }

def of_serializer₂ {f : Type u → Type v → Type w}
  (s : Π α β, serializer α α →
              serializer β β →
              serializer (f α β) (f α β))
  (h : ∀ α β serα serβ, valid_serializer serα → valid_serializer serβ →
       ∀ w, there_and_back_again (s α β serα serβ) w = pure w)
  (h₀ : ∀ {α β} serα serβ w, (s α β (of_encoder (encoder serα)) (of_encoder (encoder serβ))).encoder w = (s α β serα serβ).encoder w)
  (h₁ : ∀ {α β} serα serβ, (s α β (of_decoder (decoder serα)) (of_decoder (decoder serβ))).decoder = (s α β serα serβ).decoder) : serial2 f :=
{ encode := λ α β putα putβ, (s α β (of_encoder putα) (of_encoder putβ)).encoder
, decode := λ α β getα getβ, (s α β (of_decoder getα) (of_decoder getβ)).decoder
, correctness := by { introv hα hβ, simp [h₀ ⟨putα,getα⟩ ⟨putβ,getβ⟩,h₁ ⟨putα,getα⟩ ⟨putβ,getβ⟩],
                      apply h; assumption } }

end serial

namespace tactic
open interactive
open interactive.types
open lean.parser

meta def interactive.mk_serializer (p : parse texpr) : tactic unit :=
do g ← mk_mvar,
   refine ``(serial.of_serializer %%p %%g) <|>
     refine ``(serial.of_serializer₁ (λ α ser, %%p) %%g _ _) <|>
     refine ``(serial.of_serializer₂ (λ α β ser_α ser_β, %%p) %%g _ _),
   gs ← get_goals,
   set_goals [g],
   vs ← intros,
   cases vs.ilast,
   iterate $
     applyc ``serializer.there_and_back_again_map <|>
     applyc ``serializer.there_and_back_again_pure <|>
     applyc ``serializer.there_and_back_again_seq,
  gs' ← get_goals,
  set_goals (gs ++ gs'),
  repeat $
    intros >>
    `[simp *] <|>
    reflexivity

end tactic


syntax:1021 term:1021 "·" term:1022 : term
macro_rules
  | `($a·$f $args*) => `($f $a $args*)
  | `($a·$f)        => `($f $a)

example [Add a] (x y : a) (f : a → b) (g : b → c) (h : c → a) : a := y + x·f·g·h + x·id


import Graph.Graph
import Graph.UndirectedGraph
import Std

/-!
## Traverse
-/

namespace Graph

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

private def depthFirstTraverseAux (g : Graph α β) (visit : Nat -> γ -> γ × Bool) (leave : (Nat -> γ -> γ )) (state : γ) (sources : Array Nat) (visited : Array Bool) : Nat -> γ × Bool × Array Bool
  | 0 => (state, true, #[])
  | n + 1 => Id.run do
    let mut visited := visited
    let mut state := state
    for id in sources do
      if visited[id]! then continue else
      visited := visited.set! id true
      let (newState, terminate?) := visit id state;
      state := newState
      if terminate? then return (leave id state, true, #[]) else
      let adjacencyList := (g.vertices[id]!.adjacencyList.map (λ edge => edge.target)).filter (!visited[.]!)
      let (newState, terminate?, newVisited) := g.depthFirstTraverseAux visit leave state adjacencyList visited n
      visited := newVisited
      state := leave id newState
      if terminate? then return (state, true, #[])

    return (state, false, visited)

/-- A depth-first traversal of the graph starting at `sources`. Nodes on the same "level" of the traversal are visited in order of the edges added.
    `visit` is a function executed at each vertex, its parameters are the vertex ID and the current state, it should return a new state and
    a boolean which terminates the traversal if true (but it will still leave the node). The optional parameter `leave` is executed when the node is left,
    when all its successors have been visited, uses the same state.
    Please provide a starting state. See example uses in `Graph.TraverseExample`. -/
def depthFirstTraverse (g : Graph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (leave : Nat -> γ -> γ  := (λ _ x => x)) : γ :=
  (g.depthFirstTraverseAux visit leave startingState sources (mkArray g.vertexCount false) (g.vertexCount)).1

/-- A depth-first traversal started from all vertices in order. Each vertex is visited exactly once. See `depthFirstTraverse` for more info. -/
def depthFirstCompleteTraverse (g : Graph α β) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (leave : Nat -> γ -> γ  := (λ _ x => x)) : γ :=
  g.depthFirstTraverse g.getAllVertexIDs startingState visit leave

private def breadthFirstTraverseAux (g : Graph α β) (visit : Nat -> γ -> γ × Bool) (state : γ) (startingSources : Array Nat) (sources : Array Nat) (visited : Array Bool) : Nat -> γ
  | 0 => state
  | n + 1 => Id.run do
    let mut visited := visited
    let mut state := state
    let mut nextSources : Lean.HashSet Nat := Lean.HashSet.empty
    for id in sources do
      visited := visited.set! id true
      let (newState, terminate?) := visit id state;
      state := newState
      if terminate? then return state else
      let adjacencyList := (g.vertices[id]!.adjacencyList.map (λ edge => edge.target))
      for targetId in adjacencyList do nextSources := nextSources.insert targetId

    let sourcesArray : Array Nat := nextSources.fold (λ arr id => if visited[id]! then arr else arr.push id) #[]
    let startingSources := startingSources.filter (!visited[.]!)
    match (sourcesArray.isEmpty, startingSources.isEmpty) with
      | (false, _) => g.breadthFirstTraverseAux visit state startingSources sourcesArray visited n
      | (_, false) => g.breadthFirstTraverseAux visit state startingSources.pop #[startingSources.back] visited n
      | (true, true) => state

/-- A breadth-first traversals of the graph starting at the `sources` in order, sources should not contain duplicates. Each vertex is only visited at most once.
    Nodes on the same "level" of the traversal will be visited in random order. If you need the order to be fixed then have a look at `breadthFirstTraverseDeprecated`.
    `visit` is a function executed at each vertex, its parameters are the vertex ID and the current state, it should return a new state and a boolean which terminates
    the traversal if true. Please provide a starting state. `maxDepth` is an optional parameter you can use to limit the depth of the traversal.
    See example uses in `Graph.TraverseExample`. -/
def breadthFirstTraverse (g : Graph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (maxDepth : Nat := g.vertexCount + sources.size) : γ := Id.run do
  g.breadthFirstTraverseAux visit startingState sources.reverse #[] (mkArray g.vertexCount false) maxDepth

/-- A breadth-first traversal started from all vertices in order. Each vertex is visited exactly once. See `breadthFirstTraverse` for more info. -/
def breadthFirstCompleteTraverse (g : Graph α β) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (maxDepth : Nat := g.vertexCount) : γ :=
  g.breadthFirstTraverse g.getAllVertexIDs startingState visit maxDepth

namespace UndirectedGraph

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

/-- See directed graph. -/
def depthFirstCompleteTraverse (ug : UndirectedGraph α β) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (leave : Nat -> γ -> γ  := (λ _ x => x)) : γ :=
  ug.graph.depthFirstCompleteTraverse startingState visit leave

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

/-- See directed graph. -/
def breadthFirstCompleteTraverse (ug : UndirectedGraph α β) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (maxDepth : Nat := ug.vertexCount) : γ :=
  ug.graph.breadthFirstCompleteTraverse startingState visit maxDepth

end UndirectedGraph
end Graph


import GeneralizedRewriting.Algorithm
import GeneralizedRewriting.Eauto

section Examples

variable (α β γ: Type)
variable (Rα: relation α) (Rβ: relation β) (Rγ: relation γ)
variable (Pα: α → Prop) (Pβ: β → Prop) (Pγ: γ → Prop)
variable (Pαβγ: α → β → Prop)
variable (fαβ: α → β) (fβγ: β → γ)
variable [Proper_fαβ: Proper (Rα ==> Rβ) fαβ]
variable [Proper_Pα: Proper (Rα ==> Iff) Pα]
variable [PER Rα] [PER Rβ]

set_option trace.Meta.Tactic.grewrite true
set_option trace.Meta.Tactic.eauto true
set_option trace.Meta.Tactic.eauto.hints true

-- Smallest example
example (h: Rα a a') (finish: Pα a') : Pα a := by
  grewrite h
  exact finish

-- Rewrite a PER within itself
example (h: Rα a a') (finish: Rα a' x) : Rα a x := by
  grewrite h
  exact finish
example (h: Rα a a') (finish: Rα x a') : Rα x a := by
  grewrite h
  exact finish

-- Nested function call
example (h: Rα a a') (finish: Rβ (fαβ a') x): Rβ (fαβ a) x := by
  grewrite h
  exact finish

-- Multiple occurrences
example (h: Rα a a') (finish: Rα a' a'): Rα a a := by
  grewrite h
  exact finish
example (h: Rα a a') (finish: Rα a' a): Rα a a := by
  grewrite h at 1
  exact finish
example (h: Rα a a') (finish: Rα a a'): Rα a a := by
  grewrite h at 2
  exact finish
example (h: Rα a a') (finish: Rα a' a'): Rα a a := by
  grewrite h at -1
  grewrite h at 1
  exact finish

-- More complex selection
example (h: Rα a a') (finish: Pα a'): Pα a ∧ Pα a ∧ Pα a ∧ Pα a ∧ Pα a ∧ Pα a := by
  grewrite h at 5
  grewrite h at - 2 4
  grewrite h
  repeat (constructor; assumption)
  assumption

end Examples


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import algebra.group.pi
import group_theory.group_action.defs

/-!
# Pi instances for multiplicative actions

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

This file defines instances for mul_action and related structures on Pi types.

## See also

* `group_theory.group_action.option`
* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
* `group_theory.group_action.sum`
-/

universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)

namespace pi

@[to_additive pi.has_vadd']
instance has_smul' {g : I → Type*} [Π i, has_smul (f i) (g i)] :
  has_smul (Π i, f i) (Π i : I, g i) :=
⟨λ s x, λ i, (s i) • (x i)⟩

@[simp, to_additive]
lemma smul_apply' {g : I → Type*} [∀ i, has_smul (f i) (g i)] (s : Π i, f i) (x : Π i, g i) :
  (s • x) i = s i • x i :=
rfl

@[to_additive]
instance is_scalar_tower {α β : Type*}
  [has_smul α β] [Π i, has_smul β $ f i] [Π i, has_smul α $ f i]
  [Π i, is_scalar_tower α β (f i)] : is_scalar_tower α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_assoc x y (z i)⟩

@[to_additive]
instance is_scalar_tower' {g : I → Type*} {α : Type*}
  [Π i, has_smul α $ f i] [Π i, has_smul (f i) (g i)] [Π i, has_smul α $ g i]
  [Π i, is_scalar_tower α (f i) (g i)] : is_scalar_tower α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_assoc x (y i) (z i)⟩

@[to_additive]
instance is_scalar_tower'' {g : I → Type*} {h : I → Type*}
  [Π i, has_smul (f i) (g i)] [Π i, has_smul (g i) (h i)] [Π i, has_smul (f i) (h i)]
  [Π i, is_scalar_tower (f i) (g i) (h i)] : is_scalar_tower (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_assoc (x i) (y i) (z i)⟩

@[to_additive]
instance smul_comm_class {α β : Type*}
  [Π i, has_smul α $ f i] [Π i, has_smul β $ f i] [∀ i, smul_comm_class α β (f i)] :
  smul_comm_class α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_comm x y (z i)⟩

@[to_additive]
instance smul_comm_class' {g : I → Type*} {α : Type*}
  [Π i, has_smul α $ g i] [Π i, has_smul (f i) (g i)] [∀ i, smul_comm_class α (f i) (g i)] :
  smul_comm_class α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_comm x (y i) (z i)⟩

@[to_additive]
instance smul_comm_class'' {g : I → Type*} {h : I → Type*}
  [Π i, has_smul (g i) (h i)] [Π i, has_smul (f i) (h i)]
  [∀ i, smul_comm_class (f i) (g i) (h i)] : smul_comm_class (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_comm (x i) (y i) (z i)⟩

@[to_additive]
instance {α : Type*} [Π i, has_smul α $ f i] [Π i, has_smul αᵐᵒᵖ $ f i]
  [∀ i, is_central_scalar α (f i)] : is_central_scalar α (Π i, f i) :=
⟨λ r m, funext $ λ i, op_smul_eq_smul _ _⟩

/-- If `f i` has a faithful scalar action for a given `i`, then so does `Π i, f i`. This is
not an instance as `i` cannot be inferred. -/
@[to_additive pi.has_faithful_vadd_at "If `f i` has a faithful additive action for a given `i`, then
so does `Π i, f i`. This is not an instance as `i` cannot be inferred"]
lemma has_faithful_smul_at {α : Type*}
  [Π i, has_smul α $ f i] [Π i, nonempty (f i)] (i : I) [has_faithful_smul α (f i)] :
  has_faithful_smul α (Π i, f i) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ a : f i, begin
  classical,
  have := congr_fun (h $ function.update (λ j, classical.choice (‹Π i, nonempty (f i)› j)) i a) i,
  simpa using this,
end⟩

@[to_additive pi.has_faithful_vadd]
instance has_faithful_smul {α : Type*}
  [nonempty I] [Π i, has_smul α $ f i] [Π i, nonempty (f i)] [Π i, has_faithful_smul α (f i)] :
  has_faithful_smul α (Π i, f i) :=
let ⟨i⟩ := ‹nonempty I› in has_faithful_smul_at i

@[to_additive]
instance mul_action (α) {m : monoid α} [Π i, mul_action α $ f i] :
  @mul_action α (Π i : I, f i) m :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul α _ }

@[to_additive]
instance mul_action' {g : I → Type*} {m : Π i, monoid (f i)} [Π i, mul_action (f i) (g i)] :
  @mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul _ _ }

instance smul_zero_class (α) {n : ∀ i, has_zero $ f i}
  [∀ i, smul_zero_class α $ f i] :
  @smul_zero_class α (Π i : I, f i) (@pi.has_zero I f n) :=
{ smul_zero := λ c, funext $ λ i, smul_zero _ }

instance smul_zero_class' {g : I → Type*} {n : Π i, has_zero $ g i}
  [Π i, smul_zero_class (f i) (g i)] :
  @smul_zero_class (Π i, f i) (Π i : I, g i) (@pi.has_zero I g n) :=
{ smul_zero := by { intros, ext x, apply smul_zero } }

instance distrib_smul (α) {n : ∀ i, add_zero_class $ f i} [∀ i, distrib_smul α $ f i] :
  @distrib_smul α (Π i : I, f i) (@pi.add_zero_class I f n) :=
{ smul_add := λ c f g, funext $ λ i, smul_add _ _ _ }

instance distrib_smul' {g : I → Type*} {n : Π i, add_zero_class $ g i}
  [Π i, distrib_smul (f i) (g i)] :
  @distrib_smul (Π i, f i) (Π i : I, g i) (@pi.add_zero_class I g n) :=
{ smul_add := by { intros, ext x, apply smul_add } }

instance distrib_mul_action (α) {m : monoid α} {n : ∀ i, add_monoid $ f i}
  [∀ i, distrib_mul_action α $ f i] :
  @distrib_mul_action α (Π i : I, f i) m (@pi.add_monoid I f n) :=
{ ..pi.mul_action _,
  ..pi.distrib_smul _ }

instance distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, add_monoid $ g i}
  [Π i, distrib_mul_action (f i) (g i)] :
  @distrib_mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) (@pi.add_monoid I g n) :=
{ .. pi.mul_action',
  .. pi.distrib_smul' }

lemma single_smul {α} [monoid α] [Π i, add_monoid $ f i]
  [Π i, distrib_mul_action α $ f i] [decidable_eq I] (i : I) (r : α) (x : f i) :
  single i (r • x) = r • single i x :=
single_op (λ i : I, ((•) r : f i → f i)) (λ j, smul_zero _) _ _

/-- A version of `pi.single_smul` for non-dependent functions. It is useful in cases Lean fails
to apply `pi.single_smul`. -/
lemma single_smul' {α β} [monoid α] [add_monoid β]
  [distrib_mul_action α β] [decidable_eq I] (i : I) (r : α) (x : β) :
  single i (r • x) = r • single i x :=
single_smul i r x

lemma single_smul₀ {g : I → Type*} [Π i, monoid_with_zero (f i)] [Π i, add_monoid (g i)]
  [Π i, distrib_mul_action (f i) (g i)] [decidable_eq I] (i : I) (r : f i) (x : g i) :
  single i (r • x) = single i r • single i x :=
single_op₂ (λ i : I, ((•) : f i → g i → g i)) (λ j, smul_zero _) _ _ _

instance mul_distrib_mul_action (α) {m : monoid α} {n : Π i, monoid $ f i}
  [Π i, mul_distrib_mul_action α $ f i] :
  @mul_distrib_mul_action α (Π i : I, f i) m (@pi.monoid I f n) :=
{ smul_one := λ c, funext $ λ i, smul_one _,
  smul_mul := λ c f g, funext $ λ i, smul_mul' _ _ _,
  ..pi.mul_action _ }

instance mul_distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, monoid $ g i}
  [Π i, mul_distrib_mul_action (f i) (g i)] :
  @mul_distrib_mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) (@pi.monoid I g n) :=
{ smul_mul := by { intros, ext x, apply smul_mul' },
  smul_one := by { intros, ext x, apply smul_one } }

end pi

namespace function

/-- Non-dependent version of `pi.has_smul`. Lean gets confused by the dependent instance if this
is not present. -/
@[to_additive "Non-dependent version of `pi.has_vadd`. Lean gets confused by the dependent instance
if this is not present."]
instance has_smul {ι R M : Type*} [has_smul R M] :
  has_smul R (ι → M) :=
pi.has_smul

/-- Non-dependent version of `pi.smul_comm_class`. Lean gets confused by the dependent instance if
this is not present. -/
@[to_additive "Non-dependent version of `pi.vadd_comm_class`. Lean gets confused by the dependent
instance if this is not present."]
instance smul_comm_class {ι α β M : Type*}
  [has_smul α M] [has_smul β M] [smul_comm_class α β M] :
  smul_comm_class α β (ι → M) :=
pi.smul_comm_class

@[to_additive]
lemma update_smul {α : Type*} [Π i, has_smul α (f i)] [decidable_eq I]
  (c : α) (f₁ : Π i, f i) (i : I) (x₁ : f i) :
  update (c • f₁) i (c • x₁) = c • update f₁ i x₁ :=
funext $ λ j, (apply_update (λ i, (•) c) f₁ i x₁ j).symm

end function

namespace set

@[to_additive]
lemma piecewise_smul {α : Type*} [Π i, has_smul α (f i)] (s : set I) [Π i, decidable (i ∈ s)]
  (c : α) (f₁ g₁ : Π i, f i) :
  s.piecewise (c • f₁) (c • g₁) = c • s.piecewise f₁ g₁ :=
s.piecewise_op _ _ (λ _, (•) c)

end set

section extend

@[to_additive] lemma function.extend_smul {R α β γ : Type*} [has_smul R γ]
  (r : R) (f : α → β) (g : α → γ) (e : β → γ) :
  function.extend f (r • g) (r • e) = r • function.extend f g e :=
funext $ λ _, by convert (apply_dite ((•) r) _ _ _).symm

end extend


/-
Copyright (c) 2019 Jesse Michael Han. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Jesse Michael Han

Monadic parsing in Lean, following Hutton-Meijer's 'Monadic Parsing in Haskell` (doi: 10.1017/S0956796898003050).

A related implementation for character buffers, due to Gabriel Ebner, is in data.buffer.
-/

import tactic

import init.data.string

section miscellany

lemma forall_iff_of_eq {α} {P Q : α → Prop} (h : P = Q) : (∀ x, P x ↔ Q x) :=
λ _, h ▸ iff_of_eq rfl

lemma mem_cons_iff {α} (xs : list α) (x y : α) : y ∈ (x::xs) ↔ y = x ∨ y ∈ xs :=
(set.mem_union x (eq y) (λ (x : α), list.mem y xs))

example {α β} (xs : list α) {x : α} (f : α → β) (H_mem : x ∈ xs) : f x ∈ xs.map f := list.mem_map_of_mem f H_mem

end miscellany

namespace char

notation `[]` := list.nil
notation h :: t  := list.cons h t
notation `[` l:(foldr `, ` (h t, list.cons h t) list.nil `]`) := l

instance : has_zero string := ⟨""⟩

meta def check_is_valid_char : tactic unit := `[norm_num[is_valid_char]]

/-- char.mk' will automatically attempt to use `check_is_valid_char` to produce the validity certificate -/
def mk' (n : ℕ) (H : is_valid_char n . check_is_valid_char) : char :=
char.mk n H

def lower : list char := "abcdefghijklmnopqrstuvwxyz".data

def upper : list char := "ABCDEFGHIJKLMNOPQRSTUVWXYZ".data

lemma is_upper_of_mem_upper {c} (H : c ∈ upper) : is_upper c :=
by {unfold is_upper upper, repeat{cases H, subst H, omega}, cases H }

lemma to_lower_upper_eq_lower : upper.map to_lower = lower := dec_trivial

lemma mem_lower_of_to_lower_upper {c} (H : c ∈ upper) : c.to_lower ∈ lower :=
by {rw[<-to_lower_upper_eq_lower], exact list.mem_map_of_mem _ ‹_›}

def lowercase : {c // c ∈ upper} → {c // c ∈ lower} :=
λ ⟨c,H⟩, ⟨char.to_lower c, mem_lower_of_to_lower_upper H⟩

def alpha : list char := lower ++ upper

def numeric : list char := "0123456789".data

def alphanumeric := alpha ++ numeric

section whitespace_chars

def cr := mk' 0x0D

def newline : char := mk' 0x0a

def space : char := ' '

def thin_space : char := ' '

def hair_space : char := ' '

def no_break_space : char := ' '

def medium_mathematical_space : char := ' '

def ideographic_space : char := '　'

def zero_width_no_break_space := ''

def zero_width_space := ''

def punctuation_space := ' '

def figure_space := ' '

def six_per_em_space := ' '

def four_per_em_space := ' '

def three_per_em_space := ' '

def em_space := ' '

def en_space := ' '

def em_quad := ' '

def en_quad := ' '

def mongolian_vowel_separator := ''

def ogham_space_mark := ' '

def tab := char.mk' 0x09

def narrow_no_break_space := ' '

def whitespace_chars : list char :=
  [cr,
   newline,
   space,
   thin_space,
   hair_space,
   tab,
   zero_width_space,
   zero_width_no_break_space,
   narrow_no_break_space,
   medium_mathematical_space,
   ideographic_space,
   punctuation_space,
   figure_space,
   six_per_em_space,
   four_per_em_space,
   three_per_em_space,
   em_quad,
   en_quad,
   en_space,
   em_space,
   mongolian_vowel_separator,
   no_break_space]

end whitespace_chars

end char

namespace string

def to_lower (arg : string) : string := ⟨arg.data.map char.to_lower⟩

def reverse (arg : string) : string :=
⟨arg.data.reverse⟩

end string

@[reducible]meta def parser' := state_t string

meta def parser_tactic := parser' tactic

namespace parser_tactic
section parser_tactic
variables {α : Type}

meta def mk (run : string → tactic (α × string)) : parser_tactic α :=
state_t.mk run

meta def lift {α} (val : tactic α) : parser_tactic α := state_t.lift val

meta def run (p : parser_tactic α) : string → tactic (α × string) :=
state_t.run p

meta def result (p : parser_tactic α) (arg : string) : tactic α :=
p.run arg >>= return ∘ prod.fst

meta def get_result [has_reflect α] (p : parser_tactic α) (arg : string) : tactic unit :=
p.result arg >>= λ x, tactic.exact (reflect x)

/--
`run parser p arg` runs `p` as if `arg` were the current state.

It returns the result of p, leaving the actual state unchanged.
-/
meta def run_parser (p : parser_tactic α) : string → parser_tactic α :=
λ arg, lift (do (a,b) <- p.run arg, return a)

meta instance monad_parser_tactic : monad parser_tactic :=
by change _root_.monad (state_t _ _); apply_instance

meta instance alternative_parser_tactic : alternative parser_tactic :=
by change _root_.alternative (state_t _ _); apply_instance

meta instance : has_append (parser_tactic string) :=
⟨λ p₁ p₂, do a <- p₁, b <- p₂, return $ a ++ b⟩

meta def fail : parser_tactic α := parser_tactic.mk $ λ _, tactic.failed

meta def trace_state : parser_tactic unit :=
parser_tactic.mk $ λ str, tactic.trace str >> return ((), str)

meta def get_state : parser_tactic string :=
state_t.get

meta def put_state : string -> parser_tactic unit :=
λ arg, state_t.put arg

meta def modify_state : (string -> string) -> parser_tactic unit :=
λ m, state_t.modify m

meta def prepend_state : string -> parser_tactic unit :=
λ arg, modify_state (λ σ, arg ++ σ)

meta def append_state : string -> parser_tactic unit :=
λ arg, modify_state (λ σ, σ ++ arg)

meta def run_parser' (p : parser_tactic α) : parser_tactic string → parser_tactic α :=
λ q, q >>= run_parser p

meta def skip : parser_tactic unit :=
parser_tactic.mk $ λ str, return ((), str)

meta def trace (msg : string) : parser_tactic unit :=
parser_tactic.mk $ λ str, tactic.trace msg >> return ((), str)

meta def try_core (p : parser_tactic α) : parser_tactic (option α) :=
mk $ (λ arg, do r <- tactic.try_core (p.run arg),
      match r with
      | none     := return (none, arg)
      | (some x) := return (some x.1, x.2)
      end)

meta def try (p : parser_tactic α) : parser_tactic unit :=
try_core p >>= λ r, match r with
                    | none := skip
                    | some x := return ()
                    end

meta def to_tactic (p : parser_tactic α) : string → tactic α :=
λ arg, (p.run arg) >>= return ∘ prod.fst

meta instance : has_coe (parser_tactic α) (string → tactic α) :=
⟨to_tactic⟩

meta def parser_tactic_format {α} [H : has_to_format α] : α × string → format :=
λ ⟨r,σ⟩,
    format.line ++ ("Result:") ++
    format.line ++ format.line ++ (format.nest 5 $ to_fmt r) ++
    format.line ++ format.line ++
    "──────────────────────────────────────" ++
    format.line ++ format.line ++ ("State:") ++
    format.line ++ format.line ++ (format.nest 5 $ to_fmt σ)

/-- For testing parsers on strings -/
meta def run' {α} [has_to_format α] (p : parser_tactic α) (arg : string) : tactic unit :=
  p.run arg >>= λ fmt, return $ _root_.trace_fmt (parser_tactic_format fmt) (λ _, ())

end parser_tactic
end parser_tactic

open parser_tactic

namespace parser_tactic

meta def item : parser_tactic char :=
parser_tactic.mk $ λ str,
  match str with
  | ⟨[]⟩      := tactic.failed
  | ⟨(x::xs)⟩ := return (x, ⟨xs⟩)
  end

meta def eof : parser_tactic unit :=
parser_tactic.mk $ λ str,
  match str with
  | ⟨[]⟩ := return ⟨(), str⟩
  | ⟨(x::xs)⟩ := tactic.failed
  end

/--
`item0` is like `item`, but does not consume anything (leaves the state unchanged).
-/
meta def item0 : parser_tactic char :=
parser_tactic.mk $ λ str,
  match str with
  | ⟨[]⟩      := tactic.failed
  | ⟨(x::xs)⟩ := return (x, ⟨x::xs⟩)
  end

meta def to_string : parser_tactic char → parser_tactic string :=
λ p, do x <- p, return x.to_string

meta def to_string' : parser_tactic (list char) → parser_tactic string :=
λ p, do x <- p, return $ string_imp.mk x

meta instance parser_to_string : has_coe (parser_tactic (char)) (parser_tactic string) :=
⟨to_string⟩

meta instance list_char_coe : has_coe (parser_tactic (list char)) (parser_tactic string) :=
⟨to_string'⟩

meta def sat (P : char → Prop) [decidable_pred P] : parser_tactic char :=
item >>= λ x, (if P x then return x else fail)

section eq_any
variables {α : Type*} [decidable_eq α]

def eq_any (cs : list α) : α → Prop :=
λ c, cs.foldr (λ x, λ b, (= c) x ⊔ b)  ⊥

@[simp]lemma eq_any_cons {c : α} {cs} : eq_any (c::cs) = λ x, c = x ∨ eq_any cs x := rfl

instance eq_any_decidable_pred : ∀ {cs : list α}, decidable_pred (eq_any cs) :=
begin
  intro cs, induction cs with c cs ih, unfold eq_any, tidy, apply_instance,
  intro x, haveI : decidable (eq_any cs x) := by apply ih,
  by_cases c = x,
    { exact decidable.is_true (by simp*) },
    { by_cases (eq_any cs x),
          { simp*, apply_instance },
          { simp*, apply_instance }}
end

/- note: we'll never need this, but it's basically free -/
def eq_all (cs : list α) : α → Prop :=
λ c, cs.foldr (λ x, λ b, (= c) x ⊓ b)  ⊤

@[simp]lemma eq_all_cons {c : α} {cs} : eq_all (c::cs) = λ x, c = x ∧ eq_all cs x := rfl

instance eq_all_decidable_pred : ∀ {cs : list α}, decidable_pred (eq_all cs) :=
begin
  intro cs, induction cs with c cs ih, unfold eq_all, tidy, apply_instance,
  intro x, haveI : decidable (eq_all cs x) := by apply ih,
  by_cases c = x,
    { by_cases (eq_all cs x),
          { simp*, apply_instance },
          { simp*, apply_instance }},
    { exact decidable.is_false (by simp*) }
end

end eq_any

meta def ch  (c : char) : parser_tactic char := sat (= c)

meta def chs (cs : list char) : parser_tactic char := sat (eq_any cs)

meta def not_chs (cs : list char) : parser_tactic char := sat (λ c, ¬ eq_any cs c)

meta def not_ch (c : char) : parser_tactic char := not_chs $ [c]

meta def str : string → parser_tactic string
| ⟨[]⟩    := pure ""
| ⟨x::xs⟩ := do y <- ch x,
               z <- str ⟨xs⟩,
               return $ y.to_string ++ z

meta def nil_if_fail {α} : parser_tactic α → parser_tactic (list α) :=
λ p, (p >>= return ∘ return) <|> return []

meta def fail_if_nil : parser_tactic string → parser_tactic string :=
λ p, do x <- p, guard (x ≠ ""), return x

meta def fail_if_nil' {α} [decidable_eq α] : parser_tactic (list α) → parser_tactic (list α) :=
λ p, do x <- p, guard (x ≠ []), return x

meta def fail_if_state_nil {α} (p : parser_tactic α) : parser_tactic α :=
(get_state >>= λ arg, guard (arg ≠ "")) >> p

meta def list.mcons {m} [monad m] {α} (x : α) (xs : list α) : m (list α) :=
return (x::xs)

meta def repeat {α} (p : parser_tactic α) : parser_tactic (list α) :=
(do a  <- p,
    as <- repeat,
    return (a::as)) <|> return []

meta def repeat1 {α : Type} : parser_tactic α → parser_tactic (list α) :=
λ p, list.cons <$> p <*> repeat p

/--
`succeeds' p` runs p, but does not change the state even if p succeeds.
-/
meta def succeeds' {α} (p : parser_tactic α) : parser_tactic bool :=
succeeds $ get_state >>= (run_parser p)

meta def fail_iff_succeeds {α} (p : parser_tactic α) : parser_tactic unit :=
succeeds' p >>= λ b, ite b fail skip

/--
`until p q` runs q until p succeeds, and returns the result of p and all the results of q
-/
meta def until {α β} (p : parser_tactic α) (q : parser_tactic β) : parser_tactic (α × list β) :=
   repeat (fail_iff_succeeds p *> q) >>= λ _, prod.mk <$> p <*> return ‹_›

/--
`until' p q` runs q until p succeeds, and returns the result of p
-/
meta def until' {α β} (p : parser_tactic α) (q : parser_tactic β) : parser_tactic α :=
prod.fst <$> until p q

/--
`until'' p q` runs q until p succeeds, and returns all results of q
-/
meta def until'' {α β} (p : parser_tactic α) (q : parser_tactic β) : parser_tactic (list β) :=
prod.snd <$> until p q

/--
`lookahead arg` succeeds if and only if `arg` is a substring of the current state
-/
meta def lookahead (arg : string) : parser_tactic bool :=
succeeds' $ until' (str arg) item

run_cmd (lookahead "foo").run' "abcfoode"
/--
`not_str arg` consumes and returns the longest prefix which does not match `arg`.
-/
meta def not_str : string → parser_tactic string := λ arg,
until'' (str arg) item

meta def not_strs : list string → parser_tactic string := λ arg,
repeat $ succeeds (list.mfirst str arg) >>= (λ b, if b then fail else item)

meta def sepby_aux {α β} : parser_tactic α → parser_tactic β → parser_tactic (list α) :=
λ p sep,
  list.cons <$> p <*> repeat (sep *> p)

meta def sepby {α β} : parser_tactic α → parser_tactic β → parser_tactic (list α) :=
λ p sep,
  (sepby_aux p sep) <|> return []

/-
The choice operator (++) from Hutton-Meijer does not have a direct analogue in this framework, since we use `tactic` as the monad instead of `list`.

However, the deterministic choice operator (+++):
1. fails iff both p and q fail
2. if p succeeds, returns the result of p
3. if p fails, runs q

and therefore (+++) is emulated by the orelse (<|>) combinator.
-/

/-
c.f. Hutton-Meijer:

chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainl p op a = (p ‘chainl1‘ op) +++ return a

chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
p ‘chainl1‘ op = do {a <- p; rest a}
                 where
                   rest a = (do f <- op
                                b <- p
                                rest (f a b))
                            +++ return a
-/

meta def chainl_rest {α} (p : parser_tactic α) (op : parser_tactic (α → α → α)) : α → parser_tactic α :=
λ a,
  (do f <- op,
     b <- p,
     chainl_rest (f a b)) <|> return a

meta def chainl1 {α} (p : parser_tactic α) (op : parser_tactic (α → α → α)) : parser_tactic α :=
do a <- p, chainl_rest p op a

meta def chainl {α} : parser_tactic α → parser_tactic (α → α → α) → α → parser_tactic α :=
λ p op a, (chainl1 p op) <|> return a

meta def chainr_rest {α} (p : parser_tactic α) (op : parser_tactic (α → α → α)) : α → parser_tactic α :=
λ a,
  (do f <- op,
     b <- p,
     chainr_rest (f b a)) <|> return a

meta def chainr1 {α} (p : parser_tactic α) (op : parser_tactic (α → α → α)) : parser_tactic α :=
do a <- p, chainr_rest p op a

meta def chainr {α} : parser_tactic α → parser_tactic (α → α → α) → α → parser_tactic α :=
λ p op a, (chainr1 p op) <|> return a

/- Lexical combinators -/

meta def space : parser_tactic string := repeat (sat (= ' '))

meta def whitespace : parser_tactic string := repeat (chs char.whitespace_chars)

meta def not_whitespace : parser_tactic string := fail_if_nil $ repeat (not_chs char.whitespace_chars)

/-- `token p` runs p, then consumes as many spaces as possible before discarding them. -/
meta def token {α} (p : parser_tactic α) : parser_tactic α := p <* space

/-- `token' p runs p, then consumes as much whitespace as possible before discarding it. -/
meta def token' {α} (p : parser_tactic α) : parser_tactic α := p <* whitespace

meta def symb : string → parser_tactic string := token ∘ str

/-- An alphanumeric token is a string of alphanumeric characters which must begin with an alpha character. -/
meta def alphanumeric_token : parser_tactic string :=
(string.append <$> (sat char.is_alpha) <*> (repeat (sat char.is_alphanum))) <* whitespace

meta def digit : parser_tactic char  := chs char.numeric

def from_base_10_aux : ℕ → list ℕ → ℕ
| _      []          := 0
| 0      (x::xs)     := x
| (n+1)  (x::xs)     := (10^n) * x + from_base_10_aux n xs

def from_base_10 : list ℕ → ℕ := λ xs, from_base_10_aux xs.length xs

meta def digit' : parser_tactic ℕ :=
do x <- digit,
   if (x = '0') then return 0 else
   if (x = '1') then return 1 else
   if (x = '2') then return 2 else
   if (x = '3') then return 3 else
   if (x = '4') then return 4 else
   if (x = '5') then return 5 else
   if (x = '6') then return 6 else
   if (x = '7') then return 7 else
   if (x = '8') then return 8 else
   if (x = '9') then return 9 else
   fail

meta def number' : parser_tactic ℕ := (repeat digit') >>= return ∘ from_base_10

meta def number : parser_tactic ℕ := (fail_if_nil' (repeat digit')) >>= return ∘ from_base_10

/--
`delimiter_aux arg_left arg_right k` believes that it has passed `k` copies of `arg_left`, and is expecting `k` copies of `arg_right`.

Upon encountering a copy of `arg_right`, it calls itself, decrementing the counter by 1.

If it never encounters an opening `arg_left`, it returns the empty string.
-/

/-
running delimiter on (foo (bar )) baz produces (foo (bar )).
-/
/-
TODO(jesse) refactor this to consume extra characters to the right instead of left
-/
meta def delimiter_aux (arg_left : string) (arg_right : string) : Π k : ℕ, parser_tactic string
| 0       := (not_str arg_left ++ str arg_left ++ delimiter_aux 1)
              <|> return ""
| (k + 1) := (not_str arg_left ++ str arg_left ++ delimiter_aux (k + 2))
              <|> ((not_str arg_right) ++ str arg_right) ++ delimiter_aux k

/-- `delimiter arg_left arg_right parses the delimiters, then returns their interior as a string -/
meta def delimiter (arg_left arg_right : string) : parser_tactic string :=
delimiter_aux arg_left arg_right 0

/--
`delimiter' p arg_right arg_left` parses the delimiters, then runs p on their interior.
-/
meta def delimiter' {α} (p : parser_tactic α) (arg_right) (arg_left) : parser_tactic α :=
delimiter arg_right arg_left >>= p.run_parser

meta def delimiter'' (arg_left arg_right : string) : parser_tactic string :=
do r <- (delimiter arg_left arg_right),
   r' <- run_parser (symb arg_left >> get_state) r,
   run_parser ((symb arg_right.reverse) >> get_state >>= return ∘ string.reverse) r'.reverse

meta def between (arg_left arg_right : string) : parser_tactic string :=
  (str arg_left ++ not_strs [arg_left, arg_right] ++ (between <|> return "") ++ not_strs [arg_left, arg_right] ++ str arg_right)

meta def apply {α} (p : parser_tactic α) : string → tactic (α × string) := (space *> p).run

--TODO(jesse) fix this so it also consumes the corresponding prefix of the actual state
meta def case_insensitive (p : string → parser_tactic string) : string → parser_tactic string :=
λ arg, do s <- get_state, run_parser (p arg.to_lower) s.to_lower

-- section parse_fol
-- open fol

-- meta instance {k} : has_to_tactic_format (preformula L_empty k)  :=
-- ⟨begin intro f, have := (reflected.has_to_tactic_format f).1 ,
--        apply this, apply_instance end⟩

-- meta def parse_preformula_aux : parser_tactic (preformula L_empty 0) :=
-- token' (str "∀") >> parse_preformula_aux >>= (λ x, return (preformula.all x)) <|>
-- (repeat item) *> return (&0 ≃ &0)

-- -- as vars are encountered, they are pushed onto the stack
-- -- the de Bruijn index assigned to an encountered free variable is its position in the stack.
-- -- a named variable is captured by the nearest quantifier with the same name

-- meta structure formula_state (k : ℕ) :=
-- (bound_var : list name)
-- (free_var : list name)
-- (result : preformula L_empty k)

-- #check formula_state.mk

-- -- meta def formula_state.var {k : ℕ} (σ : formula_state k) : tactic (list name) :=
-- -- σ.bound_var >>= (λ x, (σ.free_var >>= (λ y, return (x ++ y))))

-- meta def parse_preformula {k : ℕ} (σ : formula_state k) : parser_tactic (formula_state 0) :=
-- do token' (str "∀"),
--    v <- (alphanumeric_token),
--    let foo := ℕ in
--    return (formula_state.mk (σ.bound_var ++ [v]) (σ.free_var) foo )
-- -- TODO(jesse) finish this

-- -- @formula_state.mk 0 (σ.bound_var.append ([↑v] : list _)) σ.free_var (parse_preformula >>= _

-- -- meta def parse_preformula : parser_tactic (Σk, preformula L_empty k) :=
-- -- do token' (str "∀") >> (parse_preformula >>= λ x, return ⟨x.fst, x.2⟩)

-- -- run_cmd run' parse_preformula_aux "∀ ∀ ∀ ∀ foo"

-- -- fol.preterm.var : Π {L : Language}, ℕ → preterm L 0
-- -- fol.preterm.func : Π {L : Language} {l : ℕ}, L.functions l → preterm L l
-- -- fol.preterm.app : Π {L : Language} {l : ℕ}, preterm L (l + 1) → preterm L 0 → preterm L l

-- -- fol.preformula.falsum : Π {L : Language}, preformula L 0
-- -- fol.preformula.equal : Π {L : Language}, term L → term L → preformula L 0
-- -- fol.preformula.rel : Π {L : Language} {l : ℕ}, L.relations l → preformula L l
-- -- fol.preformula.apprel : Π {L : Language} {l : ℕ}, preformula L (l + 1) → term L → preformula L l
-- -- fol.preformula.imp : Π {L : Language}, preformula L 0 → preformula L 0 → preformula L 0
-- -- fol.preformula.all : Π {L : Language}, preformula L 0 → preformula L 0

-- -- ∀ x, x = x ∧ (f x y = 3)

-- meta def parse_eq : parser_tactic $ term L_empty → term L_empty → preformula L_empty 0 :=
-- (token (ch '=' >> return preformula.equal))

-- meta def parser_var : parser_tactic $ sorry := sorry

-- meta def parse_preterm {k} : parser_tactic (preterm L_empty k) := sorry

-- meta def parse_preformula {k} : parser_tactic (preformula L_empty k) := sorry

-- end parse_fol

section tests

run_cmd (until' (str "bar") item : parser_tactic string).run' "foo bar baz"

run_cmd (str "foobar" <* eof).run' "foobar"

run_cmd (fail_if_nil $ str "h").run' "hewwo" -- succeeds as it should

-- run_cmd (fail_if_nil $ str "").run' "hewwo" -- fails as it should

-- run_cmd run' (fail_if_state_nil $ skip) "" -- fails as it should

run_cmd (sepby (str "a" <|> str "b") (str ",")).run' "a,b,c,d"

run_cmd run' (fail_if_state_nil $ skip) "foo" -- succeeds as it should

run_cmd run' (delimiter "(" ")") "(1 + 2) + 3"

run_cmd run' (delimiter "[" "]") "[a + b + [c + d] + [e + [f]]] + 3"

run_cmd run' (delimiter "[" "]") "[]] + 3"

run_cmd run' (delimiter "[" "]") "[1 + 2 + 3" -- returns nothing as it should

run_cmd run' (delimiter "[" "]") "[a + b + [c + d] + [e + [f]]] + 3"

run_cmd run' (not_str "HEWWO") "DUH HEWWO"

run_cmd run' (repeat alphanumeric_token) "a1 a3 b3 b4 x12 xasd1"

run_cmd run' (token $ (str "foo")) "foo    bar"

run_cmd run' (sepby (str "foo") (str " ")) "foo foo foo foo"

run_cmd run' (repeat (str "foo")) "barfoofoobarbarbarfoo"

-- run_cmd run' (repeat1 (str "foo")) "barfoofoobarbarbarfoo" -- fails as it should

run_cmd run' (repeat1 (str "foo")) "foofoofoobarbarbarfoo"

run_cmd run' (str "foo") "foobarbaz"  -- (foo, barbaz)

run_cmd run' (repeat1 $ fail_if_nil $ token $ not_whitespace) "foo₁ foo₂ foo₃ foo₄ foo₅"

run_cmd (repeat $ str "a" <|> str "b").run' "bbababbaabaaaa" -- if one branch fails, the state is unchanged and passed to the other branch

end tests

end parser_tactic

open parser_tactic

namespace arith_expr

section arith_expr

open arith_expr

meta def parse_number (arg : string) : tactic unit :=
do n <- number'.to_tactic arg,
   tactic.exact `(n)

mutual inductive addop,mulop,digit,factor,term,expr
with addop : Type
     | plus             : addop
     | minus            : addop
with mulop : Type
     | mult             : mulop
     | div              : mulop
with digit : Type
     | zero             : digit
     | one              : digit
     | two              : digit
     | three            : digit
     | four             : digit
     | five             : digit
     | six              : digit
     | seven            : digit
     | eight            : digit
     | nine             : digit
with factor : Type
     | of_digit         : digit → factor
     | of_expr          : expr  → factor
with term : Type
     | of_factor        : factor → term
     | of_mulop         : mulop → term → factor → term
with expr : Type
     | of_term          : term → expr
     | of_addop         : addop → expr → term → expr

def term.of_digit := term.of_factor ∘ factor.of_digit

def expr.of_digit := expr.of_term ∘ term.of_digit

meta mutual def eval_addop,eval_mulop,eval_digit,eval_factor,eval_term,eval_expr
with eval_addop                : addop → ℕ → ℕ → ℕ
     | addop.plus              := (nat.add)
     | addop.minus             := (nat.sub)
with eval_mulop                : mulop → ℕ → ℕ → ℕ
     | mulop.mult              := (nat.mul)
     | mulop.div               := (nat.div)
with eval_digit                : digit → ℕ
     | digit.zero              := 0
     | digit.one               := 1
     | digit.two               := 2
     | digit.three             := 3
     | digit.four              := 4
     | digit.five              := 5
     | digit.six               := 6
     | digit.seven             := 7
     | digit.eight             := 8
     | digit.nine              := 9
with eval_factor               : factor → ℕ
     | (factor.of_digit k)     := eval_digit k
     | (factor.of_expr e)      := eval_expr e
with eval_term                 : term → ℕ
     | (term.of_factor f)      := eval_factor f
     | (term.of_mulop op t f)  := (eval_mulop op) (eval_term t) (eval_factor f)
with eval_expr                 : expr → ℕ
     | (expr.of_term t)        := eval_term t
     | (expr.of_addop op e t)  := (eval_addop op) (eval_expr e) (eval_term t)

meta def nat.to_fmt : ℕ → format := nat.has_to_format.to_format

meta instance format_digit : has_to_format digit :=
⟨λ x, nat.to_fmt (eval_digit x)⟩

meta instance format_factor : has_to_format factor :=
⟨λ x, nat.to_fmt (eval_factor x)⟩

meta instance format_term : has_to_format term :=
⟨λ x, nat.to_fmt (eval_term x)⟩

meta instance format_expr : has_to_format expr :=
⟨λ x, nat.to_fmt (eval_expr x)⟩

meta mutual def parse_addop,parse_mulop,parse_digit,parse_factor,parse_term,parse_expr
with parse_addop                : string → tactic (addop × string)
| arg := (token (str "+" >> return addop.plus <|> str "-" >> return addop.minus)).run arg
with parse_mulop                : string → tactic (mulop × string)
| arg := (token (str "*" >> return mulop.mult <|> str "/" >> return mulop.div)).run arg
with parse_digit                : string → tactic (digit × string)
| arg := (token $ trace "HEWWO" >>    trace_state >> do  x <- parser_tactic.digit,
   trace $ x.to_string ++ " WAS THE DIGIT I PARSED",
   if (x = '0') then return digit.zero else
   if (x = '1') then return digit.one else
   if (x = '2') then return digit.two else
   if (x = '3') then return digit.three else
   if (x = '4') then return digit.four else
   if (x = '5') then return digit.five else
   if (x = '6') then return digit.six else
   if (x = '7') then return digit.seven else
   if (x = '8') then return digit.eight else
   if (x = '9') then return digit.nine else
   fail).run arg
with parse_factor               : string → tactic (factor × string)
| arg := (fail_if_state_nil $ (trace "hello" >> (token $ (mk parse_digit) >>= return ∘ factor.of_digit <|> (mk parse_expr) >>= return ∘ factor.of_expr))).run arg
with parse_term                 : string → tactic (term × string)
| arg := (token $
            (do
               trace "hola",
               b <- succeeds' (do not_str "*" >> str "*"),
               if b then (do t <- (mk parse_term),
                            op <- (mk parse_mulop),
                            f  <- (mk parse_factor),
                            return $ term.of_mulop op t f)
                     else (mk parse_factor) >>= return ∘ term.of_factor
                -- e   <- (mk parse_expr),
                -- op  <- (mk parse_addop),
                -- t   <- (mk parse_term),
                -- return $ expr.of_addop op e t
             )).run arg
with parse_expr                 : string → tactic (expr × string)
| arg := (token $
            (do
               trace "bonjour",
               b <- succeeds' (do not_str "+" >> str "+"),
               if b then -- return (expr.of_digit digit.one)
                           (do p <- not_str "+",
                             e <- (mk parse_expr).run_parser p,
                            op <- (mk parse_addop),
                            t  <- (mk parse_term),
                            return $ expr.of_addop op e t)
                     else (mk parse_term) >>= return ∘ expr.of_term
                -- e   <- (mk parse_expr),
                -- op  <- (mk parse_addop),
                -- t   <- (mk parse_term),
                -- return $ expr.of_addop op e t
             )
                ).run arg

meta def parse_arith_expr : parser_tactic expr := mk parse_expr

run_cmd (mk parse_expr).run' "9 + 1 + 1"

-- run_cmd (parse_arith_expr >> parse_arith_expr).run' "1"

-- run_cmd (
-- do b <- succeeds' (do not_str "+" >> str "+"),
--    trace_state,
--    if b then (do d₁ <- (mk parse_digit),
--                  op <- (mk parse_addop),
--                  d₂ <- (mk parse_digit),
--                  return $ expr.of_addop op (expr.of_digit d₁) (term.of_digit d₂)

--              )
--         else (mk parse_digit) >>= return ∘ expr.of_digit

--   ).run' "8 + 7"

end arith_expr

end arith_expr

namespace calculator

section calculator

open calculator

def from_base_10_aux : ℕ → list ℤ → ℤ
| _ []               := 0
| 0 (x::xs)          := x
| (n+1) (x::xs)      := (10^n) * x + from_base_10_aux n xs

def from_base_10 : list ℤ → ℤ := λ xs, from_base_10_aux xs.length xs

meta def digit' : parser_tactic ℤ :=
do x <- digit,
   if (x = '0') then return 0 else
   if (x = '1') then return 1 else
   if (x = '2') then return 2 else
   if (x = '3') then return 3 else
   if (x = '4') then return 4 else
   if (x = '5') then return 5 else
   if (x = '6') then return 6 else
   if (x = '7') then return 7 else
   if (x = '8') then return 8 else
   if (x = '9') then return 9 else
   fail

meta def number : parser_tactic ℤ := (repeat digit') >>= return ∘ from_base_10

meta def parse_number (arg : string) : tactic unit :=
do n <- number.to_tactic arg,
   tactic.exact `(n)

mutual inductive addop,mulop,digit,factor,term,expr
with addop : Type
     | plus             : addop
     | minus            : addop
with mulop : Type
     | mult             : mulop
     | div              : mulop
with digit : Type
     | zero             : digit
     | one              : digit
     | two              : digit
     | three            : digit
     | four             : digit
     | five             : digit
     | six              : digit
     | seven            : digit
     | eight            : digit
     | nine             : digit
with factor : Type
     | of_digit         : digit → factor
     | of_expr          : expr  → factor
with term : Type
     | of_factor        : factor → term
     | of_mulop         : mulop → term → factor → term
with expr : Type
     | of_term          : term → expr
     | of_addop         : addop → expr → term → expr

def term.of_digit := term.of_factor ∘ factor.of_digit

def expr.of_digit := expr.of_term ∘ term.of_digit

meta mutual def eval_addop,eval_mulop,eval_digit,eval_factor,eval_term,eval_expr
with eval_addop                : addop → ℕ → ℕ → ℕ
     | addop.plus              := (nat.add)
     | addop.minus             := (nat.sub)
with eval_mulop                : mulop → ℕ → ℕ → ℕ
     | mulop.mult              := (nat.mul)
     | mulop.div               := (nat.div)
with eval_digit                : digit → ℕ
     | digit.zero              := 0
     | digit.one               := 1
     | digit.two               := 2
     | digit.three             := 3
     | digit.four              := 4
     | digit.five              := 5
     | digit.six               := 6
     | digit.seven             := 7
     | digit.eight             := 8
     | digit.nine              := 9
with eval_factor               : factor → ℕ
     | (factor.of_digit k)     := eval_digit k
     | (factor.of_expr e)      := eval_expr e
with eval_term                 : term → ℕ
     | (term.of_factor f)      := eval_factor f
     | (term.of_mulop op t f)  := (eval_mulop op) (eval_term t) (eval_factor f)
with eval_expr                 : expr → ℕ
     | (expr.of_term t)        := eval_term t
     | (expr.of_addop op e t)  := (eval_addop op) (eval_expr e) (eval_term t)

meta def nat.to_fmt : ℕ → format := nat.has_to_format.to_format

meta instance format_digit : has_to_format digit :=
⟨λ x, nat.to_fmt (eval_digit x)⟩

meta instance format_factor : has_to_format factor :=
⟨λ x, nat.to_fmt (eval_factor x)⟩

meta instance format_term : has_to_format term :=
⟨λ x, nat.to_fmt (eval_term x)⟩

meta instance format_expr : has_to_format expr :=
⟨λ x, nat.to_fmt (eval_expr x)⟩

/-
c.f. Hutton-Meijer:

expr :: Parser Int
addop :: Parser (Int -> Int -> Int)
mulop :: Parser (Int -> Int -> Int)

expr = chainl1 term addop
term = chainl1 factor mulop
factor = digit +++ (do symb "("; n <- expr; symb ")"; return n)
digit = (do <- token (sat isDigit); return(ord x - ord '0'))
addop = (do symb "+"; return (+)) <|> (do symb "-"; return (-)))
multop = (do symb "*"; return (*)) <|> (do symb "/"; return (/)))

Since mutual recursion in Lean seems to require use of the equation compiler,
we hack around this by exposing the underlying `parser_tactic.run` function,
later recovering the parser with `parser_tactic.mk`.
-/

meta mutual def parse_addop,parse_mulop,parse_digit,parse_factor,parse_term,parse_expr
with parse_addop                : string → tactic ((ℤ → ℤ → ℤ) × string)
| arg := (symb "+" >> return (+) <|> symb "-" >> return (λ x y : ℤ, x - y)).run arg
with parse_mulop                : string → tactic ((ℤ → ℤ → ℤ) × string)
| arg := (symb "*" >> return (*) <|> symb "/" >> return (λ x y : ℤ, x / y)).run arg
with parse_digit                : string → tactic (ℤ × string)
| arg := (token $ digit').run arg
with parse_factor               : string → tactic (ℤ × string)
| arg := (mk parse_digit <|> do symb "(", e <- (mk parse_expr), symb ")", return e).run arg
with parse_term                 : string → tactic (ℤ × string)
| arg := (chainl1 (mk parse_factor) (mk parse_mulop)).run arg
with parse_expr                 : string → tactic (ℤ × string)
| arg := (chainl1 (mk parse_term) (mk parse_addop)).run arg

meta def calculator : parser_tactic ℤ := mk parse_expr

run_cmd calculator.run' "(2 * (3 + 5 + (2 * 2)))"
-- 24

run_cmd calculator.run' "9 - 9 * 0 * 3 + 4 - 7"
-- 6

end calculator

end calculator

section parse_tree_from_list

inductive my_tree
| node : option string → my_tree
| join : list my_tree → option string → my_tree

open my_tree

-- def list.reflect {α} [has_reflect α] : has_reflect $ list α :=
-- begin
--   sorry
-- end

meta instance my_tree.reflect : has_reflect my_tree
| (node arg)           := `(λ x, node x).subst `(arg)
| (join xs arg)        := (`(λ xs s, join xs s).subst (by haveI := my_tree.reflect; exact list.reflect xs)).subst `(arg)

meta def my_tree_format : my_tree → format
| (node none)           := "• "
| (node $ some st)      := sformat!"{st} "
| (join xs none)        := "{• || " ++ format.join ((xs.map my_tree_format).intersperse "  |  ") ++ "}"
| (join xs $ some st)   := "{" ++ sformat!"{st} || " ++ " || " ++ format.join ((xs.map my_tree_format).intersperse "  |  ") ++ "}"

meta instance : has_to_format my_tree := ⟨my_tree_format⟩

/-
(a, b, c, (d, e), f) should be parsed as

  none -------┐
 / | \ \      |
a  b c  none  f
        |  \
        d   e
-/

meta mutual def my_tree_parser₁,my_tree_parser₂
with my_tree_parser₁ : string → tactic (my_tree × string)
| arg := ((do int <- (fail_if_nil $ delimiter'' "(" ")"),
               ts  <- (run_parser (mk my_tree_parser₂) int),
               return (my_tree.join ts none))
            <|>
           (do x <- not_str ",",
               return $ my_tree.node x)).run arg
with my_tree_parser₂ : string → tactic (list my_tree × string)
| arg := (sepby (mk my_tree_parser₁) (symb ",")).run arg

meta def my_tree_parser : parser_tactic my_tree := mk my_tree_parser₁

def my_parse_tree : my_tree := by my_tree_parser.get_result "(a,b,c)"

#print my_parse_tree

#eval (to_fmt my_parse_tree).to_string
/- {• || a   |  b   |  c } -/
run_cmd my_tree_parser.run' "(a, b, c)"
/- {• || a   |  b   |  c } -/
run_cmd my_tree_parser.run' "(a,(b,c))"
/- {• || a   |  {• || b   |  c }} -/
run_cmd my_tree_parser.run' "((a,b),c)"
/- {• || {• || a   |  b }  |  c } -/
run_cmd my_tree_parser.run' "(a, b, c, (d, e), f)"
/- {• || a   |  b   |  c   |  {• || d   |  e }  |  f } -/

section formatting_tests

example : my_tree := node none
def example_tree : my_tree := join [node none, node none, node none] "foo"

def example_tree2 : my_tree := join [join [node "a", node "b"] none, node "foo"] "bar"

run_cmd (return example_tree  : parser_tactic my_tree).run' "ab"
run_cmd (return example_tree2 : parser_tactic my_tree).run' "ab"

end formatting_tests

end parse_tree_from_list

namespace tdop
section tdop1
/- Top-down operator-precedence parsing, but with tokens hard-coded as their own inductive types -/

structure Tokens :=
(tks   : Type)
(prec  : tks → ℕ)

@[derive has_reflect, derive decidable_eq]
inductive arith_tks : Type
| of_nat : ℕ → arith_tks
| plus : arith_tks
| mul  : arith_tks
export arith_tks

meta def arith_tks.to_format : arith_tks → format := λ x, arith_tks.cases_on x (λ n, (to_fmt n)) (to_fmt "+") (to_fmt "*")

meta instance arith_tks.has_to_format : has_to_format arith_tks :=
⟨arith_tks.to_format⟩

instance : has_coe ℕ arith_tks :=
⟨of_nat⟩

def arith_Tokens : Tokens :=
{ tks := arith_tks,
  prec := arith_tks.rec (λ _, 0) 10 15 }

instance arith_tks_Tokens_coe : has_coe arith_tks arith_Tokens.tks := ⟨id⟩

inductive tdop_parse_tree (Tks : Tokens) : Type
| node : Tks.tks → tdop_parse_tree
| join : list tdop_parse_tree → Tks.tks → tdop_parse_tree
export tdop_parse_tree

meta instance arith_tree_reflect : Π τ : tdop_parse_tree arith_Tokens, reflected τ
| (node l)                  := `(λ x, node x).subst `(l)
| (join τs l)               := (λ y, `(λ x, join x y).subst (by {haveI := arith_tree_reflect, exact (list.reflect τs)})) l

def tdop_parse_tree.make_branch {Tks : Tokens} (τ : tdop_parse_tree Tks) (τ₀ : tdop_parse_tree Tks) : tdop_parse_tree Tks :=
begin
  induction τ with n j label,
    { exact tdop_parse_tree.join ([τ₀]) n },
    { exact join (τ₀ :: j) label }
end

def tdop_parse_tree.insert {Tks : Tokens} (τ : tdop_parse_tree Tks) (tk : Tks.tks) : tdop_parse_tree Tks :=
τ.make_branch (node tk)

def my_tdop_parse_tree : tdop_parse_tree arith_Tokens :=
join [node (1 : ℕ), node (2 : ℕ)] plus

meta def of.mk {α : Type} [has_reflect α] {Tks : Tokens} (Tks_eval : (tdop_parse_tree Tks) → tactic α) (τ : tdop_parse_tree Tks) : tactic unit :=
do a <- (Tks_eval τ), tactic.exact `(a)

section arith_eval

instance : has_add $ option ℕ :=
⟨λ k₁ k₂,
option.cases_on k₁ (option.cases_on k₂ none (λ _, none)) (option.cases_on k₂ (λ _, none) (λ n₁ n₂, return $ n₁ + n₂))⟩

instance : has_mul $ option ℕ :=
⟨λ k₁ k₂,
option.cases_on k₁ (option.cases_on k₂ none (λ _, none)) (option.cases_on k₂ (λ _, none) (λ n₁ n₂, return $ n₁ * n₂))⟩

meta def arith_Tokens_eval : tdop_parse_tree arith_Tokens → option ℕ
| (node arg) := arith_tks.cases_on arg pure none none
| (join xs arg) := arith_tks.cases_on arg (λ _, none) ((xs.map arith_Tokens_eval).foldr (+) (some 0)) ((xs.map arith_Tokens_eval).foldr (*) (some 0))

meta def of_arith_Tokens : tdop_parse_tree arith_Tokens → tactic unit :=
of.mk (λ x, arith_Tokens_eval x)

meta def my_three : ℕ := by of_arith_Tokens my_tdop_parse_tree

#eval my_three -- 3

end arith_eval

meta def arith_tks.parse : parser_tactic arith_tks :=
     ((do n <- number, return n) <* whitespace)
 <|> (token (str "+") >> return plus)
 <|> (token (str "*") >> return mul)

-- run_cmd (repeat $ arith_tks.parse).run' "1 + 3 + 5 * 2"

meta def parse_nat : Π (left : tdop_parse_tree arith_Tokens), string → tactic (tdop_parse_tree arith_Tokens × string)
| left arg := (do n <- (token number), return (left.insert (of_nat n))).run arg

meta def parse_plus : Π (left : tdop_parse_tree arith_Tokens), string → tactic (tdop_parse_tree arith_Tokens × string)
| left arg := (token (str "+") >> return ((node plus : tdop_parse_tree arith_Tokens).make_branch left)).run arg

meta def parse_mul  : Π (left : tdop_parse_tree arith_Tokens), string → tactic (tdop_parse_tree arith_Tokens × string)
| left arg := (token (str "*") >> return ((node mul : tdop_parse_tree arith_Tokens).make_branch left)).run arg

meta def arith_tdop_parser' : Π (left : tdop_parse_tree arith_Tokens), parser_tactic (tdop_parse_tree arith_Tokens)
| left := (mk $ parse_nat left) <|> (mk $ parse_plus left) <|> (mk $ parse_mul left)

meta def arith_tdop_parser_aux : Π flag : bool, Π result : tdop_parse_tree arith_Tokens,  parser_tactic (tdop_parse_tree arith_Tokens)
| ff _ := arith_tdop_parser' (node $ of_nat 0) >>= arith_tdop_parser_aux tt
| tt τ := (arith_tdop_parser' τ >>= arith_tdop_parser_aux tt) <|> return τ

meta def arith_tdop_parser : parser_tactic (tdop_parse_tree arith_Tokens)
:= arith_tdop_parser_aux ff (node $ of_nat 0)

meta def tdop_arith.to_format : (tdop_parse_tree arith_Tokens) → format
| (node l) := arith_tks.to_format l
| (join τs l) := "( " ++ (tdop_arith.to_format $ node l) ++ " || " ++ (string.join (((τs.map tdop_arith.to_format).map format.to_string).intersperse " ,")) ++ ")"

meta instance tdop_parse_to_format : has_to_format (tdop_parse_tree arith_Tokens) := ⟨tdop_arith.to_format⟩

run_cmd (do arith_tdop_parser' (node $ of_nat 0) >>= arith_tdop_parser' >>= arith_tdop_parser').run' "1 + 2"

--TODO(jesse) fix this
run_cmd (arith_tdop_parser).run' "1 + 2 + 3 * 4 + 5"

end tdop1
end tdop


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

Monad encapsulating continuation passing programming style, similar to
Haskell's `Cont`, `ContT` and `MonadCont`:
<http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Cont.html>
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.monad.writer
import Mathlib.PostPort

universes u v w l u_1 u_2 u₀ u₁ v₀ v₁

namespace Mathlib

structure monad_cont.label (α : Type w) (m : Type u → Type v) (β : Type u)
where
  apply : α → m β

def monad_cont.goto {α : Type u_1} {β : Type u} {m : Type u → Type v} (f : monad_cont.label α m β) (x : α) : m β :=
  monad_cont.label.apply f x

class monad_cont (m : Type u → Type v)
where
  call_cc : {α β : Type u} → (monad_cont.label α m β → m α) → m α

class is_lawful_monad_cont (m : Type u → Type v) [Monad m] [monad_cont m]
extends is_lawful_monad m
where
  call_cc_bind_right : ∀ {α ω γ : Type u} (cmd : m α) (next : monad_cont.label ω m γ → α → m ω),
  (monad_cont.call_cc fun (f : monad_cont.label ω m γ) => cmd >>= next f) =
    do
      let x ← cmd
      monad_cont.call_cc fun (f : monad_cont.label ω m γ) => next f x
  call_cc_bind_left : ∀ {α : Type u} (β : Type u) (x : α) (dead : monad_cont.label α m β → β → m α),
  (monad_cont.call_cc fun (f : monad_cont.label α m β) => monad_cont.goto f x >>= dead f) = pure x
  call_cc_dummy : ∀ {α β : Type u} (dummy : m α), (monad_cont.call_cc fun (f : monad_cont.label α m β) => dummy) = dummy

def cont_t (r : Type u) (m : Type u → Type v) (α : Type w) :=
  (α → m r) → m r

def cont (r : Type u) (α : Type w) :=
  cont_t r id α

namespace cont_t

def run {r : Type u} {m : Type u → Type v} {α : Type w} : cont_t r m α → (α → m r) → m r :=
  id

def map {r : Type u} {m : Type u → Type v} {α : Type w} (f : m r → m r) (x : cont_t r m α) : cont_t r m α :=
  f ∘ x

theorem run_cont_t_map_cont_t {r : Type u} {m : Type u → Type v} {α : Type w} (f : m r → m r) (x : cont_t r m α) : run (map f x) = f ∘ run x :=
  rfl

def with_cont_t {r : Type u} {m : Type u → Type v} {α : Type w} {β : Type w} (f : (β → m r) → α → m r) (x : cont_t r m α) : cont_t r m β :=
  fun (g : β → m r) => x (f g)

theorem run_with_cont_t {r : Type u} {m : Type u → Type v} {α : Type w} {β : Type w} (f : (β → m r) → α → m r) (x : cont_t r m α) : run (with_cont_t f x) = run x ∘ f :=
  rfl

protected theorem ext {r : Type u} {m : Type u → Type v} {α : Type w} {x : cont_t r m α} {y : cont_t r m α} (h : ∀ (f : α → m r), run x f = run y f) : x = y :=
  funext fun (x_1 : α → m r) => h x_1

protected instance monad {r : Type u} {m : Type u → Type v} : Monad (cont_t r m) := sorry

protected instance is_lawful_monad {r : Type u} {m : Type u → Type v} : is_lawful_monad (cont_t r m) :=
  is_lawful_monad.mk
    (fun (α β : Type u_1) (x : α) (f : α → cont_t r m β) =>
      cont_t.ext fun (f_1 : β → m r) => Eq.refl (run (pure x >>= f) f_1))
    fun (α β γ : Type u_1) (x : cont_t r m α) (f : α → cont_t r m β) (g : β → cont_t r m γ) =>
      cont_t.ext fun (f_1 : γ → m r) => Eq.refl (run (x >>= f >>= g) f_1)

def monad_lift {r : Type u} {m : Type u → Type v} [Monad m] {α : Type u} : m α → cont_t r m α :=
  fun (x : m α) (f : α → m r) => x >>= f

protected instance has_monad_lift {r : Type u} {m : Type u → Type v} [Monad m] : has_monad_lift m (cont_t r m) :=
  has_monad_lift.mk fun (α : Type u) => monad_lift

theorem monad_lift_bind {r : Type u} {m : Type u → Type v} [Monad m] [is_lawful_monad m] {α : Type u} {β : Type u} (x : m α) (f : α → m β) : monad_lift (x >>= f) = monad_lift x >>= monad_lift ∘ f := sorry

protected instance monad_cont {r : Type u} {m : Type u → Type v} : monad_cont (cont_t r m) :=
  monad_cont.mk
    fun (α β : Type u_1) (f : label α (cont_t r m) β → cont_t r m α) (g : α → m r) =>
      f (monad_cont.label.mk fun (x : α) (h : β → m r) => g x) g

protected instance is_lawful_monad_cont {r : Type u} {m : Type u → Type v} : is_lawful_monad_cont (cont_t r m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

protected instance monad_except {r : Type u} {m : Type u → Type v} (ε : outParam (Type u_1)) [monad_except ε m] : monad_except ε (cont_t r m) :=
  monad_except.mk (fun (x : Type u_2) (e : ε) (f : x → m r) => throw e)
    fun (α : Type u_2) (act : cont_t r m α) (h : ε → cont_t r m α) (f : α → m r) => catch (act f) fun (e : ε) => h e f

protected instance monad_run {r : Type u} {m : Type u → Type v} : monad_run (fun (α : Type u) => (α → m r) → ulift (m r)) (cont_t r m) :=
  monad_run.mk fun (α : Type u) (f : cont_t r m α) (x : α → m r) => ulift.up (f x)

end cont_t

def except_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {ε : Type u} : label (except ε α) m β → label α (except_t ε m) β :=
  sorry

theorem except_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {ε : Type u} (x : label (except ε α) m β) (i : α) : goto (except_t.mk_label x) i = except_t.mk (except.ok <$> goto x (except.ok i)) :=
  monad_cont.label.cases_on x fun (x : except ε α → m β) => Eq.refl (goto (except_t.mk_label (monad_cont.label.mk x)) i)

def except_t.call_cc {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] {α : Type u} {β : Type u} (f : label α (except_t ε m) β → except_t ε m α) : except_t ε m α :=
  except_t.mk (monad_cont.call_cc fun (x : label (except ε α) m β) => except_t.run (f (except_t.mk_label x)))

protected instance except_t.monad_cont {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] : monad_cont (except_t ε m) :=
  monad_cont.mk fun (α β : Type u) => except_t.call_cc

protected instance except_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (except_t ε m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

def option_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} : label (Option α) m β → label α (option_t m) β :=
  sorry

theorem option_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} (x : label (Option α) m β) (i : α) : goto (option_t.mk_label x) i = option_t.mk (some <$> goto x (some i)) :=
  monad_cont.label.cases_on x fun (x : Option α → m β) => Eq.refl (goto (option_t.mk_label (monad_cont.label.mk x)) i)

def option_t.call_cc {m : Type u → Type v} [Monad m] [monad_cont m] {α : Type u} {β : Type u} (f : label α (option_t m) β → option_t m α) : option_t m α :=
  option_t.mk (monad_cont.call_cc fun (x : label (Option α) m β) => option_t.run (f (option_t.mk_label x)))

protected instance option_t.monad_cont {m : Type u → Type v} [Monad m] [monad_cont m] : monad_cont (option_t m) :=
  monad_cont.mk fun (α β : Type u) => option_t.call_cc

protected instance option_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (option_t m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

def writer_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u} {ω : Type u} [HasOne ω] : label (α × ω) m β → label α (writer_t ω m) β :=
  sorry

theorem writer_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u} {ω : Type u} [HasOne ω] (x : label (α × ω) m β) (i : α) : goto (writer_t.mk_label x) i = monad_lift (goto x (i, 1)) :=
  monad_cont.label.cases_on x fun (x : α × ω → m β) => Eq.refl (goto (writer_t.mk_label (monad_cont.label.mk x)) i)

def writer_t.call_cc {m : Type u → Type v} [Monad m] [monad_cont m] {α : Type u} {β : Type u} {ω : Type u} [HasOne ω] (f : label α (writer_t ω m) β → writer_t ω m α) : writer_t ω m α :=
  writer_t.mk (monad_cont.call_cc (writer_t.run ∘ f ∘ writer_t.mk_label))

protected instance writer_t.monad_cont {m : Type u → Type v} [Monad m] (ω : Type u) [Monad m] [HasOne ω] [monad_cont m] : monad_cont (writer_t ω m) :=
  monad_cont.mk fun (α β : Type u) => writer_t.call_cc

def state_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {σ : Type u} : label (α × σ) m (β × σ) → label α (state_t σ m) β :=
  sorry

theorem state_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {σ : Type u} (x : label (α × σ) m (β × σ)) (i : α) : goto (state_t.mk_label x) i = state_t.mk fun (s : σ) => goto x (i, s) :=
  monad_cont.label.cases_on x fun (x : α × σ → m (β × σ)) => Eq.refl (goto (state_t.mk_label (monad_cont.label.mk x)) i)

def state_t.call_cc {m : Type u → Type v} [Monad m] {σ : Type u} [monad_cont m] {α : Type u} {β : Type u} (f : label α (state_t σ m) β → state_t σ m α) : state_t σ m α :=
  state_t.mk
    fun (r : σ) => monad_cont.call_cc fun (f' : label (α × σ) m (β × σ)) => state_t.run (f (state_t.mk_label f')) r

protected instance state_t.monad_cont {m : Type u → Type v} [Monad m] {σ : Type u} [monad_cont m] : monad_cont (state_t σ m) :=
  monad_cont.mk fun (α β : Type u) => state_t.call_cc

protected instance state_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] {σ : Type u} [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (state_t σ m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

def reader_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u} (ρ : Type u) : label α m β → label α (reader_t ρ m) β :=
  sorry

theorem reader_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {ρ : Type u} {β : Type u} (x : label α m β) (i : α) : goto (reader_t.mk_label ρ x) i = monad_lift (goto x i) :=
  monad_cont.label.cases_on x fun (x : α → m β) => Eq.refl (goto (reader_t.mk_label ρ (monad_cont.label.mk x)) i)

def reader_t.call_cc {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] {α : Type u} {β : Type u} (f : label α (reader_t ε m) β → reader_t ε m α) : reader_t ε m α :=
  reader_t.mk fun (r : ε) => monad_cont.call_cc fun (f' : label α m β) => reader_t.run (f (reader_t.mk_label ε f')) r

protected instance reader_t.monad_cont {m : Type u → Type v} [Monad m] {ρ : Type u} [monad_cont m] : monad_cont (reader_t ρ m) :=
  monad_cont.mk fun (α β : Type u) => reader_t.call_cc

protected instance reader_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] {ρ : Type u} [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (reader_t ρ m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

/-- reduce the equivalence between two continuation passing monads to the equivalence between
their underlying monad -/
def cont_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ : Type u₀} {r₁ : Type u₀} {α₂ : Type u₁} {r₂ : Type u₁} (F : m₁ r₁ ≃ m₂ r₂) (G : α₁ ≃ α₂) : cont_t r₁ m₁ α₁ ≃ cont_t r₂ m₂ α₂ :=
  equiv.mk
    (fun (f : cont_t r₁ m₁ α₁) (r : α₂ → m₂ r₂) => coe_fn F (f fun (x : α₁) => coe_fn (equiv.symm F) (r (coe_fn G x))))
    (fun (f : cont_t r₂ m₂ α₂) (r : α₁ → m₁ r₁) =>
      coe_fn (equiv.symm F) (f fun (x : α₂) => coe_fn F (r (coe_fn (equiv.symm G) x))))
    sorry sorry


import free_pfpng.epi
import free_pfpng.mono

noncomputable theory

open_locale classical big_operators

open category_theory
open opposite
open category_theory.grothendieck_topology

universe u

lemma Condensed.is_zero_of_is_zero_obj (A : Condensed.{u} Ab.{u+1})
  (hA : ∀ S : Profinite.{u}, limits.is_zero (A.val.obj (opposite.op S))) :
  limits.is_zero A :=
{ unique_to := λ Y, nonempty.intro
  { default := 0,
    uniq := λ a, begin
      ext t : 3,
      apply (hA t.unop).eq_of_src,
    end },
  unique_from := λ Y, nonempty.intro
  { default := 0,
    uniq := λ a, begin
      ext t : 3,
      apply (hA t.unop).eq_of_tgt
    end } }

lemma Profinite.free_pfpng_eq_zero_of_empty (S : Profinite.{u}) [is_empty S]
  (a : S.free_pfpng) : a = 0 :=
begin
  let E : limits.cone ((S.fintype_diagram ⋙ free_pfpng_functor)) :=
    ProFiltPseuNormGrp₁.bounded_cone ⟨Ab.explicit_limit_cone.{u u} _,
      Ab.explicit_limit_cone_is_limit _⟩,
  let hE : limits.is_limit E :=
    ProFiltPseuNormGrp₁.bounded_cone_is_limit _,
  let ee : S.free_pfpng ≅ E.X :=
    (limits.limit.is_limit _).cone_point_unique_up_to_iso hE,
  apply_fun ee.hom, swap,
  { intros x y h, apply_fun ee.inv at h, simpa using h },
  rw ee.hom.map_zero, ext T t,
  obtain ⟨s⟩ := t,
  apply is_empty.elim _ (s : S), assumption
end

lemma Profinite.is_zero_of_empty (S : Profinite.{u}) [is_empty S] :
  limits.is_zero S.condensed_free_pfpng :=
begin
  apply Condensed.is_zero_of_is_zero_obj,
  intros T,
  dsimp [Profinite.condensed_free_pfpng],
  dsimp [CompHausFiltPseuNormGrp.presheaf],
  apply is_zero_Ab,
  rintros ⟨⟨f,hf⟩⟩, ext t, change f t = 0,
  apply Profinite.free_pfpng_eq_zero_of_empty,
end

lemma category_theory.abelian.is_iso_of_mono_of_is_zero
  {A : Type*} [category A] [abelian A] {X Y : A} (f : X ⟶ Y) [mono f]
  (hY : limits.is_zero Y) : is_iso f :=
begin
  use 0, simp, split,
  rw ← cancel_mono f,
  apply hY.eq_of_tgt,
  apply hY.eq_of_tgt,
end

instance Profinite.epi_free'_to_condensed_free_pfpng_of_empty
  (S : Profinite.{u}) [is_empty S] :
  epi S.free'_to_condensed_free_pfpng :=
begin
  suffices : is_iso S.free'_to_condensed_free_pfpng,
  { resetI, apply_instance },
  apply category_theory.abelian.is_iso_of_mono_of_is_zero,
  apply Profinite.is_zero_of_empty,
end

-- Do a case split on `[nonempty S]` here.
instance Profinite.epi_free'_to_condensed_free_pfpng (S : Profinite.{u}) :
  epi S.free'_to_condensed_free_pfpng :=
begin
  by_cases hS : nonempty S, { resetI, apply_instance },
  simp only [not_nonempty_iff] at hS,
  resetI, apply_instance
end

instance Profinite.is_iso_free'_to_condensed_free_pfpng
  (S : Profinite.{u}) : is_iso S.free'_to_condensed_free_pfpng :=
is_iso_of_mono_of_epi _

def Profinite.free_to_pfpng (S : Profinite.{u}) :
  CondensedSet_to_Condensed_Ab.obj S.to_Condensed ⟶
  S.condensed_free_pfpng :=
(Condensed_Ab_CondensedSet_adjunction.hom_equiv _ _).symm S.to_condensed_free_pfpng

attribute [simps hom_app] AddCommGroup.free_iso_free'

instance Profinite.is_iso_free_to_pfpng (S : Profinite.{u}) : is_iso S.free_to_pfpng :=
begin
  suffices : S.free_to_pfpng =
    (CondensedSet_to_Condensed_Ab_iso.app S.to_Condensed).hom ≫
    S.free'_to_condensed_free_pfpng,
  { rw this, apply_instance },
  rw [iso.app_hom],
  delta Profinite.free'_to_condensed_free_pfpng Profinite.free'_lift Profinite.free_to_pfpng
    CondensedSet_to_Condensed_Ab_iso Sheaf.adjunction
    Condensed_Ab_CondensedSet_adjunction Condensed_Ab_CondensedSet_adjunction',
  ext T : 4,
  dsimp only [adjunction.mk_of_hom_equiv_hom_equiv, functor.map_iso_hom, quiver.hom.forget_Ab,
    Sheaf.hom.comp_val, Condensed_Ab_to_CondensedSet_map, Sheaf.compose_equiv_symm_apply_val,
    presheaf_to_Sheaf_map_val, nat_trans.comp_app,
    iso_whisker_left_hom, iso_whisker_right_hom, whisker_left_app, whisker_right_app],
  rw [← nat_trans.comp_app, sheafify_map_sheafify_lift],
  congr' 4, clear T,
  ext T : 2,
  dsimp only [whiskering_right_map_app_app, whiskering_right_obj_map, nat_trans.comp_app,
    adjunction.whisker_right, adjunction.mk_of_unit_counit_hom_equiv_symm_apply,
    whisker_left_app, whisker_right_app,
    functor.associator_hom_app, functor.right_unitor_hom_app],
  erw [category.id_comp, category.id_comp, category.comp_id, category.comp_id],
  rw [← nat_trans.naturality_assoc],
  congr' 1,
  dsimp only [AddCommGroup.adj, AddCommGroup.adj', adjunction.mk_of_hom_equiv_hom_equiv,
    adjunction.of_nat_iso_left, adjunction.mk_of_hom_equiv_counit_app,
    equiv.inv_fun_as_coe, equiv.symm_trans_apply, iso.symm_hom,
    adjunction.equiv_homset_left_of_nat_iso_symm_apply],
  simp only [equiv.symm_symm],
  erw [← category.assoc, ← nat_trans.comp_app, iso.hom_inv_id, nat_trans.id_app,
    category.id_comp],
end

lemma free_pfpng_profinite_natural_map_aux (S T : Profinite.{u}) (f : S ⟶ T) :
  f ≫ T.to_free_pfpng = S.to_free_pfpng ≫
    (ProFiltPseuNormGrp₁.level.obj 1).map
    ((Profinite.extend free_pfpng_functor).map f) :=
begin
  apply (limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1)
   (limits.limit.is_limit _)).hom_ext,
  intros W, dsimp [Profinite.to_free_pfpng,
    Profinite.free_pfpng_level_iso, limits.is_limit.cone_point_unique_up_to_iso,
    limits.is_limit.map],
  simp only [category.assoc],
  erw (limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1)
    (limits.limit.is_limit (T.fintype_diagram ⋙ free_pfpng_functor))).fac,
  erw limits.limit.lift_π,
  swap, apply_instance,
  simp only [← functor.map_comp, limits.limit.lift_π],
  dsimp [Profinite.change_cone],
  simp only [functor.map_comp],
  erw (limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1)
    (limits.limit.is_limit (S.fintype_diagram ⋙ free_pfpng_functor))).fac_assoc,
  erw limits.limit.lift_π_assoc,
  ext, dsimp [Profinite.as_limit_cone, Fintype.free_pfpng_unit, free_pfpng.map,
    ProFiltPseuNormGrp₁.level],
  rcases x with ⟨x⟩,
  simp only [finset.filter_congr_decidable],
  erw [finset.sum_filter, finset.sum_ite, finset.sum_ite],
  simp only [finset.filter_congr_decidable, finset.sum_const,
    nat.smul_one_eq_coe, finset.sum_const_zero, add_zero],
  rw finset.filter_filter,
  split_ifs,
  { symmetry, norm_cast, rw finset.card_eq_one,
    use (W.comap f.2).proj a,
    rw finset.eq_singleton_iff_nonempty_unique_mem,
    split,
    { rw finset.filter_nonempty_iff,
      use (W.comap f.2).proj a,
      refine ⟨finset.mem_univ _, h, rfl⟩ },
    { rintros ⟨q⟩ hq,
      simp only [finset.mem_filter, finset.mem_univ, true_and] at hq,
      erw hq.2 } },
  { symmetry, norm_cast,
    simp only [finset.card_eq_zero],
    rw finset.filter_eq_empty_iff,
    rintros ⟨q⟩ -, push_neg, intros hh,
    rw ← hh at h,
    erw discrete_quotient.map_proj_apply at h,
    contrapose! h,
    let e : (W.comap f.2) → W := discrete_quotient.map (le_refl _),
    apply_fun e at h, exact h },
end

def free_pfpng_profinite_natural_map :
  Profinite_to_Condensed ⋙ CondensedSet_to_Condensed_Ab ⟶
  Profinite.extend free_pfpng_functor ⋙
  PFPNG₁_to_CHFPNG₁ₑₗ ⋙
  CHFPNG₁_to_CHFPNGₑₗ ⋙
  CompHausFiltPseuNormGrp.to_Condensed :=
{ app := λ X, X.free_to_pfpng,
  naturality' := λ S T f, begin
    -- we should be able to precompose with the natural map `S.to_Condensed ⟶ S.free'`
    -- how do we do that?
    -- Answer: use `adjunction.hom_equiv`.
    dsimp only [functor.comp_map],
    dsimp only [Profinite.free_to_pfpng],
    apply_fun (Condensed_Ab_CondensedSet_adjunction.hom_equiv _ _),
    simp only [adjunction.hom_equiv_unit, adjunction.hom_equiv_counit, functor.map_comp],
    simp only [nat_trans.naturality, category.assoc, nat_trans.naturality_assoc],
    dsimp only [Profinite.condensed_free_pfpng],
    have := Condensed_Ab_CondensedSet_adjunction.unit.naturality
      (Profinite_to_Condensed.map f),
    dsimp only [functor.comp_map] at this,
    slice_lhs 1 2 { rw ← this }, clear this,
    dsimp only [functor.id_map], simp only [category.assoc],
    have := Condensed_Ab_CondensedSet_adjunction.unit.naturality
      S.to_condensed_free_pfpng,
    dsimp only [functor.comp_map] at this,
    slice_rhs 1 2 { erw ← this }, clear this,
    dsimp only [functor.id_map], simp only [category.assoc],
    have := Condensed_Ab_CondensedSet_adjunction.right_triangle_components,
    slice_rhs 2 3 { erw this }, clear this,
    erw category.id_comp,
    slice_lhs 2 3 { erw ← nat_trans.naturality },
    simp only [functor.id_map, category.assoc],
    have := Condensed_Ab_CondensedSet_adjunction.right_triangle_components,
    slice_lhs 3 4 { rw this }, clear this,
    erw category.comp_id,
    ext W ⟨t⟩ : 7, change W.unop ⟶ S at t,

    dsimp [Profinite.to_condensed_free_pfpng,
      CompHausFiltPseuNormGrp.level_Condensed_diagram_cocone,
      Ab.ulift, Profinite.to_free_pfpng_level],
    erw ← comp_apply,
    erw ← comp_apply,
    erw ← comp_apply,
    rw free_pfpng_profinite_natural_map_aux _ _ f, refl,
  end }

instance free_pfpng_profinite_natural_map_is_iso :
  is_iso free_pfpng_profinite_natural_map :=
begin
  apply_with nat_iso.is_iso_of_is_iso_app { instances := ff },
  intros X,
  apply X.is_iso_free_to_pfpng,
end

def free_pfpng_profinite_iso_aux :
  condensify (free_pfpng_functor ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) ≅
  ((Profinite.extend free_pfpng_functor ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) ⋙
    CHFPNG₁_to_CHFPNGₑₗ) ⋙
    CompHausFiltPseuNormGrp.to_Condensed :=
iso_whisker_right
  (iso_whisker_right
    (Profinite.extend_commutes free_pfpng_functor PFPNG₁_to_CHFPNG₁ₑₗ).symm
    CHFPNG₁_to_CHFPNGₑₗ)
  CompHausFiltPseuNormGrp.to_Condensed

/-- Prop 2.1 of Analytic.pdf -/
def free_pfpng_profinite_iso :
  condensify (free_pfpng_functor ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) ≅
  Profinite_to_Condensed ⋙ CondensedSet_to_Condensed_Ab :=
free_pfpng_profinite_iso_aux ≪≫ (as_iso free_pfpng_profinite_natural_map).symm


import tactic defs single height

lemma branch_left : ∀ t, ⟨t⟩ → ⟨⟦t∣⟧⟩ :=
begin intros, apply is_branch.left_nl, assumption end

lemma branch_left_leaf : ∀ t, ⟨t⟩ → ⟨⟦t,●⟧⟩ :=
begin intros, apply is_branch.left_l, assumption end

lemma branch_right : ∀ t, ⟨t⟩ → ⟨⟦∣t⟧⟩ :=
begin intros, apply is_branch.right_nl, assumption end

lemma branch_right_leaf : ∀ t, ⟨t⟩ → ⟨⟦●,t⟧⟩ :=
begin intros, apply is_branch.right_l, assumption end

meta def auto_branch_core : tactic unit :=
do
  h ← tactic.target,
  match h with
  | `(is_branch %%b):=
      match b with
      | `(●)      := tactic.exact `(is_branch.single)
      | `(⟦%%t∣⟧) := do tactic.applyc `branch_left, auto_branch_core
      | `(⟦∣%%t⟧) := do tactic.applyc `branch_right, auto_branch_core
      | `(⟦%%t,●⟧):= do tactic.applyc `branch_left_leaf,
                        auto_branch_core
      | `(⟦●,%%t⟧):= do tactic.applyc `branch_right_leaf,
                        auto_branch_core
      | _      := tactic.try (tactic.assumption <|> tactic.tautology)
      end
  | _ := tactic.fail "should not exists"
  end

meta def reduce_trivial_tree_core : list expr → tactic unit
| [] := tactic.skip
| (h :: hs) := do t ← tactic.infer_type h,
                  match t with
                  | `(%%b ↣ ●) := tactic.replace h.to_string ``(single_grow %%b %%h)
                  | `(height %%b ≤ 1) := tactic.replace h.to_string ``(height_le1_single %%b %%h)
                  | _ := tactic.skip
                  end,
                  reduce_trivial_tree_core hs

meta def reduce_trivial_tree : tactic unit :=
do
  h ← tactic.local_context,
  reduce_trivial_tree_core h

meta def rewrite_ci_core : list expr → tactic unit
| [] := tactic.skip
| (h :: hs) := do t ← tactic.infer_type h,
                  match t with
                  | `(%%b = ●) := tactic.try (tactic.subst h)
                  | _ := tactic.skip
                  end,
                  rewrite_ci_core hs

meta def rewrite_ci : tactic unit :=
do
  reduce_trivial_tree,
  h ← tactic.local_context,
  rewrite_ci_core h

meta def auto_grow_core : tactic unit :=
 do h ← tactic.target,
   match h with
   | `(grow %%t %%t') :=
          match t, t' with
          | `(●), _ := tactic.applyc `grow.single_grow
          | `(⟦%%u∣⟧), `(⟦%%u'∣⟧) :=
                       do tactic.applyc `grow.left_grow,
                          auto_grow_core
          | `(⟦∣%%v⟧), `(⟦∣%%v'⟧) :=
                       do tactic.applyc `grow.right_grow,
                          auto_grow_core
          | `(⟦%%u, %%v⟧), `(⟦%%u', %%v'⟧) :=
                       do tactic.applyc `grow.full_grow,
                          auto_grow_core,
                          auto_grow_core
          | _, _ := tactic.try (tactic.assumption <|> tactic.tautology)
          end
   | _ := tactic.fail "should not exists"
   end

meta def auto_grow : tactic unit :=
do
  rewrite_ci,
  auto_grow_core

meta def auto_branch : tactic unit :=
do
  rewrite_ci,
  auto_branch_core